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