LONG PERL SOURCE EXAMPLE
The following code is an example of a small scale workflow. This particular code
ran in a very complex and crowded process environment. Notice how 75% of the
code is dedicated to error trapping and reporting. Notice also the extensive
comments and discussion throughout the code making it easier for the next
programmer to come along and pick up where I leave off. The program makes use of
routines from INCLUDED modules (some also written by me) that are not shown
here.
#!/usr/bin/perl
###########################################################################
#
# Name: gt_im.pl
#
# Purpose: To monitor one or more directories for one or more files,
# transform their name, and copy them to another directory based
# on control table information.
#
# Description:
# This program scans directories named in its control file, examines file
# names for reg expressions also in the control file, copies those files
# to new destinations given in the control file, and renames them according
# to reg expressions in the control file. Structure of the control file is:
# SOURCE_REG_EXPR|DEST_DIR|NEW_NAME_REG_EXPR|AllowMoveToAltFileSys (Y or N)
# The NEW_NAME_REG_EXPR consists of node variables interspersed with
# literals. For example the file MY.FILE.NAMED.JOE has four nodes
# referenced as $node[0] = MY, $node[1] = FILE, etc. To change the
# name to JOE.NOT.NAMED.MATTS.FILE, the new pattern would look like
# $node[4].NOT.$node[3].MATTS.$node[2]. Note that in this transformation,
# $node[1] is dropped...
#
#
# Parameters:
# Param R/O Description
#
# -i O Sleep interval in seconds
# Default = 30
#
# -f O Name and path to control file.
# Default = $GT_ADMIN/gt_im.ctl
#
# -m O Source directory - dir to monitor.
#
# -o O One shot - cycle once then quit
# (parameter only, no associated value)
# In this context it means "go through the whole control
# table once";
#
# -r O Fatal exit code - applies to system calls only. Process
# will quit if this value or higher is received from the
# command. For evaluated Perl commands, the process will
# quit only if the return value is undefined.
# Default = environment variable RCCRIT
#
#
# Change History:
# ======================================================================
# date author/description
# ======================================================================
# 04/30/02 Matthew Rapaport
# Initial release.
# gt_monitor.pl.
#
###########################################################################
###########################################################################
# Include Modules
###########################################################################
use Env;
use lib $ENV{GT_SH} . "/perl";
use strict;
use gt_stdlib;
use File::Basename;
use Getopt::Std;
use vars qw(
$opt_i
$opt_f
$opt_m
$opt_o
$opt_r
);
###########################################################################
# Global Variables
###########################################################################
Env::import();
chomp(my $execname=basename($0)); # name of this module
my $pid = $$; # PID of current process
my $rc = 0;
my $rc_fatal = $RCCRIT;
my $message;
my @args = @ARGV;
my $quit = "n";
my $filename;
my $ok_to_exit = "y";
my $save_signame;
###########################################################################
# Subroutines
###########################################################################
sub checkSignal
###########################################################################
#
# Check to see if a signal was recieved and exit if it is okay to do so.
#
###########################################################################
{ # Subroutine Begin
my $message;
if ($save_signame)
{
if ($ok_to_exit eq "y" && $save_signame ne '__WARN__')
{
$message="received signal $save_signame, exit rc=$rc";
&logmsg($execname, $pid, __LINE__, "0150", "I", "$message");
exit;
}
}
} # Subroutine End
sub set_signal
###########################################################################
#
# This overrides the gt_stdlib.pm subroutine which is called by
# set_traps in the same library. It is run immediately when a signal
# is received. Save the signal name then possibly exit.
#
###########################################################################
{ # Subroutine Begin
my $signame = shift;
$save_signame = $signame;
&checkSignal();
} # Subroutine End
sub setWARN
###########################################################################
#
# Trap the "warn" pseudo signal and log a warning message
#
###########################################################################
{ # Subroutine Begin
chomp(my $sigmsg = shift);
$save_signame = '__WARN__';
my $message="from $save_signame, msg=$sigmsg";
&logmsg($execname, $pid, __LINE__, "0150", "W", "$message");
} # Subroutine End
sub setDIE
###########################################################################
#
# Trap the "die" pseudo signal and log an error message
#
###########################################################################
{ # Subroutine Begin
chomp(my $sigmsg = shift);
$save_signame = '__DIE__';
my $message="from $save_signame, msg=$sigmsg, exiting";
&logmsg($execname, $pid, __LINE__, "0150", "E", "$message");
exit;
} # Subroutine End
sub normalExit
###########################################################################
#
# Normal exit from program
#
###########################################################################
{
my($line_num, $rc) = @_;
&logmsg($execname, $pid, $line_num, "0100", "I", "exit rc=$rc");
exit $rc;
}
sub fatalExit
###########################################################################
#
# Log "error" type message and exit with "fatal" return code
#
###########################################################################
{
my($line_num, $msgid, $message) = @_;
&logmsg($execname, $pid, $line_num, $msgid, "E", $message);
&normalExit($line_num, $rc_fatal);
}
sub getArgs
###########################################################################
#
# Assign variables associated with the run-time options.
#
###########################################################################
{ # Subroutine Begin
my $ctlfile = $GT_ADMIN . "/gt_im.ctl";
my $scandir;
my $sleep_sec = 30;
my $oneshot = 'n';
my $arg_err = 'n';
&getopts('oi:f:m:r:');
if (defined($opt_r))
{
if ($opt_r =~ m/^\d+$/)
{
$rc_fatal = $opt_r;
}
else
{
$message="-r (fatal return code) must be an integer, value=$opt_r";
&logmsg($execname, $pid, __LINE__, "1001", "E", $message);
$arg_err = 'y';
}
}
if (defined($opt_i))
{
if ($opt_i =~ m/^\d+$/)
{
if ($opt_i != 0)
{
$sleep_sec = $opt_i;
}
}
else
{
$message="-i (sleep time) must be an integer, value=$opt_i";
&logmsg($execname, $pid, __LINE__, "1001", "E", $message);
$arg_err = 'y';
}
}
if (defined($opt_f))
{
if (-r $opt_f)
{
$ctlfile = $opt_f;
}
else
{
$message="-f (control file) not readable, value=$opt_f";
&logmsg($execname, $pid, __LINE__, "1001", "E", $message);
$arg_err = 'y';
}
}
if (defined($opt_m))
{
if (-r $opt_m)
{
$scandir = $opt_m;
} else {
$message="-m (scan directory) not readable, value=$opt_f";
&logmsg($execname, $pid, __LINE__, "1001", "E", $message);
$arg_err = 'y';
}
} else {
$message="-m No scan directory given. No default!";
&logmsg($execname, $pid, __LINE__, "1001", "E", $message);
$arg_err = 'y';
}
if (defined($opt_o))
{
$oneshot = 'y';
}
return (
$ctlfile,
$scandir,
$sleep_sec,
$oneshot,
$rc_fatal,
$arg_err
);
} # Subroutine End
sub getFileList
###########################################################################
#
# Get a filtered, sorted list of filenames.
#
###########################################################################
{ # Subroutine Begin
my($scandir) = @_;
my @file_list;
my $filename;
opendir(SCANDIR, "$scandir") or do
{
$message = "error opening $scandir";
&fatalExit(__LINE__, "1002", $message);
};
@file_list = grep { -f }
map { "$scandir/$_" }
grep { !/^\./ }
readdir(SCANDIR);
closedir(SCANDIR);
return(\@file_list);
} # subroutine end
###########################################################################
# Mainline
###########################################################################
$message="args: @args";
&logmsg($execname, $pid, __LINE__, "0000", "I", $message);
&set_traps();
$SIG{__WARN__} = "setWARN";
$SIG{__DIE__} = "setDIE";
my @ctlList;
my @node;
my $ctlNdx = 0;
my $ctlLine;
my $srcX;
my $dest;
my $newNamePat;
my $hideflag;
my $unHideName;
my $retval;
my $time_used;
my $curr_loop_time;
my $foundMatchFlag = "";
my $altFSflag = "N"; # allow move to alternate file system.
my (
$ctlfile,
$scandir,
$sleep_sec,
$oneshot,
$rc_fatal,
$arg_err
) = &getArgs();
if ($arg_err eq 'y')
{
&normalExit(__LINE__, $rc_fatal);
}
# We are up and running, but check to see if there is another instance
# of this specific execname cause there shouldn't be...
if (isGTprocActive($execname,$GT_ADMID) >1)
{
# another copy of this specific $execname is running.
$message = "$execname already running!";
&logmsg($execname, $pid, __LINE__, "1011", "W", "$message");
$retval=0;
exit $retval;
}
# Open and read in the control file ONCE before infinite loop.
# If the control file is changed, the program will have to be bounced
# to pick up the changes.
open(CTLIN, $ctlfile) or do
{
# should not happen because we've already determined that the file is
# readable when we tested the arguments...
$message = "error opening control file $ctlfile";
&fatalExit(__LINE__, "1002", $message);
};
$ctlNdx = 0; #initialize every time we read!
while ($ctlLine = )
{
if ($ctlLine =~ /^#/ || $ctlLine =~ /^\s*$/)
{
next;
}
chomp($ctlLine);
$ctlList[$ctlNdx] = $ctlLine;
$ctlNdx++; # note that ctlNdx ends up 1 higher than the real max value
}
close(CTLIN);
# Next the program's main loop. Runs forever until program is killed, or
# oneshot is set in which case, $quit is set to 'y' at bottom of this
# loop.
until ($quit eq 'y')
{
# set up for sleep time comparison.
$curr_loop_time = time;
# Get the files!
my $file_list_ref = &getFileList($scandir);
my @file_list = @$file_list_ref;
foreach $filename (@file_list)
{
# here we now process through the control file to see if any
# of the regX source patterns match this file.
$filename = basename($filename);
(@node) = split(/\./, $filename); #get all the nodes of the source file.
# push a null into the first (0) array index so the first real value starts with "1"
splice(@node,0,0,"STUB");
$foundMatchFlag = ""; # re-initialize for each file!
foreach $ctlLine (@ctlList)
{
$altFSflag = "N"; # re-initialize as it might not be in control file at all!
($srcX, $dest, $newNamePat, $altFSflag) = split(/\|/, $ctlLine);
if ($filename =~ /$srcX/)
{
# if the file matches the pattern...
$newNamePat =~ s/(\$\w+[\[\]\d]*)/$1/gee ; # transform the name
# We found a match. Set flag here, cause we might have to unset it later.
$foundMatchFlag = "TRUE";
# Expand any possible environment variables in $dest
# $dest =~ s/.+/$dest/gee ;
# Above seems natural way to do it, but for consistency sake, lets do it
# like the name transformation above...
$dest =~ s/(\$\w+[\[\]\d]*)/$1/gee ;
if (uc($altFSflag) eq "Y")
{
# we are going to use mv instead of rename because user wants this file
# in an alternate file system.
# We have to move it as a hidden file, then un-hide it if it is supposed
# to be unhidden.
$newNamePat = "\." . $newNamePat;
system("mv $scandir/$filename $dest/$newNamePat") ;
$retval = $? >> 8;
if ($retval)
{
# If we CAN NOT move the file to its proper destination
# try moving it to $GT_SUSP. Fail only if we can't even do that!
$message="Can not move file $filename to $dest/$newNamePat. Trying $GT_SUSP";
&logmsg($execname, $pid, __LINE__, "1003", "E", "$message");
$foundMatchFlag = ""; # Will cause a try to move file to $GT_SUSP
} else {
# move was good, so now unhide it...
$unHideName = substr($newNamePat,1);
rename("$dest/$newNamePat", "$dest/$unHideName") or do
{
# If we CAN NOT unhide the file,
# leave it alone, but log an error message...
$message="Can not unhide file $dest/$newNamePat.";
&logmsg($execname, $pid, __LINE__, "1003", "E", "$message");
};
}
} else {
rename("$scandir/$filename", "$dest/$newNamePat") or do
{
# If we CAN NOT move the file to its proper destination
# try moving it to $GT_SUSP. Fail only if we can't even do that!
$message="Can not rename file $filename to $dest/$newNamePat. Trying $GT_SUSP";
&logmsg($execname, $pid, __LINE__, "1003", "E", "$message");
$foundMatchFlag = "";
};
}
last; # skips out of pattern examination and gets the next file.
# if $foundMatchFlag is false here, it can only be because we found
# the file, but couldn't move it. We unset the flag to allow the
# move attempt to $GT_SUSP below.
} # end of IF test for pattern match (if $filename =~ /$srcX/).
} # end of pattern examination loop (foreach $ctlLine (@ctlList))
if (! $foundMatchFlag)
{
# No match was found with any pattern, or the matching file could not be moved
# to the named destination, so move this file to $GT_SUSP
$newNamePat = $execname . "\." . $filename;
$message="Orphan file $filename moving to $GT_SUSP as $newNamePat";
&logmsg($execname, $pid, __LINE__, "1002", "E", "$message");
rename("$scandir/$filename", "$GT_SUSP/$newNamePat") or do
{
$message="Unable to move file $filename to $GT_SUSP/$newNamePat";
&fatalExit(__LINE__, 1002, $message);
};
}
&checkSignal(); # after each file see if we got a signal.
} # End of filename loop
if ($oneshot eq 'y')
{
$quit = 'y';
} else {
$time_used = time - $curr_loop_time;
if ($time_used < $sleep_sec)
{
# if $time_used >= $sleep_sec we don't want the program to
# sleep at all, so this test will fail and go back to the
# forever loop.
sleep($sleep_sec - $time_used);
}
}
} # end of forever loop (until $quit eq 'y')
&normalExit(__LINE__, $rc);
#---------------
# End of Program
#---------------
Mail to mjr