jpayne@69: package TIGR::Foundation;
jpayne@69: {
jpayne@69:  
jpayne@69: =head1 NAME
jpayne@69: 
jpayne@69: TIGR::Foundation - TIGR Foundation object
jpayne@69: 
jpayne@69: =head1 SYNOPSIS
jpayne@69: 
jpayne@69:   use TIGR::Foundation;
jpayne@69:   my $obj_instance = new TIGR::Foundation;
jpayne@69: 
jpayne@69: =head1 DESCRIPTION
jpayne@69: 
jpayne@69: This module defines a structure for Perl programs to utilize
jpayne@69: logging, version reporting, and dependency checking in a simple way.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69:    BEGIN {
jpayne@69:       require 5.006_00;                       # error if using Perl < v5.6.0  
jpayne@69:    }
jpayne@69: 
jpayne@69:    use strict;
jpayne@69:    use Cwd;
jpayne@69:    use Cwd 'chdir';
jpayne@69:    use Cwd 'abs_path';
jpayne@69:    use File::Basename;
jpayne@69:    use Getopt::Long;
jpayne@69:    use IO::Handle;
jpayne@69:    use POSIX qw(strftime);
jpayne@69:    use Sys::Hostname;
jpayne@69:    use English;   
jpayne@69: 
jpayne@69:    require Exporter;
jpayne@69: 
jpayne@69:    our @ISA;
jpayne@69:    our @EXPORT;
jpayne@69:    @ISA = ('Exporter');
jpayne@69:    @EXPORT = qw(
jpayne@69:                 isReadableFile
jpayne@69:                 isWritableFile
jpayne@69:                 isExecutableFile
jpayne@69:                 isCreatableFile
jpayne@69:                 isReadableDir
jpayne@69:                 isWritableDir
jpayne@69:                 isCreatableDir
jpayne@69:                 isCreatablePath
jpayne@69: 
jpayne@69:                 getISODate
jpayne@69:                 getSybaseDate
jpayne@69:                 getMySQLDate
jpayne@69:                 getFilelabelDate
jpayne@69:                 getLogfileDate
jpayne@69:                );
jpayne@69: 
jpayne@69:    ## internal variables and identifiers
jpayne@69:    our $REVISION = (qw$Revision: 1.1.1.1 $)[-1];
jpayne@69:    our $VERSION = '1.1'; 
jpayne@69:    our $VERSION_STRING = "$VERSION (Build $REVISION)";
jpayne@69:    our @DEPEND = ();                          # there are no dependencies
jpayne@69: 
jpayne@69: 
jpayne@69:    ## prototypes
jpayne@69: 
jpayne@69:    # Functional Class : general
jpayne@69:    sub new();
jpayne@69:    sub getProgramInfo($);
jpayne@69:    sub runCommand($);
jpayne@69: 
jpayne@69:    # Functional Class : depend
jpayne@69:    sub printDependInfo();
jpayne@69:    sub printDependInfoAndExit();
jpayne@69:    sub addDependInfo(@);
jpayne@69: 
jpayne@69:    # Functional Class : version
jpayne@69:    sub getVersionInfo();
jpayne@69:    sub printVersionInfo();
jpayne@69:    sub printVersionInfoAndExit();
jpayne@69:    sub setVersionInfo($);
jpayne@69: 
jpayne@69:    # Functional Class : help
jpayne@69:    sub printHelpInfo();
jpayne@69:    sub printHelpInfoAndExit();
jpayne@69:    sub setHelpInfo($);
jpayne@69: 
jpayne@69:    # Functional Class : usage
jpayne@69:    sub printUsageInfo();
jpayne@69:    sub printUsageInfoAndExit();
jpayne@69:    sub setUsageInfo($);
jpayne@69: 
jpayne@69:    # Functional Class : files
jpayne@69:    sub isReadableFile($);
jpayne@69:    sub isExecutableFile($);
jpayne@69:    sub isWritableFile($);
jpayne@69:    sub isCreatableFile($);
jpayne@69:    sub isReadableDir($);
jpayne@69:    sub isWritableDir($);
jpayne@69:    sub isCreatableDir($);
jpayne@69:    sub isCreatablePath($);
jpayne@69: 
jpayne@69:    # Functional Class : date
jpayne@69:    sub getISODate(;@);
jpayne@69:    sub getSybaseDate(;@);
jpayne@69:    sub getMySQLDate(;@);
jpayne@69:    sub getFilelabelDate(;@);
jpayne@69:    sub getLogfileDate(;@);
jpayne@69: 
jpayne@69:    # Functional Class : logging
jpayne@69:    sub setDebugLevel($;$);
jpayne@69:    sub getDebugLevel();
jpayne@69:    sub setLogFile($;$);
jpayne@69:    sub getLogFile();
jpayne@69:    sub getErrorFile();
jpayne@69:    sub printDependInfo();
jpayne@69:    sub invalidateLogFILES();
jpayne@69:    sub cleanLogFILES();
jpayne@69:    sub closeLogERROR();
jpayne@69:    sub closeLogMSG();
jpayne@69:    sub openLogERROR();
jpayne@69:    sub openLogMSG();
jpayne@69:    sub logAppend($;$);
jpayne@69:    sub debugPush();
jpayne@69:    sub debugPop();
jpayne@69:    sub logLocal($$);
jpayne@69:    sub logError($;$);
jpayne@69:    sub bail($;$);
jpayne@69: 
jpayne@69:    # Functional Class : modified methods
jpayne@69:    sub TIGR_GetOptions(@);
jpayne@69: 
jpayne@69:    ## Implementation
jpayne@69:    
jpayne@69: 
jpayne@69: # Functional Class : general
jpayne@69: 
jpayne@69: =over
jpayne@69: 
jpayne@69: =item $obj_instance = new TIGR::Foundation;
jpayne@69: 
jpayne@69: This function creates a new instance of the TIGR::Foundation
jpayne@69: object.  A reference pointing to the object is returned on success.  Otherwise,
jpayne@69: this method returns undefined.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub new() {
jpayne@69:       
jpayne@69:       my $self = {};
jpayne@69:       my $pkg = shift;
jpayne@69:       my $user_name = getpwuid($<);
jpayne@69:       my $host_name = hostname();
jpayne@69: 
jpayne@69:       # create the object
jpayne@69:       bless $self, $pkg;
jpayne@69: 
jpayne@69:       ## Instance variables and identifiers, by functional class
jpayne@69:       
jpayne@69:       # Functional Class : general
jpayne@69:       my $pname  = basename($0, ()); # extract the script name
jpayne@69:        
jpayne@69:       if((defined ($pname)) && ($pname =~ /^(.*)$/)) {
jpayne@69:           $pname = $1;
jpayne@69: 	  $self->{program_name} = $pname ;
jpayne@69:       }
jpayne@69:       
jpayne@69:       if ($self->{program_name} =~ /^-$/) {     # check if '-' is the input
jpayne@69:          $self->{program_name} = "STDIN";
jpayne@69:       }
jpayne@69:       
jpayne@69:       my $pcommand = join (' ', @ARGV);
jpayne@69:       
jpayne@69:       if((defined ($pcommand)) && ($pcommand =~ /^(.*)$/)) {
jpayne@69:           $pcommand = $1;
jpayne@69: 	  $self->{invocation} = $pcommand ;
jpayne@69:       }
jpayne@69:       
jpayne@69:       # The following four variables are to contain information specified by
jpayne@69:       # the 'host' program; there are methods of setting and retrieving each
jpayne@69: 
jpayne@69:       # Functional Class : depend
jpayne@69:       @{$self->{depend_info}} = ();
jpayne@69:    
jpayne@69:       # Functional Class : version
jpayne@69:       $self->{version_info} = undef; 
jpayne@69:    
jpayne@69:       # Functional Class : help
jpayne@69:       $self->{help_info} = undef; 
jpayne@69:    
jpayne@69:       # Functional Class : usage
jpayne@69:       $self->{usage_info} = undef; 
jpayne@69:    
jpayne@69:       # Functional Class : logging
jpayne@69:       $self->{debug_level} = undef;             # default debug is not defined
jpayne@69:       @{$self->{debug_store}} = ();             # the backup debug level stack
jpayne@69:       @{$self->{debug_queue}} = ();             # queue used by MSG routine
jpayne@69:       @{$self->{error_queue}} = ();             # queue used by ERROR routine
jpayne@69:       $self->{max_debug_queue_size} = 100;      # maximum size for queue before
jpayne@69:                                                 # log entries are expired
jpayne@69:       @{$self->{log_files}} =                   # these log files are consulted
jpayne@69:          ("$self->{program_name}.log",          # on file write error and are
jpayne@69:           "/tmp/$self->{program_name}.$$.log"); # modified by setLogFile
jpayne@69:       $self->{msg_file_open_flag} = 0;          # flag to check logLocal file
jpayne@69:       $self->{error_file_open_flag} = 0;        # flag to check logError file
jpayne@69:       $self->{msg_file_used} = 0;               # flag to indicate if log file
jpayne@69:       $self->{error_file_used} = 0;             #   has been written to
jpayne@69:       $self->{msg_append_flag} = 0;             # by default logs are truncated
jpayne@69:       $self->{error_append_flag} = 0;           # by default logs are truncated
jpayne@69:       $self->{log_append_setting} = 0;          # (truncate == 0)
jpayne@69:       $self->{static_log_file} = undef;         # user defined log file
jpayne@69:       $self->{start_time} = undef;              # program start time
jpayne@69:       $self->{finish_time} = undef;             # program stop time
jpayne@69: 
jpayne@69:       # Log program invocation
jpayne@69:       $self->logLocal("START: " . "Username:$user_name, ".
jpayne@69:                       "Hostname: $host_name ". $self->getProgramInfo('name') .
jpayne@69:                       " " . $self->getProgramInfo('invocation'), 0);
jpayne@69:       $self->{start_time} = time;
jpayne@69: 
jpayne@69:       return $self;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: 
jpayne@69: =item $value = $obj_instance->getProgramInfo($field_type);
jpayne@69: 
jpayne@69: This function returns field values for specified field types describing
jpayne@69: attributes of the program.  The C<$field_type> parameter must be a listed
jpayne@69: attribute: C<name>, C<invocation>, C<env_path>, C<abs_path>.
jpayne@69: The C<name> field specifies the bare name of the executable.  The
jpayne@69: C<invocation> field specifies the command line arguments passed to the
jpayne@69: executable.   The C<env_path> value returns the environment path to the
jpayne@69: working directory.  The C<abs_path> value specifies the absolute path to the
jpayne@69: working directory.  If C<env_path> is found to be inconsistent, then that
jpayne@69: value will return the C<abs_path> value.  If an invalid C<$field_type> is 
jpayne@69: passed, the function returns undefined.  
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getProgramInfo($) {
jpayne@69:       my $self = shift;
jpayne@69:       my $field_type = shift;
jpayne@69:       my $return_value = undef;
jpayne@69:       if (defined $field_type) {
jpayne@69:          $field_type =~ /^name$/ && do {
jpayne@69:             $return_value = $self->{program_name};
jpayne@69:          };
jpayne@69:          $field_type =~ /^invocation$/ && do {
jpayne@69:             $return_value = $self->{invocation};
jpayne@69:          };
jpayne@69:          $field_type =~ /^env_path$/ && do {
jpayne@69:             my $return_value = "";
jpayne@69:             if (
jpayne@69:                 (defined $ENV{'PWD'}) &&
jpayne@69:                 (abs_path($ENV{'PWD'}) eq abs_path(".")) &&
jpayne@69:                 ($ENV{'PWD'} =~ /^(.*)$/)     
jpayne@69:                ) {
jpayne@69: 	       $ENV{'PWD'} = $1;
jpayne@69:                $return_value = $ENV{'PWD'};
jpayne@69:             }
jpayne@69:             else {
jpayne@69: 	       my $tmp_val = abs_path(".");
jpayne@69: 
jpayne@69:                if((defined ($tmp_val)) && ($tmp_val =~ /^(.*)$/)) {
jpayne@69:                   $tmp_val = $1;
jpayne@69: 	          $return_value = $tmp_val;
jpayne@69:                }
jpayne@69:             }
jpayne@69:             return $return_value;
jpayne@69:          };
jpayne@69: 
jpayne@69:          $field_type =~ /^abs_path$/ && do {
jpayne@69:             my $tmp_val = abs_path(".");
jpayne@69: 
jpayne@69:             if((defined ($tmp_val)) && ($tmp_val =~ /^(.*)$/)) {
jpayne@69:                $tmp_val = $1;
jpayne@69: 	       $return_value = $tmp_val;
jpayne@69:             }
jpayne@69:          };
jpayne@69:       }
jpayne@69:       return $return_value;
jpayne@69:    }
jpayne@69: 
jpayne@69: =item $exit_code = $obj_instance->runCommand($command_str);
jpayne@69: 
jpayne@69: This function passes the argument C<$command_str> to /bin/sh
jpayne@69: for processing.  The return value is the exit code of the 
jpayne@69: C<$command_str>.  If the exit code is not defined, then either the signal or
jpayne@69: core dump value of the execution is returned, whichever is applicable.  Perl
jpayne@69: variables C<$?> and C<$!> are set accordingly.  If C<$command_str> is not 
jpayne@69: defined, this function returns undefined.  Log messages are recorded at log
jpayne@69: level 4 to indicate the type of exit status and the corresponding code.
jpayne@69: Invalid commands return -1.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub runCommand($) {
jpayne@69:        my $self = shift;
jpayne@69:        my $command_str = shift;
jpayne@69:        my $exit_code = undef; 
jpayne@69:        my $signal_num = undef;
jpayne@69:        my $dumped_core = undef;
jpayne@69:        my $invalid_command = undef;
jpayne@69:        my $return_value = undef;
jpayne@69:        my @info_arr = getpwuid($<);
jpayne@69:        my $len = @info_arr;
jpayne@69:        my $home_dir = $info_arr[7];
jpayne@69:        my $current_dir = $self->getProgramInfo("abs_path"); 
jpayne@69:        
jpayne@69:        if((defined ($ENV{PATH})) && ($ENV{PATH} =~ /^(.*)$/)) {#taint checking
jpayne@69: 	  $ENV{PATH} = $1; 
jpayne@69:           my $path_var = $ENV{PATH};
jpayne@69:           my @paths = split /:/, $path_var;
jpayne@69:           my $pathval = undef;
jpayne@69:           my $i = 0;
jpayne@69:           my $paths_len = @paths;
jpayne@69: 
jpayne@69:           for ($i = 0; $i < $paths_len ; $i++) {
jpayne@69:              #substituting ~ with the home pathname.
jpayne@69: 	     $pathval = $paths[$i];
jpayne@69: 	     $pathval =~ s/^~$/$home_dir/g;
jpayne@69:              my $home_root = $home_dir."\/";
jpayne@69:              $pathval =~ s/^~\//$home_root/g;
jpayne@69:              
jpayne@69:              #substituting . with the current pathname.
jpayne@69:              $pathval =~ s/^\.$/$current_dir/g;
jpayne@69:              my $current_root = $current_dir."\/";
jpayne@69:              $pathval =~ s/^\.\//$current_root/g;
jpayne@69:              $paths[$i] = $pathval;
jpayne@69: 	  }
jpayne@69:           
jpayne@69:           $ENV{PATH} = join(":", @paths);
jpayne@69:        }
jpayne@69: 
jpayne@69:        if((defined ($command_str)) && ($command_str =~ /^(.*)$/)) {#taint 
jpayne@69:                                                                    #checking
jpayne@69:           $command_str = $1;
jpayne@69:           system($command_str);
jpayne@69:           $exit_code = $? >> 8;
jpayne@69:           $signal_num = $? & 127;
jpayne@69:           $dumped_core = $? & 128;
jpayne@69: 
jpayne@69:           if ($? == -1) {
jpayne@69:              $invalid_command = -1;
jpayne@69:           } 
jpayne@69:  
jpayne@69:           if ( 
jpayne@69:              (!defined $invalid_command) &&
jpayne@69:              ($exit_code == 0) &&
jpayne@69:              ($signal_num == 0) &&
jpayne@69:              ($dumped_core != 0)
jpayne@69:              ) {
jpayne@69:             
jpayne@69:              $self->logLocal("Command '" . $command_str . "' core dumped", 4);
jpayne@69:              $return_value = $dumped_core;
jpayne@69:            }
jpayne@69:           elsif (
jpayne@69:                 (!defined $invalid_command) &&
jpayne@69:                 ($exit_code == 0) &&
jpayne@69:                 ($signal_num != 0)
jpayne@69:                 ) {
jpayne@69:              
jpayne@69:              $self->logLocal("Command '" . $command_str .
jpayne@69:                              "' exited on signal " . $signal_num, 4);
jpayne@69:              $return_value = $signal_num;
jpayne@69:           }
jpayne@69:           elsif ((!defined $invalid_command)) {
jpayne@69:              
jpayne@69:              $self->logLocal("Command '" . $command_str .
jpayne@69:                              "' exited with exit code " . $exit_code, 4);
jpayne@69:              $return_value = $exit_code;
jpayne@69:           }
jpayne@69:           else {
jpayne@69:            
jpayne@69:              $self->logLocal("Command '" . $command_str .
jpayne@69:                              "' exited with invalid code " . $?, 4);
jpayne@69:              $return_value = $?;
jpayne@69:           }
jpayne@69:        }
jpayne@69:        return $return_value;
jpayne@69:    }
jpayne@69:    
jpayne@69: 
jpayne@69: # Functional Class : depend
jpayne@69: 
jpayne@69: =item $obj_instance->printDependInfo();
jpayne@69: 
jpayne@69: The C<printDependInfo()> function prints the dependency list created by
jpayne@69: C<addDependInfo()>.  One item is printed per line.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub printDependInfo() {
jpayne@69:       my $self = shift;
jpayne@69:       foreach my $dependent (@{$self->{depend_info}}) {
jpayne@69:          print STDERR $dependent, "\n";
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->printDependInfoAndExit();
jpayne@69: 
jpayne@69: The C<printDependInfoAndExit()> function prints the dependency list created by
jpayne@69: C<addDependInfo()>.  One item is printed per line.  The function exits with
jpayne@69: exit code 0. 
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub printDependInfoAndExit() {
jpayne@69:       my $self = shift;
jpayne@69:       $self->printDependInfo();
jpayne@69:       exit 0;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->addDependInfo(@depend_list);
jpayne@69: 
jpayne@69: The C<addDependInfo()> function adds C<@depend_list> information
jpayne@69: to the dependency list.  If C<@depend_list> is empty, the internal
jpayne@69: dependency list is emptied.  Contents of C<@depend_list> are not checked
jpayne@69: for validity (eg. they can be composed entirely of white space or
jpayne@69: multiple files per record).  The first undefined record in C<@depend_list>
jpayne@69: halts reading in of dependency information.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub addDependInfo(@) {
jpayne@69:       my $self = shift;
jpayne@69:       my $num_elts = 0;
jpayne@69:       while (my $data_elt = shift @_) {
jpayne@69:          push (@{$self->{depend_info}}, $data_elt);
jpayne@69:          $num_elts++;
jpayne@69:       }
jpayne@69:       if ($num_elts == 0) {
jpayne@69:          @{$self->{depend_info}} = ();
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: # Functional Class : version
jpayne@69: 
jpayne@69: =item $version_string = $obj_instance->getVersionInfo();
jpayne@69: 
jpayne@69: The C<getVersionInfo()> function returns the version information set by the
jpayne@69: C<setVersionInfo()> function.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getVersionInfo() {
jpayne@69:       my $self = shift;
jpayne@69:       return $self->{version_info};
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->printVersionInfo();
jpayne@69: 
jpayne@69: The C<printVersionInfo()> function prints the version information set by the
jpayne@69: C<setVersionInfo()> function.  If there is no defined version information,
jpayne@69: a message is returned notifying the user.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub printVersionInfo() {
jpayne@69:       my $self = shift;
jpayne@69:       if (defined $self->getVersionInfo()) {
jpayne@69:          print STDERR $self->getProgramInfo('name'), 
jpayne@69:             " ", $self->getVersionInfo(), "\n";
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          print STDERR $self->getProgramInfo('name'),
jpayne@69:             " has no defined version information\n";
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->printVersionInfoAndExit();
jpayne@69: 
jpayne@69: The C<printVersionInfoAndExit()> function prints version info set by the
jpayne@69: C<setVersionInfo()> function.  If there is no defined version information,
jpayne@69: a message is printed notifying the user.  This function calls exit with
jpayne@69: exit code 0. 
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub printVersionInfoAndExit() {
jpayne@69:       my $self = shift;
jpayne@69:       $self->printVersionInfo();
jpayne@69:       exit 0;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->setVersionInfo($version_string);
jpayne@69: 
jpayne@69: The C<setVersionInfo()> function sets the version information to be reported
jpayne@69: by C<getVersionInfo()>.  If C<$version_string> is empty, invalid, or
jpayne@69: undefined, the stored version information will be undefined.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub setVersionInfo($) {
jpayne@69:       my $self = shift;
jpayne@69:       my $v_info = shift;
jpayne@69:       if (
jpayne@69:           (defined $v_info) &&
jpayne@69:           ($v_info =~ /\S/) &&
jpayne@69:           ((ref $v_info) eq "")
jpayne@69:          ) {
jpayne@69:          $self->{version_info} = $v_info;
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          $self->{version_info} = undef;
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: # Functional Class : help
jpayne@69: 
jpayne@69: =item $obj_instance->printHelpInfo();
jpayne@69: 
jpayne@69: The C<printHelpInfo()> function prints the help information passed by the
jpayne@69: C<setHelpInfo()> function.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub printHelpInfo() {
jpayne@69:       my $self = shift;
jpayne@69:       if (defined $self->{help_info}) {
jpayne@69:          print STDERR $self->{help_info};
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          print STDERR "No help information defined.\n";
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->printHelpInfoAndExit();
jpayne@69: 
jpayne@69: The C<printHelpInfoAndExit()> function prints the help info passed by the
jpayne@69: C<setHelpInfo()> function.  This function exits with exit code 0.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub printHelpInfoAndExit() {
jpayne@69:       my $self = shift;
jpayne@69:       $self->printHelpInfo();
jpayne@69:       exit 0;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->setHelpInfo($help_string);
jpayne@69: 
jpayne@69: The C<setHelpInfo()> function sets the help information via C<$help_string>.
jpayne@69: If C<$help_string> is undefined, invalid, or empty, the help information 
jpayne@69: is undefined.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub setHelpInfo($) {
jpayne@69:       my $self = shift;
jpayne@69:       my $help_string = shift;
jpayne@69:       if (
jpayne@69:           (defined $help_string) &&
jpayne@69:           ($help_string =~ /\S/) &&
jpayne@69:           ((ref $help_string) eq "")
jpayne@69:          ) {
jpayne@69: 	 chomp($help_string);#removing a new line if it is there.
jpayne@69:          $self->{help_info} = $help_string."\n";#adding a new line to help.
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          $self->{help_info} = undef;
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: # Functional Class : usage
jpayne@69: 
jpayne@69: =item $obj_instance->printUsageInfo();
jpayne@69: 
jpayne@69: The C<printUsageInfo()> function prints the usage information reported by the
jpayne@69: C<setUsageInfo()> function.  If no usage information is defined, but help
jpayne@69: information is defined, help information will be printed.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub printUsageInfo() {
jpayne@69:      
jpayne@69:       my $self = shift;
jpayne@69:       if (defined $self->{usage_info}) {
jpayne@69:          print STDERR $self->{usage_info};
jpayne@69:       }
jpayne@69:       elsif (defined $self->{help_info}) {
jpayne@69:          print STDERR $self->{help_info};
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          print STDERR "No usage information defined.\n";
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->printUsageInfoAndExit();
jpayne@69: 
jpayne@69: The C<printUsageInfoAndExit()> function prints the usage information the
jpayne@69: reported by the C<setUsageInfo()> function and exits with status 1.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub printUsageInfoAndExit() {
jpayne@69:       my $self = shift;
jpayne@69:       $self->printUsageInfo();
jpayne@69:       $self->bail("Incorrect command line");
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->setUsageInfo($usage_string);
jpayne@69: 
jpayne@69: The C<setUsageInfo()> function sets the usage information via C<$usage_string>.
jpayne@69: If C<$usage_string> is undefined, invalid, or empty, the usage information 
jpayne@69: is undefined.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub setUsageInfo($) {
jpayne@69:       my $self = shift;
jpayne@69:       my $usage_string = shift;
jpayne@69:       if (
jpayne@69:           (defined $usage_string) &&
jpayne@69:           ($usage_string =~ /\S/) &&
jpayne@69:           ((ref $usage_string) eq "")
jpayne@69:          ) {
jpayne@69: 	 chomp($usage_string); #removing a new line if it is there.
jpayne@69:          $self->{usage_info} = $usage_string."\n";#adding a new line to usage
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          $self->{usage_info} = undef;
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: # Functional Class : files
jpayne@69: 
jpayne@69: =item $valid = isReadableFile($file_name);
jpayne@69: 
jpayne@69: This function accepts a single scalar parameter containing a file name.
jpayne@69: If the file corresponding to the file name is a readable plain file or symbolic
jpayne@69: link, this function returns 1.  Otherwise, the function returns 0.  If the file
jpayne@69: name passed is undefined, this function returns 0 as well.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub isReadableFile($) {
jpayne@69:       my $file = shift;
jpayne@69:       if (scalar(@_) != 0) { #incase the method was invoked as an instance 
jpayne@69:                              #method
jpayne@69:          $file  = shift;
jpayne@69:       }
jpayne@69:  
jpayne@69:       if (defined ($file) &&             # was a file name passed?
jpayne@69:           ((-f $file) || (-l $file)) &&  # is the file a file or sym. link?
jpayne@69:           (-r $file)                     # is the file readable?
jpayne@69:          ) {
jpayne@69:          return 1;
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          return 0;
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $valid = isExecutableFile($file_name);
jpayne@69: 
jpayne@69: This function accepts a single scalar parameter containing a file name.
jpayne@69: If the file corresponding to the file name is an executable plain file
jpayne@69: or symbolic link, this function returns 1.  Otherwise, the function returns 0.
jpayne@69: If the file name passed is undefined, this function returns 0 as well.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub isExecutableFile($) {
jpayne@69:       my $file = shift;
jpayne@69:        if (scalar(@_) != 0) { # incase the method was invoked as a instance
jpayne@69:                               # method
jpayne@69:          $file  = shift;
jpayne@69:       }
jpayne@69:  
jpayne@69:       if (defined ($file) &&             # was a file name passed?
jpayne@69:           ((-f $file) || (-l $file)) &&  # is the file a file or sym. link?
jpayne@69:           (-x $file)                     # is the file executable?
jpayne@69:          ) {
jpayne@69:          return 1;
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          return 0;
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $valid = isWritableFile($file_name);
jpayne@69: 
jpayne@69: This function accepts a single scalar parameter containing a file name.
jpayne@69: If the file corresponding to the file name is a writable plain file
jpayne@69: or symbolic link, this function returns 1.  Otherwise, the function returns 0.
jpayne@69: If the file name passed is undefined, this function returns 0 as well.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub isWritableFile($) {
jpayne@69:       my $file = shift;
jpayne@69:       if (scalar(@_) != 0) { # incase the method was invoked as a instance
jpayne@69:                              #  method
jpayne@69:          $file  = shift;
jpayne@69:       }
jpayne@69:  
jpayne@69:       if (defined ($file) &&             # was a file name passed?
jpayne@69:           ((-f $file) || (-l $file)) &&  # is the file a file or sym. link?
jpayne@69:           (-w $file)                     # is the file writable?
jpayne@69:          ) {
jpayne@69:          return 1;
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          return 0;
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $valid = isCreatableFile($file_name);
jpayne@69: 
jpayne@69: This function accepts a single scalar parameter containing a file name.  If
jpayne@69: the file corresponding to the file name is creatable this function returns 1.
jpayne@69: The function checks if the location of the file is writable by the effective
jpayne@69: user id (EUID).  If the file location does not exist or the location is not
jpayne@69: writable, the function returns 0.  If the file name passed is undefined,
jpayne@69: this function returns 0 as well.  Note that files with suffix F</> are not
jpayne@69: supported under UNIX platforms, and will return 0.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub isCreatableFile($) {
jpayne@69:       my $file = shift;
jpayne@69:       if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69:                              # method
jpayne@69:          $file  = shift;
jpayne@69:       }
jpayne@69: 
jpayne@69:       my $return_code = 0;
jpayne@69: 
jpayne@69:       if (
jpayne@69:           (defined ($file)) &&
jpayne@69:           (! -e $file) &&
jpayne@69:           ($file !~ /\/$/) 
jpayne@69:          ) {
jpayne@69:          my $dirname = dirname($file);
jpayne@69:          # check the writability of the directory
jpayne@69:          $return_code = isWritableDir($dirname);
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          # the file exists, it's not creatable
jpayne@69:          $return_code = 0;
jpayne@69:       }
jpayne@69:       return $return_code;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $valid = isReadableDir($directory_name);
jpayne@69: 
jpayne@69: This function accepts a single scalar parameter containing a directory name.
jpayne@69: If the name corresponding to the directory is a readable, searchable directory 
jpayne@69: entry, this function returns 1.  Otherwise, the function returns 0.  If the
jpayne@69: name passed is undefined, this function returns 0 as well.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub isReadableDir($) {
jpayne@69:       my $file = shift;
jpayne@69:       if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69:                              # method
jpayne@69:          $file  = shift;
jpayne@69:       }
jpayne@69:  
jpayne@69:       if (defined ($file) &&             # was a name passed?
jpayne@69:           (-d $file) &&                  # is the name a directory?
jpayne@69:           (-r $file) &&                  # is the directory readable?
jpayne@69:           (-x $file)                     # is the directory searchable?
jpayne@69:          ) {
jpayne@69:          return 1;
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          return 0;
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $valid = isWritableDir($directory_name);
jpayne@69: 
jpayne@69: This function accepts a single scalar parameter containing a directory name.
jpayne@69: If the name corresponding to the directory is a writable, searchable directory 
jpayne@69: entry, this function returns 1.  Otherwise, the function returns 0.  If the
jpayne@69: name passed is undefined, this function returns 0 as well.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub isWritableDir($) {
jpayne@69:       my $file = shift;
jpayne@69:       if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69:                              # method
jpayne@69:          $file  = shift;
jpayne@69:       }
jpayne@69:  
jpayne@69:       if (defined ($file) &&             # was a name passed?
jpayne@69:           (-d $file) &&                  # is the name a directory?
jpayne@69:           (-w $file) &&                  # is the directory writable?
jpayne@69:           (-x $file)                     # is the directory searchable?
jpayne@69:          ) {
jpayne@69:          return 1;
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          return 0;
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $valid = isCreatableDir($directory_name);
jpayne@69: 
jpayne@69: This function accepts a single scalar parameter containing a directory name.  
jpayne@69: If the name corresponding to the directory is creatable this function returns 
jpayne@69: 1. The function checks if the immediate parent of the directory is writable by
jpayne@69: the effective user id (EUID).  If the parent directory does not exist or the 
jpayne@69: tree is not writable, the function returns 0.  If the directory name passed is
jpayne@69: undefined, this function returns 0 as well.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub isCreatableDir($) {
jpayne@69:       my $dir = shift;
jpayne@69:       if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69:                              # method
jpayne@69:          $dir  = shift;
jpayne@69:       }
jpayne@69:       my $return_code = 0;
jpayne@69: 
jpayne@69:       if (defined ($dir)) {
jpayne@69:          $dir =~ s/\/$//g;
jpayne@69:          $return_code = isCreatableFile($dir);
jpayne@69:       }
jpayne@69:       return $return_code;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $valid = isCreatablePath($path_name);
jpayne@69: 
jpayne@69: This function accepts a single scalar parameter containing a path name.  If
jpayne@69: the C<$path_name> is creatable this function returns 1. The function checks 
jpayne@69: if the directory hierarchy of the path is creatable or writable by the
jpayne@69: effective user id (EUID).  This function calls itself recursively until
jpayne@69: an existing directory node is found.  If that node is writable, ie. the path
jpayne@69: can be created in it, then this function returns 1.  Otherwise, the function
jpayne@69: returns 0.  This function also returns zero if the C<$path_name> supplied
jpayne@69: is disconnected from a reachable directory tree on the file system.
jpayne@69: If the path already exists, this function returns 0.  The C<$path_name> may
jpayne@69: imply either a path to a file or a directory.  Path names may be relative or
jpayne@69: absolute paths.  Any unresolvable relative paths will return 0 as well.  This
jpayne@69: includes paths with F<..> back references to nonexistent directories.
jpayne@69: This function is recursive whereas C<isCreatableFile()> and 
jpayne@69: C<isCreatableDir()> are not.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub isCreatablePath($) {
jpayne@69:       my $pathname = shift;
jpayne@69:       if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69:                              # method
jpayne@69:          $pathname  = shift;
jpayne@69:       }
jpayne@69:       my $return_code = 0;
jpayne@69: 
jpayne@69:       if (defined $pathname) {
jpayne@69:          # strip trailing '/'
jpayne@69:          $pathname =~ s/(.+)\/$/$1/g;
jpayne@69:          my $filename = basename($pathname);
jpayne@69:          my $dirname = dirname($pathname);
jpayne@69:          if (
jpayne@69:              (! -e $pathname) &&
jpayne@69:              ($dirname ne $pathname) &&
jpayne@69:              ($filename ne "..")
jpayne@69:             ) {
jpayne@69:             if (-e $dirname) {
jpayne@69:                $return_code = isWritableDir($dirname);
jpayne@69:             }
jpayne@69:             else {
jpayne@69:                $return_code = isCreatablePath($dirname);
jpayne@69:             }
jpayne@69:          }
jpayne@69:          else {
jpayne@69:             $return_code = 0;
jpayne@69:          }
jpayne@69:       }
jpayne@69:       return $return_code;
jpayne@69:    }
jpayne@69:          
jpayne@69: 
jpayne@69: # Functional Class : date
jpayne@69: 
jpayne@69: =item $date_string = getISODate($tm);
jpayne@69: 
jpayne@69: This function returns the ISO 8601 datetime as a string given a time
jpayne@69: structure as returned by the C<time> function.  If no arguments
jpayne@69: are supplied, this function returns the current time.  If incorrect
jpayne@69: arguments are supplied, this function returns undefined.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getISODate(;@) {
jpayne@69:       #checking if the function is invoked as an instance method.
jpayne@69:       if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69:          shift;
jpayne@69:       } 
jpayne@69:       my @time_val = @_;
jpayne@69:       my $time_str = undef;
jpayne@69:       if (scalar(@time_val) == 0) {
jpayne@69:          @time_val = localtime;
jpayne@69:       }
jpayne@69:       eval {
jpayne@69:          $time_str = strftime "%Y-%m-%d %H:%M:%S", @time_val;
jpayne@69:       };
jpayne@69:       return $time_str;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $date_string = getSybaseDate(@tm);
jpayne@69: 
jpayne@69: This function returns a Sybase formatted datetime as a string given a time
jpayne@69: structure as returned by the C<time> function.  If no arguments
jpayne@69: are supplied, this function returns the current time.  If incorrect
jpayne@69: arguments are supplied, this function returns undefined.  The date string
jpayne@69: returned is quoted according to Sybase requirements.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getSybaseDate(;@) {
jpayne@69:       #checking if the function is invoked as an instance method.
jpayne@69:       if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69:          shift;
jpayne@69:       } 
jpayne@69:       my @time_val = @_;
jpayne@69:       my $time_str = undef;
jpayne@69:       if (scalar(@time_val) == 0) {
jpayne@69:          @time_val = localtime;
jpayne@69:       }
jpayne@69:       eval {
jpayne@69:          $time_str = strftime "\'%b %d %Y %I:%M%p\'", @time_val;
jpayne@69:       };
jpayne@69:       return $time_str;
jpayne@69:    }
jpayne@69:       
jpayne@69: 
jpayne@69: =item $date_string = getMySQLDate(@tm);
jpayne@69: 
jpayne@69: This function returns a MySQL formatted datetime as a string given a time
jpayne@69: structure as returned by the C<time> function.  If no arguments
jpayne@69: are supplied, this function returns the current time.  If incorrect
jpayne@69: arguments are supplied, this function returns undefined.  The datetime string
jpayne@69: returned is prequoted according to MySQL requirements.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getMySQLDate(;@) {
jpayne@69:       #checking if the function is invoked as an instance method.
jpayne@69:       if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69:          shift;
jpayne@69:       }
jpayne@69:       my @time_val = @_;
jpayne@69:       my $time_str = undef;
jpayne@69:       if (scalar(@time_val) == 0) {
jpayne@69:          @time_val = localtime;
jpayne@69:       }
jpayne@69:       $time_str = getISODate(@time_val);
jpayne@69:       if (defined $time_str) {
jpayne@69:          $time_str = "\'$time_str\'";
jpayne@69:       }
jpayne@69:       return $time_str;
jpayne@69:    }
jpayne@69:       
jpayne@69: 
jpayne@69: =item $date_string = getFilelabelDate(@tm);
jpayne@69: 
jpayne@69: This function returns the date (not time) as a compressed string
jpayne@69: suitable for use as part of a file name.  The format is YYMMDD.
jpayne@69: The optional parameter should be a time structure as returned by 
jpayne@69: the C<time> function.  If no arguments are supplied, the current time
jpayne@69: is used.  If incorrect arguments are supplied, this function returns
jpayne@69: undefined.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getFilelabelDate(;@) {
jpayne@69:       #checking if the function is invoked as an instance method.
jpayne@69:       if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69:          shift;
jpayne@69:       }
jpayne@69:       my @time_val = @_;
jpayne@69:       my $time_str = undef;
jpayne@69:       if (scalar(@time_val) == 0) {
jpayne@69:          @time_val = localtime;
jpayne@69:       }
jpayne@69:       eval {
jpayne@69:          $time_str = strftime "%y%m%d", @time_val;
jpayne@69:       };
jpayne@69:       return $time_str;
jpayne@69:    }
jpayne@69:       
jpayne@69: 
jpayne@69: =item $date_string = $obj_instance->getLogfileDate(@tm);
jpayne@69: 
jpayne@69: This function returns the datetime as a formatted string
jpayne@69: suitable for use as a log entry header.  The optional parameter
jpayne@69: should be a time structure as returned by the C<time> function.
jpayne@69: If no arguments are supplied, this function uses the current time.
jpayne@69: If incorrect arguments are supplied, this function sets the date/time fields
jpayne@69: of the log entry string to C< INVALID|XXXXXX|>.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getLogfileDate(;@) {
jpayne@69:       #checking if the function is invoked as an instance method.
jpayne@69:       if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69:          shift;
jpayne@69:       } 
jpayne@69:       my @time_val = @_;
jpayne@69:       my $time_str = undef;
jpayne@69:       my $log_form = undef;
jpayne@69:       if (scalar(@time_val) == 0) {
jpayne@69:          @time_val = localtime;
jpayne@69:       }
jpayne@69:       eval {
jpayne@69:          $time_str = strftime("%Y%m%d|%H%M%S|", @time_val);
jpayne@69:       };
jpayne@69:       if (!defined $time_str) {
jpayne@69:          $time_str = " INVALID|XXXXXX|";
jpayne@69:       }
jpayne@69:       $log_form = $time_str . sprintf("%6d| ", $$);
jpayne@69:       return $log_form;
jpayne@69:    }
jpayne@69:       
jpayne@69: 
jpayne@69: # Functional Class : logging
jpayne@69: 
jpayne@69: =item $obj_instance->setDebugLevel($new_level);
jpayne@69: 
jpayne@69: This function sets the level of debug reporting according to C<$new_level>.
jpayne@69: If the debug level is less than 0, all debug reporting is turned off.
jpayne@69: It is impossible to turn off error reporting from C<bail()>.  If C<$new_level>
jpayne@69: is undefined, the debug level is set to 0.  This function maintains 
jpayne@69: compatibility with C<GetOptions()>, and will accept a second parameter
jpayne@69: the debug level, provided it is an integer.  In such cases, the first parameter
jpayne@69: is checked only if the second parameter is invalid.  By default, the default
jpayne@69: level is undefined.  To turn on debugging, you must invoke this function.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub setDebugLevel($;$) {
jpayne@69:       my $self = shift;
jpayne@69:       my $new_level = shift;
jpayne@69:       my $getopts_new_level = shift;
jpayne@69: 
jpayne@69:       if (
jpayne@69:           (defined $getopts_new_level) &&
jpayne@69:           ($getopts_new_level =~ /^-?\d+$/)
jpayne@69:          ) {
jpayne@69:          $new_level = $getopts_new_level;
jpayne@69:       }
jpayne@69:       elsif (
jpayne@69:           (!defined $new_level) ||
jpayne@69:           ($new_level !~ /^-?\d+$/)
jpayne@69:          ) {
jpayne@69:          $new_level = 0;
jpayne@69:          $self->logLocal("No or invalid parameter to setDebugLevel(), " .
jpayne@69:                          "setting debug level to 0", 3);
jpayne@69:       }
jpayne@69: 
jpayne@69:       if ($new_level < 0) {
jpayne@69:          $new_level = -1;
jpayne@69:       }
jpayne@69: 
jpayne@69:       $self->{debug_level} = $new_level;
jpayne@69:       $self->logLocal("Set debug level to " . $self->getDebugLevel(), 2);
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $level = $obj_instance->getDebugLevel();
jpayne@69: 
jpayne@69: This function returns the current debug level.  If the current debug
jpayne@69: level is not defined, this function returns undefined.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getDebugLevel() {
jpayne@69:       my $self = shift;
jpayne@69:       return $self->{debug_level};
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->setLogFile($log_file);
jpayne@69: 
jpayne@69: This function sets the log file name for the C<logLocal()> function.
jpayne@69: B<The programmer should call this function before invoking C<setDebugLevel()>>
jpayne@69: if the default log file is not to be used.  The function takes one parameter,
jpayne@69: C<$log_file>, which defines the new log file name.  If a log file is already
jpayne@69: open, it is closed.  The old log file is not truncated or deleted.
jpayne@69: Future calls to C<logLocal()> or C<bail()> will log to C<$log_file> if it
jpayne@69: is successfully opened.  If the new log file is not successfully opened, 
jpayne@69: the function will try to open the default log file, F<program_name.log>.
jpayne@69: If that file cannot be opened, F</tmp/program_name.$process_id.log> will
jpayne@69: be used.  If no log file argument is passed, the function will try to open
jpayne@69: the default log file.  This function is C<GetOptions()> aware; it will accept
jpayne@69: two parameters, using the second one as the log file and ignoring the first if
jpayne@69: and only if two parameters are passed.  Any other usage specifies the first
jpayne@69: parameter as the log file name.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub setLogFile($;$) {
jpayne@69:       my $self = shift;
jpayne@69:       my $old_log_file = defined $self->{static_log_file} ? 
jpayne@69:          $self->{static_log_file} : undef;
jpayne@69:       $self->{static_log_file} = shift;
jpayne@69:       if (scalar(@_) == 1) {
jpayne@69:          $self->{static_log_file} = shift;
jpayne@69:       }
jpayne@69: 
jpayne@69:       # only consider a new log file that is definable as a file
jpayne@69:       if ((defined ($self->{static_log_file})) &&
jpayne@69:           ($self->{static_log_file} !~ /^\s*$/)) {
jpayne@69:          # delete an old log file entry added by "setLogFile"
jpayne@69:          for (my $idx = 0;
jpayne@69:               ($idx <= $#{$self->{log_files}}) && defined($old_log_file);
jpayne@69:               $idx++) {
jpayne@69:             if ($self->{log_files}[$idx] eq $old_log_file) {
jpayne@69:                splice @{$self->{log_files}}, $idx, 1;
jpayne@69:                $old_log_file = undef;
jpayne@69:             }
jpayne@69:          }
jpayne@69:          unshift @{$self->{log_files}}, $self->{static_log_file};
jpayne@69: 
jpayne@69:          # initialize the log file variables and file spaces
jpayne@69:          $self->{msg_file_used} = 0;
jpayne@69:          $self->{error_file_used} = 0;
jpayne@69:          $self->cleanLogFILES();
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $log_file_name = $obj_instance->getLogFile();
jpayne@69: 
jpayne@69: This function returns the name of the log file to be used for printing
jpayne@69: log messages.  If no log file is available, this function returns undefined.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getLogFile() {
jpayne@69:       my $self = shift;
jpayne@69:       my $return_val = undef;
jpayne@69:       if (
jpayne@69:           (scalar(@{$self->{log_files}}) != 0) &&
jpayne@69:           (defined($self->{log_files}[0]))
jpayne@69:          ) {
jpayne@69:          $return_val = $self->{log_files}[0];
jpayne@69:       }
jpayne@69:       return $return_val;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $error_file_name = $obj_instance->getErrorFile();
jpayne@69: 
jpayne@69: This function returns the name of the error file to be used for printing
jpayne@69: error messages.  The error file is derived from the log file; a F<.log>
jpayne@69: extension is replaced by a F<.error> extension.  If there is no F<.log>
jpayne@69: extension, then F<.error> is appended to the log file name.  If no
jpayne@69: log files are defined, this function returns undefined.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub getErrorFile() {
jpayne@69:       my $self = shift;
jpayne@69:       my $return_val = $self->getLogFile();
jpayne@69:       if (defined $return_val) {
jpayne@69:          $return_val =~ s/\.log$//g;
jpayne@69:          $return_val .= '.error';
jpayne@69:       }
jpayne@69:       return $return_val;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69:    # the following private functions are used for logging
jpayne@69: 
jpayne@69: 
jpayne@69:    # push items onto the debug level stack
jpayne@69:    sub debugPush() {
jpayne@69:       my $self = shift;
jpayne@69:       if (defined ($self->{debug_level})) {
jpayne@69:          push @{$self->{debug_store}}, $self->{debug_level};
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          push @{$self->{debug_store}}, "undef";
jpayne@69:       }
jpayne@69:       $self->{debug_level} = undef;
jpayne@69:    } 
jpayne@69: 
jpayne@69: 
jpayne@69:    # pop items from the debug level stack
jpayne@69:    sub debugPop() {
jpayne@69:       my $self = shift;
jpayne@69:       $self->{debug_level} = pop @{$self->{debug_store}};
jpayne@69:       if (
jpayne@69:           (!defined ($self->{debug_level})) || 
jpayne@69:           ($self->{debug_level} eq "undef")
jpayne@69:          ) {
jpayne@69:          $self->{debug_level} = undef;
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69:    # remove log files
jpayne@69:    sub removeLogERROR() {
jpayne@69:      
jpayne@69:       my $self = shift;
jpayne@69:       $self->debugPush();
jpayne@69:       if (
jpayne@69:           (defined $self->getErrorFile()) &&
jpayne@69:           (isWritableFile($self->getErrorFile()))
jpayne@69:          ) {
jpayne@69: 	    unlink $self->getErrorFile() or
jpayne@69:             $self->logLocal("Unable to remove error file " .
jpayne@69:                              $self->getErrorFile(), 3);
jpayne@69:       }
jpayne@69:       $self->debugPop();
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69:    sub removeLogMSG() {
jpayne@69:       my $self = shift;
jpayne@69:       $self->debugPush();
jpayne@69:      
jpayne@69:       if (
jpayne@69:           (defined $self->getLogFile()) &&
jpayne@69:           (isWritableFile($self->getLogFile()))
jpayne@69:          ) {
jpayne@69:             unlink $self->getLogFile() or 
jpayne@69:             $self->logLocal("Unable to remove error file " .
jpayne@69:                              $self->getLogFile(), 3);
jpayne@69:       }
jpayne@69:       $self->debugPop();
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69:    # invalidate log files
jpayne@69:    sub invalidateLogFILES() {
jpayne@69:       my $self = shift;
jpayne@69:       $self->debugPush();
jpayne@69:       if (defined $self->getLogFile()) {
jpayne@69:          $self->logLocal("Invalidating " . $self->getLogFile(), 2); 
jpayne@69:          shift @{$self->{log_files}};
jpayne@69:          $self->{msg_append_flag} = $self->{error_append_flag} =
jpayne@69:             $self->{log_append_setting};
jpayne@69:          $self->{msg_file_used} = $self->{error_file_used} = 0;
jpayne@69:          $self->cleanLogFILES();
jpayne@69:       }
jpayne@69:       $self->debugPop();
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69:    # clean previous log files
jpayne@69:    sub cleanLogFILES() {
jpayne@69:       my $self = shift;
jpayne@69:       if ($self->{log_append_setting} == 0) {
jpayne@69:          if ($self->{msg_file_used} == 0) {
jpayne@69:             $self->removeLogMSG();
jpayne@69:          }
jpayne@69:          if ($self->{error_file_used} == 0) {
jpayne@69:             $self->removeLogERROR();
jpayne@69:          }
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69:    # close log files
jpayne@69:    sub closeLogERROR() {
jpayne@69:       my $self = shift;
jpayne@69:       my $return_code = 1; # need to return true for success, false for fail
jpayne@69: 
jpayne@69:       $self->debugPush();
jpayne@69:       if (!close(ERRLOG) && (defined $self->getErrorFile())) {
jpayne@69:          $self->logLocal("Cannot close " . $self->getErrorFile(), 3);
jpayne@69:          $return_code = 0;
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          $return_code = 1;
jpayne@69:       }
jpayne@69:       $self->{error_file_open_flag} = 0;
jpayne@69:       $self->debugPop();
jpayne@69:       return $return_code;
jpayne@69:    }   
jpayne@69: 
jpayne@69: 
jpayne@69:    sub closeLogMSG() {
jpayne@69:       my $self = shift;
jpayne@69:       my $return_code = 1; # need to return true for success, false for fail
jpayne@69: 
jpayne@69:       $self->debugPush();
jpayne@69:       if (!close(MSGLOG) && (defined $self->getLogFile())) {
jpayne@69:          $self->logLocal("Cannot close " . $self->getLogFile(), 3);
jpayne@69:          $return_code = 0;
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          $return_code = 1;
jpayne@69:       }
jpayne@69:       $self->{msg_file_open_flag} = 0;
jpayne@69:       $self->debugPop();
jpayne@69:       return $return_code;
jpayne@69:    }   
jpayne@69: 
jpayne@69: 
jpayne@69:    # open log files
jpayne@69:    sub openLogERROR() {
jpayne@69:       my $self = shift;
jpayne@69:       my $return_code = 1; # need to return true for success, false for fail
jpayne@69: 
jpayne@69:       $self->debugPush();
jpayne@69:       if ((defined $self->getErrorFile()) &&
jpayne@69:           ($self->{error_file_open_flag} == 0)) {
jpayne@69:          my $fileop;
jpayne@69:          $self->{error_file_open_flag} = 1;
jpayne@69:          if ($self->{error_append_flag} == 0) {
jpayne@69:             $fileop = '>';
jpayne@69:             $self->{error_append_flag} = 1;
jpayne@69:          }
jpayne@69:          else {
jpayne@69:             $fileop = '>>';
jpayne@69:          }
jpayne@69:          if (open(ERRLOG, $fileop . $self->getErrorFile())) {
jpayne@69:             autoflush ERRLOG 1;
jpayne@69:          }
jpayne@69:          else {
jpayne@69:             $self->logLocal("Cannot open " . $self->getErrorFile() .
jpayne@69:                " for logging", 4);
jpayne@69:             $self->{error_file_open_flag} = 0;
jpayne@69:          }
jpayne@69:       }
jpayne@69:       $return_code = $self->{error_file_open_flag};
jpayne@69:       $self->debugPop();
jpayne@69: 
jpayne@69:       # this is 1 if the file stream is open, 0 if not
jpayne@69:       return $return_code;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69:    sub openLogMSG() {
jpayne@69:       my $self = shift;
jpayne@69:       my $return_code = 1; # need to return true for success, false for fail
jpayne@69: 
jpayne@69:       $self->debugPush();
jpayne@69:       if ((defined $self->getLogFile()) && ($self->{msg_file_open_flag} == 0)){
jpayne@69:          my $fileop;
jpayne@69:          $self->{msg_file_open_flag} = 1;
jpayne@69:          if ($self->{msg_append_flag} == 0) {
jpayne@69:             $fileop = '>';
jpayne@69:             $self->{msg_append_flag} = 1;
jpayne@69:          }
jpayne@69:          else {
jpayne@69:             $fileop = '>>';
jpayne@69:          }
jpayne@69: 
jpayne@69:          if (open(MSGLOG, $fileop . $self->getLogFile())) {
jpayne@69:             autoflush MSGLOG 1;
jpayne@69:          }
jpayne@69:          else {
jpayne@69:             $self->logLocal("Cannot open " . $self->getLogFile() . 
jpayne@69:                             " for logging", 4);
jpayne@69:             $self->{msg_file_open_flag} = 0;
jpayne@69:          }
jpayne@69:       }
jpayne@69:       $return_code = $self->{msg_file_open_flag};
jpayne@69:       $self->debugPop();
jpayne@69: 
jpayne@69:       # this is 1 if the file stream is open, 0 if not
jpayne@69:       return $return_code;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->logAppend($log_append_flag);
jpayne@69: 
jpayne@69: The C<logAppend()> function takes either C<0> or C<1> as a flag to 
jpayne@69: disable or enable log file appending.  By default, log files are 
jpayne@69: truncated at the start of program execution or logging.  Error files are
jpayne@69: controlled by this variable as well.  Invalid or undefined calls are ignored.
jpayne@69: Calling this function with a C<0> argument after the log files have started
jpayne@69: to be written may cause them to be truncated undesirably.  This function is
jpayne@69: C<GetOptions()> compliant; if 2 and only 2 variables are passed, the second
jpayne@69: option is treated as C<$log_append_flag>.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub logAppend($;$) {
jpayne@69:       my $self = shift;
jpayne@69:       my $log_append_flag = shift;
jpayne@69:       if (defined $_[0]) {
jpayne@69:          $log_append_flag = shift;
jpayne@69:       }
jpayne@69:       if (
jpayne@69:           (defined ($log_append_flag)) &&
jpayne@69:           (($log_append_flag eq "0") ||
jpayne@69:            ($log_append_flag eq "1"))
jpayne@69:          ) {
jpayne@69:          $self->{log_append_setting} = $self->{msg_append_flag} = 
jpayne@69:             $self->{error_append_flag} = $log_append_flag;
jpayne@69:       }
jpayne@69:    } 
jpayne@69: 
jpayne@69: 
jpayne@69: =item $obj_instance->logLocal($log_message, $log_level);
jpayne@69: 
jpayne@69: The C<logLocal()> function takes two arguments.  The C<$log_message>
jpayne@69: argument specifies the message to be written to the log file.  The
jpayne@69: C<$log_level> argument specifies the level at which C<$log_message> is printed.
jpayne@69: The active level of logging is set via the C<setDebugLevel()> function.
jpayne@69: Only messages at C<$log_level> less than or equal to the active debug
jpayne@69: level are logged.  The default debug level is undefined.  Note, a trailing
jpayne@69: new line, if it exists, is stripped from the log message.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub logLocal($$) {
jpayne@69:       my $self = shift;
jpayne@69:       my $log_message = shift;
jpayne@69:       my $log_level = shift;
jpayne@69: 
jpayne@69:       if ((!defined $log_level) || ($log_level =~ /\D/)) {
jpayne@69:          $log_level = 1;
jpayne@69:       }
jpayne@69: 
jpayne@69:       if (defined $log_message) {
jpayne@69:          chomp $log_message; # strip end new line, if it exists
jpayne@69: 
jpayne@69:          $log_message = getLogfileDate() . $log_message;
jpayne@69:          push @{$self->{debug_queue}}, [ $log_message, $log_level ];
jpayne@69: 
jpayne@69:          if ((defined ($self->getDebugLevel())) &&
jpayne@69:                       ($self->getDebugLevel() > -1)) {
jpayne@69:             while (
jpayne@69:                    (defined(my $log_record = $self->{debug_queue}[0])) &&
jpayne@69:                    (defined($self->getLogFile()))
jpayne@69:                   ) {
jpayne@69:                ($log_message, $log_level) = @{$log_record};
jpayne@69:                if (
jpayne@69:                    (
jpayne@69:                     ($log_level <= $self->getDebugLevel()) && # debug level
jpayne@69:                     ($self->openLogMSG())                  && # check log file
jpayne@69:                     (print MSGLOG "$log_message\n")        && # print message
jpayne@69:                     ($self->closeLogMSG())                 && # close log file
jpayne@69:                     ($self->{msg_file_used} = 1)              # log file used
jpayne@69:                    ) ||
jpayne@69:                    (
jpayne@69:                     ($log_level > $self->getDebugLevel())     # bad dbg level
jpayne@69:                    ) 
jpayne@69:                   ) {
jpayne@69:                   # log message is successfully processed, so shift it off
jpayne@69:                   shift @{$self->{debug_queue}};
jpayne@69:                }
jpayne@69:                else {
jpayne@69:                   $self->debugPush();
jpayne@69:                   $self->logLocal("Cannot log message \'$log_message\' to " .
jpayne@69:                      $self->getLogFile() . " = " .  $!, 9);
jpayne@69:                   $self->invalidateLogFILES(); 
jpayne@69:                   $self->debugPop();
jpayne@69:                }
jpayne@69:             }
jpayne@69:          }
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          $self->logLocal("logLocal() called without any parameters!",3);
jpayne@69:       }
jpayne@69: 
jpayne@69:       while ($#{$self->{debug_queue}} >= $self->{max_debug_queue_size}) {
jpayne@69:          # expire old entries; this needs to happen if $self->{debug_level}
jpayne@69:          # is undefined or there is no writable log file, otherwise the
jpayne@69:          # queue could exhaust RAM.
jpayne@69:          shift @{$self->{debug_queue}};
jpayne@69:       }
jpayne@69:    }
jpayne@69:    
jpayne@69: 
jpayne@69: =item $obj_instance->logError($log_message,$flag);
jpayne@69: 
jpayne@69: The C<logError()> function takes two arguments, the second one being optional. 
jpayne@69: The C<$log_message> argument specifies the message to be written to the error 
jpayne@69: file. If the C<$flag> argument is defined and is non-zero, the C<$log_message>
jpayne@69: is also written to STDERR. The C<$log_message> is also passed to C<logLocal>.
jpayne@69: A message passed via logError() will always get logged to the log file 
jpayne@69: regardles of the debug level.  Note, a trailing new line, if it exists, is 
jpayne@69: stripped from the log message.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub logError($;$) {
jpayne@69:       
jpayne@69:       my $self = shift;
jpayne@69:       my $log_message = shift;
jpayne@69:       my $flag = shift; 
jpayne@69:       if (defined $log_message) {
jpayne@69:          chomp $log_message;  # strip end new line, if it exists
jpayne@69:          $self->logLocal($log_message, 0);
jpayne@69: 
jpayne@69:          #printing error message to STDERR if flag is non zero.
jpayne@69:          if((defined($flag)) && ($flag ne '0')) {
jpayne@69:             print STDERR "$log_message\n";
jpayne@69:          }        
jpayne@69: 
jpayne@69:          $log_message = getLogfileDate() . $log_message;
jpayne@69:          push(@{$self->{error_queue}}, $log_message);
jpayne@69:         
jpayne@69:          while (
jpayne@69:                 (defined(my $log_message = $self->{error_queue}[0])) &&
jpayne@69:                 (defined($self->getErrorFile()))
jpayne@69:                ) {
jpayne@69:                
jpayne@69:             if (
jpayne@69:                 ($self->openLogERROR()) &&     
jpayne@69:                 (print ERRLOG "$log_message\n") &&
jpayne@69:                 ($self->closeLogERROR()) &&
jpayne@69:                 ($self->{error_file_used} = 1) # that is an '='
jpayne@69:                ) {
jpayne@69: 	       shift @{$self->{error_queue}};
jpayne@69:             }
jpayne@69:             else {
jpayne@69:                $self->debugPush();
jpayne@69:                $self->logLocal("Cannot log message \'$log_message\' to " .
jpayne@69:                   $self->getErrorFile() . " = $!", 6);
jpayne@69:                $self->invalidateLogFILES(); 
jpayne@69:                $self->debugPop();
jpayne@69:             }
jpayne@69:          }
jpayne@69:       }
jpayne@69:       else {
jpayne@69:          $self->logLocal("logError() called without any parameters!",3);
jpayne@69:       }
jpayne@69: 
jpayne@69:       while ($#{$self->{error_queue}} >= $self->{max_debug_queue_size}) {
jpayne@69:          # expire old entries; this needs to happen if $self->{debug_level}
jpayne@69:          # is undefined or there is no writable log file, otherwise the
jpayne@69:          # queue could exhaust RAM.
jpayne@69:          shift @{$self->{error_queue}};
jpayne@69:       }
jpayne@69:    }
jpayne@69:  
jpayne@69: 
jpayne@69: =item $obj_instance->bail($log_message);
jpayne@69: 
jpayne@69: The C<bail()> function takes a single required argument.  The C<$log_message>
jpayne@69: argument specifies the message to be passed to C<logLocal()> and displayed
jpayne@69: to the screen in using the C<warn> function.  All messages passed to C<bail()>
jpayne@69: are logged regardless of the debug level.  The C<bail()> function
jpayne@69: calls C<exit(1)> to terminate the program.  Optionally, a second positive
jpayne@69: integer argument can be passed as the exit code to use.  Note, a trailing
jpayne@69: new line, if it exists, is stripped from the end of the line.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub bail($;$) {
jpayne@69:       my $self = shift;
jpayne@69:       my $log_message = shift;
jpayne@69:       my $exit_code = shift;
jpayne@69: 
jpayne@69:       if (
jpayne@69:           (!defined $exit_code) ||
jpayne@69:           ($exit_code !~ /^\d+$/)
jpayne@69:          ) {
jpayne@69:          $exit_code = 1;
jpayne@69:       }
jpayne@69:       if (defined $log_message) {
jpayne@69:          chomp $log_message;  # strip end new line, if it exists
jpayne@69: 
jpayne@69:          $self->logError($log_message);
jpayne@69:          print STDERR $log_message, "\n";
jpayne@69:       }
jpayne@69: 
jpayne@69:       exit $exit_code;
jpayne@69:    }
jpayne@69: 
jpayne@69: 
jpayne@69: # Functional Class : modified methods
jpayne@69: 
jpayne@69: =item $getopts_error_code = $obj_instance->TIGR_GetOptions(@getopts_arguments);
jpayne@69: 
jpayne@69: This function extends C<Getopt::Long::GetOptions()>.  It may be used
jpayne@69: as C<GetOptions()> is used.  Extended functionality eliminates the need
jpayne@69: to C<eval {}> the block of code containing the function.  Further, TIGR
jpayne@69: standard options, such as C<-help>, are defined implicitly.  Using this
jpayne@69: function promotes proper module behavior.  Log and error files from 
jpayne@69: previous runs are removed if the log file append option, C<-appendlog>,
jpayne@69: is not set to 1.
jpayne@69: 
jpayne@69: The following options are defined by this function:
jpayne@69: 
jpayne@69: =over
jpayne@69: 
jpayne@69: =item -appendlog APPEND_FLAG
jpayne@69: 
jpayne@69: Passing '1' to this argument turns on log file appending.
jpayne@69: 
jpayne@69: =item -debug DEBUG_LEVEL
jpayne@69: 
jpayne@69: Set debugging to DEBUG_LEVEL.
jpayne@69: 
jpayne@69: =item -logfile LOG_FILE_NAME
jpayne@69: 
jpayne@69: Set the default TIGR Foundation log file to LOG_FILE_NAME.
jpayne@69: 
jpayne@69: =item -version, -V
jpayne@69: 
jpayne@69: Print version information and exit.
jpayne@69: 
jpayne@69: =item -help, -h
jpayne@69: 
jpayne@69: Print help information and exit.
jpayne@69: 
jpayne@69: =item -depend
jpayne@69: 
jpayne@69: Print dependency information and exit.
jpayne@69: 
jpayne@69: =back
jpayne@69: 
jpayne@69: Regular C<GetOptions()> may still be used, however the C<TIGR_GetOptions()>
jpayne@69: function eliminates some of the confusing issues with setting log files
jpayne@69: and debug levels.  B<The options defined by C<TIGR_GetOptions()> cannot be
jpayne@69: overridden or recorded>.  To get the log file and debug level after parsing
jpayne@69: the command line, use C<getLogFile()> and C<getDebugLevel()>.  C<GetOptions()>
jpayne@69: default variables, ie. those of the form C<$opt_I<optionname>>, are not
jpayne@69: supported.  This function will return 1 on success.
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 
jpayne@69:    sub TIGR_GetOptions(@) {
jpayne@69:       my $self = shift;
jpayne@69:       my @user_options = @_;
jpayne@69: 
jpayne@69:       my $appendlog_var = undef;
jpayne@69:       my $logfile_var = undef;
jpayne@69:       my $debug_var = undef;
jpayne@69:       my $version_var = undef;
jpayne@69:       my $help_var = undef;
jpayne@69:       my $depend_var = undef;
jpayne@69: 
jpayne@69:       # these foundation options support the defaults
jpayne@69:       my @foundation_options = (
jpayne@69:          "appendlog=i" => \$appendlog_var,
jpayne@69:          "logfile=s" => \$logfile_var,
jpayne@69:          "debug=i" => \$debug_var,
jpayne@69:          "version|V" => \$version_var,
jpayne@69:          "help|h" => \$help_var,
jpayne@69:          "depend" => \$depend_var
jpayne@69:       );
jpayne@69: 
jpayne@69:       Getopt::Long::Configure('no_ignore_case');
jpayne@69:       my $getopt_code = eval 'GetOptions (@user_options, @foundation_options)';
jpayne@69: 
jpayne@69:       if ((defined $help_var) && ($help_var =~ /^(.*)$/))  {
jpayne@69:          $self->printHelpInfoAndExit();
jpayne@69:       }
jpayne@69: 
jpayne@69:       if ((defined $version_var) && ($version_var =~ /^(.*)$/)) {
jpayne@69:          $self->printVersionInfoAndExit();
jpayne@69:       }
jpayne@69: 
jpayne@69:       if ((defined $depend_var) && ($depend_var =~ /^(.*)$/)) {
jpayne@69:          $self->printDependInfoAndExit();
jpayne@69:       }
jpayne@69: 
jpayne@69:       if ((defined $appendlog_var) && ($appendlog_var =~ /^(.*)$/)) {
jpayne@69: 	 $appendlog_var = $1;
jpayne@69:          $self->logAppend($appendlog_var);
jpayne@69:       }
jpayne@69: 
jpayne@69:       if ((defined $logfile_var) && ($logfile_var =~ /^(.*)$/))  {
jpayne@69: 	 $logfile_var = $1;
jpayne@69:          $self->setLogFile($logfile_var);
jpayne@69:       }
jpayne@69: 
jpayne@69:       if ((defined $debug_var) && ($debug_var =~ /^(.*)$/)) {
jpayne@69: 	 $debug_var = $1;
jpayne@69:          $self->setDebugLevel($debug_var);
jpayne@69:       }
jpayne@69: 
jpayne@69:       # remove old log files, if necessary
jpayne@69:       for (
jpayne@69:            my $file_control_var = 0;
jpayne@69:            $file_control_var <= $#{$self->{log_files}};
jpayne@69:            $file_control_var++
jpayne@69:           ) {
jpayne@69:           $self->cleanLogFILES();
jpayne@69:           push(@{$self->{log_files}}, shift @{$self->{log_files}});
jpayne@69:       }
jpayne@69:       return $getopt_code;
jpayne@69:    }
jpayne@69: 
jpayne@69:    DESTROY {
jpayne@69:       my $self = shift;
jpayne@69:       $self->{finish_time} = time;
jpayne@69:       my $time_difference = $self->{finish_time} - $self->{start_time};
jpayne@69:       my $num_days = int($time_difference / 86400); # there are 86400 sec/day
jpayne@69:       $time_difference -= $num_days * 86400;
jpayne@69:       my $num_hours = int($time_difference / 3600); # there are 3600 sec/hour
jpayne@69:       $time_difference -= $num_hours * 3600;
jpayne@69:       my $num_min = int($time_difference / 60); # there are 60 sec/hour
jpayne@69:       $time_difference -= $num_min * 60;
jpayne@69:       my $num_sec = $time_difference; # the left overs are seconds
jpayne@69:       my $time_str = sprintf "%03d-%02d:%02d:%02d", $num_days, $num_hours,
jpayne@69:          $num_min, $num_sec;
jpayne@69:       $self->logLocal("FINISH: " . $self->getProgramInfo('name') .
jpayne@69:          ", elapsed ".$time_str ,0);
jpayne@69:    }
jpayne@69: }
jpayne@69: 
jpayne@69: =back
jpayne@69: 
jpayne@69: =head1 USAGE
jpayne@69: 
jpayne@69: To use this module, load the C<TIGR::Foundation> package
jpayne@69: via the C<use> function.  Then, create a new instance of the
jpayne@69: object via the C<new()> method, as shown below.  If applicable,
jpayne@69: C<START> and C<FINISH> log messages are printed when the object
jpayne@69: is created and destroyed, respectively.  It is advisable to 
jpayne@69: keep the instance of the object in scope for the whole program
jpayne@69: to achieve maximum functionality.
jpayne@69: 
jpayne@69: An example script using this module follows:
jpayne@69: 
jpayne@69:    use strict;
jpayne@69:    use TIGR::Foundation;
jpayne@69: 
jpayne@69:    my $tfobject = new TIGR::Foundation;
jpayne@69: 
jpayne@69:    MAIN: 
jpayne@69:    {
jpayne@69:       # The following dependencies are not used in
jpayne@69:       # this script, but are provided as an example.
jpayne@69: 
jpayne@69:       my @DEPEND = ("/usr/bin/tee", "/sbin/stty");
jpayne@69: 
jpayne@69:       # The user defined $VERSION variable is usable by Perl.
jpayne@69:       # The auto defined $REVISION variable stores the RCS/CVS revision
jpayne@69:       # The user defined $VERSION_STRING reports both.
jpayne@69: 
jpayne@69:       my $VERSION = '1.0';
jpayne@69:       my $REVISION = (qw$Revision: 1.1.1.1 $)[-1];
jpayne@69:       my $VERSION_STRING = "$VERSION (Build $REVISION)";
jpayne@69: 
jpayne@69:       my $HELP_INFO = "This is my help\n";
jpayne@69: 
jpayne@69:       # All of the necessary information must be passed
jpayne@69:       # to the foundation object instance, as below.
jpayne@69: 
jpayne@69:       $tfobject->addDependInfo(@DEPEND);
jpayne@69:       $tfobject->setVersionInfo($VERSION_STRING);
jpayne@69:       $tfobject->setHelpInfo($HELP_INFO);
jpayne@69: 
jpayne@69:       my $input_file;
jpayne@69:       my $output_file;
jpayne@69: 
jpayne@69:       $tfobject->TIGR_GetOptions("input=s" => \$input_file,
jpayne@69:                                  "output=s" => \$output_file);
jpayne@69: 
jpayne@69:       # GetOptions(), and subsequently TIGR_GetOptions(), leaves
jpayne@69:       # the variables unchanged if no corresponding command line
jpayne@69:       # arguments are parsed.  The passed variables are checked below.
jpayne@69: 
jpayne@69:       if (defined $input_file) {
jpayne@69: 
jpayne@69:          # The log message is written only if debugging is turned on.
jpayne@69:          # By default, debugging is off.  To turn on debugging, use the
jpayne@69:          # '-debug DEBUG_LEVEL' option on the command line.
jpayne@69:          # In this example, '-debug 1' would set debugging to level 1
jpayne@69:          # and report these log messages.
jpayne@69: 
jpayne@69:          $tfobject->logLocal("My input file is $input_file", 1);
jpayne@69:       }
jpayne@69: 
jpayne@69:       print "Hello world", "\n";
jpayne@69: 
jpayne@69:       # This case is similar to the previous one above...
jpayne@69:       if (defined $output_file) {
jpayne@69:          $tfobject->logLocal("My output file is $output_file.", 1);
jpayne@69:       }
jpayne@69:    }
jpayne@69: 
jpayne@69: =cut
jpayne@69: 
jpayne@69: 1; 
jpayne@69: 
jpayne@69: 
jpayne@69: 
jpayne@69: