Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
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;
Replies are listed 'Best First'.
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? :)
Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://140382]
help
Chatterbox?
[holli]: yet no body
[virtualsue]: I was called upon to remove a gnawed mouse carcass from the living room this morning
holli googles dryarian just to make sure that isn't actually thing
[holli]: I mean, you never know, right?
[shmem]: good $localtime monkses
[holli]: mmh. maybe a user handle "dry arian" is a bit unfortunate? https://www. pinterest.de/ dryarian/
[Discipulus]: exists!
[shmem]: holli, agreed. "dry airan" would be slightly better :P
[holli]: virtualsue: How much was left?
[shmem]: Discipulus: oh. tatsächlich.

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (9)
As of 2017-11-21 12:47 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    In order to be able to say "I know Perl", you must have:













    Results (301 votes). Check out past polls.

    Notices?