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