Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

perlcaller.pl

by DaveRoberts (Novice)
on Jan 21, 2002 at 17:20 UTC ( #140382=sourcecode: print w/ replies, xml ) Need Help??

Category: Win32 Stuff
Author/Contact Info DaveRoberts@iname.com
Description: This script is intended to be called by sysmon.pl - and manages the log file associated with this service.
use File::Find;
# Wrapper to configure the correct log file....
use constant TRUE  => 1;
use constant FALSE => 0;

my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) 
  = gmtime(time);
my $label = sprintf "%02d%s%04d_%02d%02d%02d",
  $mday,$months[$mon],($year+1900),$hour,$min,$sec;

my($verbose) = FALSE;  # Set verbose flag to off
my($age)     = 7;      # Max age of log files....(in days)
my($redirect,$ldir,$rv,@CODE,$exit_value,$signal_num,$dumped_core);
$exit_value  = 0;
$|=1;
if ( $] >= 5.006 ) {
  $redirect = TRUE;
}else{
  $redirect = FALSE;
}
$ldir = shift @ARGV;            # log file (first element of @ARGV)
mkdir $ldir unless (-d $ldir);  # Create the log file directory

#---------------------------------------------------------------------
+----------
# Manage the log files
#
if ( $ldir =~ /(.*)\.(\S+)$/ ) {
  my($name)   = $1;
  my($suffix) = $2;
  $log = "$name-$label.$suffix";
  my($root) = $name;
  if ( $name =~ m/(.*)[\\|\/]([a-zA-Z0-9]+)/ ) {
    my($root) = $1;
    my($patt) = $2;
    sub prune {
      my ($dev,$ino,$mode,$nlink,$uid,$gid);
      if ( /^$patt.*\z/s && (($dev,$ino,$mode,$nlink,$uid,$gid) = lsta
+t($_)) &&
        -f $_ && (int(-M _) > $age) ) {
        my($file) = $File::Find::name;
        print "Pruning log $file\n";
        unlink $file || print "  - failed to unlink $file\n";
      }
    }
    sub archive {
      if ( /^$patt.*\z/s && -f $_ ) {
        my($file)  = $File::Find::name;
        my($rname) = $ldir . '/' . $_;
        return if ($File::Find::dir eq $ldir );
        if ( rename $file,$rname) {
          print "archiving log $file to $rname\n";
        }else{
          print "  - failed to move $file to $rname\n";
        }
      }
    }

    # Traverse desired filesystems
    File::Find::find({wanted => \&prune}, $ldir);   
    # Prune log files older than $age days
    File::Find::find({wanted => \&archive}, $root); 
    # move old log file to archive dir
  }
}

if (open(FILE,">> $log ")) {
  open(STDOUT_BACKUP,">&STDOUT");
  open(STDOUT,">&FILE");
  pr("perlcaller: @ARGV\n");
  if ( $ARGV[0] =~ /\.(pl|cmd)$/ ) {
    if ( $ARGV[0] =~ /\.pl$/ ) {
      push(@CODE,"perl");
    }else{
      push(@CODE,"cmd");
    }
    push(@CODE,@ARGV);
    pr("CODE: @CODE\n");
    if (open(CODE_OUT, "@CODE 2>&1 |")){
      $|=1;
      while (<CODE_OUT>) {
        print STDOUT "  > $_" if ( $redirect );
        print FILE "  > $_" unless ( $redirect );
      }
      close CODE_OUT;
      $rv=$?;
      if ( $rv != 0 ) {
        $exit_value  = $rv >> 8;
        $signal_num  = $rv & 127;
        $dumped_core = $rv & 128;
        pr ("Return Code: $rv\n");
        pr ("Exit Value : $exit_value\n");
        pr ("Signal No  : $signal_num\n");
        pr ("Dumped Core: $dumped_core\n");
      }
    }else{
      pr("Unable to execute @CODE ($?)\n");
      $exit_value  = $? >> 8;
      $signal_num  = $? & 127;
      $dumped_core = $? & 128;
    }
  }else{
    pr("$ARGV[0] is neither perl script (.pl) or a command file (.cmd)
+\n");
  }
  pr("perlcaller: done\n");
  open(STDOUT,">&STDOUT_BACKUP");
  close(STDOUT_BACKUP);
  close(FILE);
}else{
  print  "failed to open log file $log ($!)\n";
}
exit $exit_value;

sub pr {
  my($message)= @_;
  my($dt)="[" . scalar( gmtime() ) . "] ";
  print STDOUT "$dt $message" if ( $redirect );
  print FILE   "$dt $message" unless ( $redirect );
}

1;

Comment on perlcaller.pl
Download Code
Re: perlcaller.pl
by Juerd (Abbot) on Jan 21, 2002 at 17:42 UTC
    Why do you use TRUE and FALSE constants? Perl already has some sense of true and false ("", "0", 0 and undef are false, all other values are true).
    If you ever need a representation in terms of 1 or 0, just use ?:.
    $foo ? 1 : 0;
    (Or the more evil !!$foo || 0 :))

    2;0 juerd@ouranos:~$ perl -e'undef christmas' Segmentation fault 2;139 juerd@ouranos:~$

      While you are correct, (and I ++'ed ya), perhaps he is more familiar with another programming language where those constants do exist (such as java)? You have to admit that it does make the program easier to read, and easier to maintain for a non-native perl programmer. Thats not to say I'd do it myself, but if it helps Dave write code that he is more comfortable with, why not? TIMTOWTDI, right? :)

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://140382]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (7)
As of 2014-11-22 16:58 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My preferred Perl binaries come from:














    Results (123 votes), past polls