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