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;