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