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