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