lib/Utils.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: Utils.pm,v $
   4
   5 Utils - Simple and often used utilities
   6
   7 =head1 VERSION
   8
   9 =over
  10
  11 =item Author
  12
  13 Andrew DeFaria <Andrew@ClearSCM.com>
  14
  15 =item Revision
  16
  17 $Revision: 1.26 $
  18
  19 =item Created
  20
  21 Thu Jan  5 15:15:29 PST 2006
  22
  23 =item Modified
  24
  25 $Date: 2013/03/28 21:18:55 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  31 This module seeks to encapsulate useful utilities, things that are often done
  32 over and over again but who's classification is miscellaneous.
  33
  34   EnterDaemonMode
  35
  36   my @children = GetChildren ($pid);
  37
  38   my @lines = ReadFile ("/tmp/file");
  39
  40   print "Found foo!\n" if InArray ("foo", @bar);
  41
  42   my ($status, @output) = Execute ("ps -ef");
  43
  44 =head1 DESCRIPTION
  45
  46 A collection of utility type subroutines.
  47
  48 =head1 ROUTINES
  49
  50 The following routines are exported:
  51
  52 =cut
  53
  54 package Utils;
  55
  56 use strict;
  57 use warnings;
  58
  59 use FindBin;
  60
  61 use base 'Exporter';
  62
  63 use POSIX qw (setsid);
  64 use File::Spec;
  65 use Carp;
  66 use Term::ReadKey;
  67
  68 use OSDep;
  69 use Display;
  70
  71 our $pipe;
  72
  73 our @EXPORT = qw (
  74   CheckParms
  75   EnterDaemonMode
  76   Execute
  77   GetChildren
  78   GetPassword
  79   InArray
  80   LoadAvg
  81   PageOutput
  82   PipeOutput
  83   PipeOutputArray
  84   ReadFile
  85   RequiredFields
  86   RedirectOutput
  87   StartPipe
  88   Stats
  89   StopPipe
  90   Usage
  91 );
  92
  93 sub _restoreTerm() {
  94   # In case the user hits Ctrl-C
  95   print "\nControl-C\n";
  96
  97   ReadMode 'normal';
  98
  99   exit;
 100 } # _restoreTerm
 101
 102 sub CheckParms($$) {
 103   my ($requiredFields, $rec) = @_;
 104
 105   my $msg = RequiredFields($requiredFields, $rec);
 106
 107   my $function = (caller(1))[3];
 108
 109   croak "Internal error: $function: $msg" if $msg;
 110
 111   return;
 112 } # CheckParms
 113
 114 sub EnterDaemonMode(;$$$) {
 115   my ($logfile, $errorlog, $pidfile) = @_;
 116
 117 =pod
 118
 119 =head2 EnterDaemonMode ($logfile, $errorlog)
 120
 121 There is a right way to enter "daemon mode" and this routine is for that. If you
 122 call EnterDaemonMode your process will be disassociated from the terminal and
 123 enter into a background mode just like a good daemon.
 124
 125 Parameters:
 126
 127 =for html <blockquote>
 128
 129 =over
 130
 131 =item $logfile
 132
 133 File name of where to redirect STDOUT for the daemon (Default: $NULL)
 134
 135 =item $errorlog
 136
 137 File name of where to redirect STDERR for the daemon (Default: $NULL)
 138
 139 =back
 140
 141 =for html </blockquote>
 142
 143 Returns:
 144
 145 =for html <blockquote>
 146
 147 =over
 148
 149 =item Doesn't return
 150
 151 =back
 152
 153 =for html </blockquote>
 154
 155 =cut
 156
 157   $logfile  ||= $NULL;
 158   $errorlog ||= $NULL;
 159
 160   my $file;
 161
 162   # Redirect STDIN to $NULL
 163   open STDIN, '<', $NULL
 164     or error "Can't read $NULL ($!)", 1;
 165
 166   # Redirect STDOUT to logfile
 167   open STDOUT, '>>', $logfile
 168     or error "Can't write to $logfile ($!)", 1;
 169
 170   # Redirect STDERR to errorlog
 171   open STDERR, '>>', $errorlog
 172     or error "Can't write to $errorlog ($!)", 1;
 173
 174   # Change the current directory to /
 175   my $ROOT = $ARCHITECTURE eq "windows" ? "C:\\" : "/";
 176   chdir $ROOT
 177     or error "Can't chdir to $ROOT ($!), 1";
 178
 179   # Turn off umask
 180   umask 0;
 181
 182   # Now fork the daemon
 183   defined (my $pid = fork)
 184     or error "Can't create daemon ($!)", 1;
 185
 186   # Now the parent exits
 187   exit if $pid;
 188
 189   # Write pidfile if specified
 190   if ($pidfile) {
 191     $pidfile =  File::Spec->rel2abs ($pidfile);
 192
 193     open $file, '>', $pidfile
 194       or warning "Unable to open pidfile $pidfile for writing - $!";
 195
 196     print $file "$$\n";
 197
 198     close $file;
 199   } # if
 200
 201   # Set process to be session leader
 202   setsid ()
 203     or error "Can't start a new session ($!)", 1;
 204
 205   return;
 206 } # EnterDaemonMode
 207
 208 sub Execute($) {
 209   my ($cmd) = @_;
 210
 211 =pod
 212
 213 =head2 Execute ($command)
 214
 215 We all execute OS commands and then have to deal with the output and return
 216 codes and the like. How about an easy Execute subroutine. It takes one
 217 parameter, the command to execute, executes it and returns two parameters, the
 218 output in a nice chomped array and the status.
 219
 220 Parameters:
 221
 222 =for html <blockquote>
 223
 224 =over
 225
 226 =item $command
 227
 228 Command to execute
 229
 230 =back
 231
 232 =for html </blockquote>
 233
 234 Returns:
 235
 236 =for html <blockquote>
 237
 238 =over
 239
 240 =item A status scalar and an array of lines output from the command (if any).
 241
 242 Note, no redirection of STDERR is included. If you want STDERR included in
 243 STDOUT then do so in the $command passed in.
 244
 245 =back
 246
 247 =for html </blockquote>
 248
 249 =cut
 250
 251   local $SIG{CHLD} = 'DEFAULT';
 252
 253   my @output = `$cmd`;
 254   my $status = $?;
 255
 256   chomp @output;
 257
 258   wantarray ? return ($status, @output) : $status;
 259 } # Execute
 260
 261 sub GetChildren(;$) {
 262   my ($pid) = @_;
 263
 264 =pod
 265
 266 =head2 GetChildren ($pid)
 267
 268 Returns an array of children pids for the passed in $pid.
 269
 270 NOTE: This assumes that the utility pstree exists and is in the callers PATH.
 271
 272 Parameters:
 273
 274 =for html <blockquote>
 275
 276 =over
 277
 278 =item $pid
 279
 280 $pid to return the subtree of (Default: pid of init)
 281
 282 =back
 283
 284 =for html </blockquote>
 285
 286 Returns:
 287
 288 =for html <blockquote>
 289
 290 =over
 291
 292 =item Array of children pids
 293
 294 =back
 295
 296 =for html </blockquote>
 297
 298 =cut
 299
 300   my @children = ();
 301
 302   $pid = 1 if !$pid;
 303
 304   my @output = `pstree -ap $pid`;
 305
 306   return @children if $? == 0;
 307
 308   chomp @output;
 309
 310   for (@output) {
 311     # Skip the pstree process and the parent process - we want only
 312     # our children.
 313     next if /pstree/ or /\($pid\)/;
 314
 315     if (/\((\d+)\)/) {
 316       push @children, $1;
 317     } # if
 318   } # for
 319
 320   return @children;
 321 } # GetChildren
 322
 323 sub GetPassword(;$) {
 324   my ($prompt) = @_;
 325
 326 =pod
 327
 328 =head2 GetPassword (;$prompt)
 329
 330 Prompt for a password
 331
 332 Parameters:
 333
 334 =for html <blockquote>
 335
 336 =over
 337
 338 =item $prompt
 339
 340 Prompt string to use (Default: "Password:")
 341
 342 =back
 343
 344 =for html </blockquote>
 345
 346 Returns:
 347
 348 =for html <blockquote>
 349
 350 =over
 351
 352 =item $password
 353
 354 =back
 355
 356 =for html </blockquote>
 357
 358 =cut
 359
 360   $prompt ||= 'Password';
 361
 362   my $password = '';
 363
 364   local $| = 1;
 365
 366   print "$prompt:";
 367
 368   $SIG{INT} = \&_restoreTerm;
 369
 370   ReadMode 'cbreak';
 371
 372   while () {
 373     my $key;
 374
 375     while (not defined ($key = ReadKey -1)) { }
 376
 377     if ($key =~ /(\r|\n)/) {
 378        print "\n";
 379
 380        last;
 381     } # if
 382
 383     # Handle backspaces
 384     if ($key eq chr(127)) {
 385       unless ($password eq '') {
 386         chop $password;
 387
 388         print "\b \b";
 389       } # unless
 390     } else {
 391       print '*';
 392
 393       $password .= $key;
 394     } # if
 395   } # while
 396
 397   ReadMode 'restore'; # Reset tty mode before exiting.
 398
 399   $SIG{INT} = 'DEFAULT';
 400
 401   return $password;
 402 } # GetPassword
 403
 404 sub InArray($@) {
 405   my ($item, @array) = @_;
 406
 407 =pod
 408
 409 =head2 InArray ($item, @array)
 410
 411 Find an item in an array.
 412
 413 Parameters:
 414
 415 =for html <blockquote>
 416
 417 =over
 418
 419 =item $item
 420
 421 Item to search for
 422
 423 =item @array
 424
 425 Array to search
 426
 427 =back
 428
 429 =for html </blockquote>
 430
 431 Returns:
 432
 433 =for html <blockquote>
 434
 435 =over
 436
 437 =item $TRUE if found - $FALSE otherwise
 438
 439 =back
 440
 441 =for html </blockquote>
 442
 443 =cut
 444
 445   for (@array) {
 446     return $TRUE if $item eq $_;
 447   } # for
 448
 449   return $FALSE;
 450 } # InArray
 451
 452 sub LoadAvg () {
 453
 454 =pod
 455
 456 =head2 LoadAvg ()
 457
 458 Return an array of the 1, 5, and 15 minute load averages.
 459
 460 Parameters:
 461
 462 =for html <blockquote>
 463
 464 =over
 465
 466 =item none
 467
 468 =back
 469
 470 =for html </blockquote>
 471
 472 Returns:
 473
 474 =for html <blockquote>
 475
 476 =over
 477
 478 =item An array of the 1, 5, and 15 minute load averages in a list context.
 479 In a scalar context just the 1 minute load average.
 480
 481 =back
 482
 483 =for html </blockquote>
 484
 485 =cut
 486   # TODO: Make it work on Windows...
 487   return if $^O =~ /win/i;
 488
 489   open my $loadAvg, '<', '/proc/loadavg'
 490     or croak "Unable to open /proc/loadavg\n";
 491
 492   my $load = <$loadAvg>;
 493
 494   close $loadAvg;
 495
 496   my @loadAvgs = split /\s/, $load;
 497
 498   if (wantarray) {
 499     return @loadAvgs;
 500   } else {
 501     return $loadAvgs[0]; # This is the 1 minute average
 502   }
 503 } # LoadAvg
 504
 505 sub StartPipe($;$) {
 506   my ($to, $existingPipe) = @_;
 507
 508 =pod
 509
 510 =head2 StartPipe ($to, $existingPipe)
 511
 512 Starts a pipeline
 513
 514 Parameters:
 515
 516 =for html <blockquote>
 517
 518 =over
 519
 520 =item $to
 521
 522 String representing the other end of the pipe
 523
 524 =item $existingPipe
 525
 526 Already existing pipe handle (from a previous call to StartPipe)
 527
 528 =back
 529
 530 =for html </blockquote>
 531
 532 Returns:
 533
 534 =for html <blockquote>
 535
 536 =over
 537
 538 =item A $pipe to used for PipeOutput
 539
 540 =back
 541
 542 =for html </blockquote>
 543
 544 =cut
 545
 546   if ($existingPipe) {
 547     close $existingPipe;
 548
 549     open $existingPipe, '|-', $to
 550       or error "Unable to open pipe - $!", 1;
 551
 552     return $existingPipe;
 553   } else {
 554     open $pipe, '|-', $to
 555       or error "Unable to open pipe - $!", 1;
 556
 557     return $pipe;
 558   } # if
 559 } # StartPipe
 560
 561 sub PipeOutputArray($@) {
 562   my ($to, @output) = @_;
 563
 564 =pod
 565
 566 =head2 PipeOutputArray ($to, @ouput)
 567
 568 Pipes output to $to
 569
 570 Parameters:
 571
 572 =for html <blockquote>
 573
 574 =over
 575
 576 =item $to
 577
 578 String representing the other end of the pipe to pipe @output to
 579
 580 =item @output
 581
 582 Output to pipe
 583
 584 =back
 585
 586 =for html </blockquote>
 587
 588 Returns:
 589
 590 =for html <blockquote>
 591
 592 =over
 593
 594 =item Nothing
 595
 596 =back
 597
 598 =for html </blockquote>
 599
 600 =cut
 601
 602   open my $pipe, '|-', $to
 603     or error "Unable to open pipe - $!", 1;
 604
 605   for (@output) {
 606     chomp;
 607
 608     print $pipe "$_\n";
 609   } # for
 610
 611   return close $pipe;
 612 } # PipeOutputArray
 613
 614 sub PipeOutput($;$) {
 615   my ($line, $topipe) = @_;
 616
 617 =pod
 618
 619 =head2 PipeOutput ($line, $topipe)
 620
 621 Pipes a single line to $topipe
 622
 623 Parameters:
 624
 625 =for html <blockquote>
 626
 627 =over
 628
 629 =item $line
 630
 631 Line to output to $topipe.
 632
 633 =item $topipe
 634
 635 A pipe returned by StartPipe (or our $pipe) to which the $line is piped.
 636
 637 =back
 638
 639 =for html </blockquote>
 640
 641 Returns:
 642
 643 =for html <blockquote>
 644
 645 =over
 646
 647 =item Nothing
 648
 649 =back
 650
 651 =for html </blockquote>
 652
 653 =cut
 654
 655   $topipe ||= $pipe;
 656
 657   chomp $line; chop $line if $line =~ /\r$/;
 658
 659   print $pipe "$line\n";
 660
 661   return;
 662 } # PipeOutput
 663
 664 sub StopPipe(;$) {
 665   my ($pipeToStop) = @_;
 666
 667 =pod
 668
 669 =head2 StopPipe ($pipe)
 670
 671 Stops a $pipe.
 672
 673 Parameters:
 674
 675 =for html <blockquote>
 676
 677 =over
 678
 679 =item $pipe
 680
 681 Pipe to stop
 682
 683 =back
 684
 685 =for html </blockquote>
 686
 687 Returns:
 688
 689 =for html <blockquote>
 690
 691 =over
 692
 693 =item Nothing
 694
 695 =back
 696
 697 =for html </blockquote>
 698
 699 =cut
 700
 701   $pipeToStop ||= $pipe;
 702
 703   close $pipeToStop if $pipeToStop;
 704
 705   return;
 706 } # StopPipe
 707
 708 sub PageOutput(@) {
 709   my (@output) = @_;
 710
 711 =pod
 712
 713 =head2 PageOutput (@ouput)
 714
 715 Pages output to the screen
 716
 717 Parameters:
 718
 719 =for html <blockquote>
 720
 721 =over
 722
 723 =item @output
 724
 725 Output to page
 726
 727 =back
 728
 729 =for html </blockquote>
 730
 731 Returns:
 732
 733 =for html <blockquote>
 734
 735 =over
 736
 737 =item Nothing
 738
 739 =back
 740
 741 =for html </blockquote>
 742
 743 =cut
 744
 745   if ($ENV{PAGER}) {
 746     PipeOutputArray $ENV{PAGER}, @output;
 747   } else {
 748     print "$_\n"
 749       for (@output);
 750   } # if
 751
 752   return;
 753 } # PageOutput
 754
 755 sub RedirectOutput($$@) {
 756   my ($to, $mode, @output) = @_;
 757
 758 =pod
 759
 760 =head2 RedirectOutput ($to, @ouput)
 761
 762 Pages output to the screen
 763
 764 Parameters:
 765
 766 =for html <blockquote>
 767
 768 =over
 769
 770 =item $to
 771
 772 Where to send the output
 773
 774 =item @output
 775
 776 Output to redirect
 777
 778 =back
 779
 780 =for html </blockquote>
 781
 782 Returns:
 783
 784 =for html <blockquote>
 785
 786 =over
 787
 788 =item Nothing
 789
 790 =back
 791
 792 =for html </blockquote>
 793
 794 =cut
 795
 796   croak 'Mode must be > or >>'
 797     unless ($mode eq '>' or $mode eq '>>');
 798
 799   open my $out, $mode, $to
 800     or croak "Unable to open $to for writing - $!";
 801
 802   for (@output) {
 803     chomp;
 804     print $out "$_\n";
 805   } # for
 806
 807   return;
 808 } # RedirectOutput
 809
 810 sub ReadFile($) {
 811   my ($filename) = @_;
 812
 813 =pod
 814
 815 =head2 ReadFile ($filename)
 816
 817 How many times have you coded a Perl subroutine, or just staight inline Perl to
 818 open a file, read all the lines into an array and close the file. This routine
 819 does that very thing along with the associated and proper checking of open
 820 failure and even trims the lines in the output array of trailing newlines? This
 821 routine returns an array of the lines in the filename passed in.
 822
 823 Parameters:
 824
 825 =for html <blockquote>
 826
 827 =over
 828
 829 =item $filename
 830
 831 Filename to read
 832
 833 =back
 834
 835 =for html </blockquote>
 836
 837 Returns:
 838
 839 =for html <blockquote>
 840
 841 =over
 842
 843 =item Array of lines in the file
 844
 845 =back
 846
 847 =for html </blockquote>
 848
 849 =cut
 850
 851   open my $file, '<', $filename
 852     or error "Unable to open $filename ($!)", 1;
 853
 854   if (wantarray) {
 855     local $/ = "\n";
 856
 857     my @lines = <$file>;
 858
 859     close $file
 860       or error "Unable to close $filename ($!)", 1;
 861
 862     my @cleansed_lines;
 863
 864     for (@lines) {
 865       chomp;
 866       chop if /\r/;
 867       push @cleansed_lines, $_ if !/^#/; # Discard comment lines
 868     } # for
 869
 870     return @cleansed_lines;
 871   } else {
 872     local $/ = undef;
 873
 874     return <$file>;
 875   } # if
 876 } # ReadFile
 877
 878 sub Stats($;$) {
 879   my ($total, $log) = @_;
 880
 881 =pod
 882
 883 =head2 Stats ($total, $log)
 884
 885 Reports runtime stats
 886
 887 Parameters:
 888
 889 =for html <blockquote>
 890
 891 =over
 892
 893 =item $total
 894
 895 Reference to a hash of total counters. The keys of the hash will be the labels
 896 and the values of the hash will be the counters.
 897
 898 =item $log
 899
 900 Logger object to log stats to (if specified). Note: if the Logger object has
 901 errors or warnings then they will be automatically included in the output.
 902
 903 =back
 904
 905 =for html </blockquote>
 906
 907 Returns:
 908
 909 =for html <blockquote>
 910
 911 =over
 912
 913 =item Nothing
 914
 915 =back
 916
 917 =for html </blockquote>
 918
 919 =cut
 920
 921   my $msg = "$FindBin::Script Run Statistics:";
 922
 923   if ($log and ref $log eq 'Logger') {
 924     $total->{errors}   = $log->{errors};
 925     $total->{warnings} = $log->{warnings};
 926   } # if
 927
 928   if (keys %$total) {
 929     # Display statistics (if any)
 930     if ($log) {
 931       $log->msg ($msg);
 932     } else {
 933       display $msg;
 934     } # if
 935
 936     for (sort keys %$total) {
 937       $msg = $total->{$_} . "\t $_";
 938
 939       if ($log) {
 940         $log->msg ($total->{$_} . "\t $_");
 941       } else {
 942         display $msg;
 943       } # if
 944     } # for
 945   } # if
 946
 947   return;
 948 } # Stats
 949
 950 sub Usage(;$) {
 951   my ($msg) = @_;
 952
 953 =pod
 954
 955 =head2 Usage ($msg)
 956
 957 Reports usage using perldoc
 958
 959 Parameters:
 960
 961 =for html <blockquote>
 962
 963 =over
 964
 965 =item $msg
 966
 967 Message to output before doing perldoc
 968
 969 =back
 970
 971 =for html </blockquote>
 972
 973 Returns:
 974
 975 =for html <blockquote>
 976
 977 =over
 978
 979 =item Does not return
 980
 981 =back
 982
 983 =for html </blockquote>
 984
 985 =cut
 986
 987   display $msg if $msg;
 988
 989   system "perldoc $0";
 990
 991   exit 1;
 992 } # Usage
 993
 994 sub RequiredFields($$) {
 995
 996 =pod
 997
 998 =head2 RequiredFields($total, $log)
 999
1000 Check if a list of fields are contained in a hash
1001
1002 Parameters:
1003
1004 =for html <blockquote>
1005
1006 =over
1007
1008 =item $fields
1009
1010 Array reference to a list of field names that are required
1011
1012 =item $rec
1013
1014 Hash reference whose key values we are checking
1015
1016 =back
1017
1018 =for html </blockquote>
1019
1020 Returns:
1021
1022 =for html <blockquote>
1023
1024 =over
1025
1026 =item Message
1027
1028 Returns either an empty string or a string naming the first missing required
1029 field
1030
1031 =back
1032
1033 =for html </blockquote>
1034
1035 =cut
1036
1037   my ($fields, $rec) = @_;
1038
1039   for my $fieldname (@$fields) {
1040     my $found = 0;
1041
1042     for (keys %$rec) {
1043       if ($fieldname eq $_) {
1044         $found = 1;
1045         last;
1046       } # if
1047     } # for
1048
1049     return "$fieldname is required" unless $found;
1050   } # for
1051
1052   return;
1053 } # RequiredFields
1054
1055 END {
1056   StopPipe;
1057 } # END
1058
1059 1;
1060
1061 =head1 CONFIGURATION AND ENVIRONMENT
1062
1063 None
1064
1065 =head1 DEPENDENCIES
1066
1067 =head2 Perl Modules
1068
1069 L<File::Spec|File::Spec>
1070
1071 L<FindBin>
1072
1073 L<POSIX>
1074
1075 =head2 ClearSCM Perl Modules
1076
1077 =for html <p><a href="/php/scm_man.php?file=lib/Display.pm">Display</a></p>
1078
1079 =for html <p><a href="/php/scm_man.php?file=lib/Logger.pm">Logger</a></p>
1080
1081 =for html <p><a href="/php/scm_man.php?file=lib/OSDep.pm">OSDep</a></p>
1082
1083 =head1 INCOMPATABILITIES
1084
1085 None yet...
1086
1087 =head1 BUGS AND LIMITATIONS
1088
1089 There are no known bugs in this module.
1090
1091 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
1092
1093 =head1 LICENSE AND COPYRIGHT
1094
1095 This Perl Module is freely available; you can redistribute it and/or modify it
1096 under the terms of the GNU General Public License as published by the Free
1097 Software Foundation; either version 2 of the License, or (at your option) any
1098 later version.
1099
1100 This Perl Module is distributed in the hope that it will be useful, but WITHOUT
1101 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
1102 FOR A PARTICULAR PURPOSE. See the GNU General Public License
1103 (L<http://www.gnu.org/copyleft/gpl.html>) for more details.
1104
1105 You should have received a copy of the GNU General Public License along with
1106 this Perl Module; if not, write to the Free Software Foundation, Inc., 59
1107 Temple Place - Suite 330, Boston, MA 02111-1307, USA. reserved.
1108
1109 =cut