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