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