Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/opt/mummer-3.23/scripts/Foundation.pm @ 69:33d812a61356

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
planemo upload commit 2e9511a184a1ca667c7be0c6321a36dc4e3d116d
author jpayne
date Tue, 18 Mar 2025 17:55:14 -0400
parents
children
rev   line source
jpayne@69 1 package TIGR::Foundation;
jpayne@69 2 {
jpayne@69 3
jpayne@69 4 =head1 NAME
jpayne@69 5
jpayne@69 6 TIGR::Foundation - TIGR Foundation object
jpayne@69 7
jpayne@69 8 =head1 SYNOPSIS
jpayne@69 9
jpayne@69 10 use TIGR::Foundation;
jpayne@69 11 my $obj_instance = new TIGR::Foundation;
jpayne@69 12
jpayne@69 13 =head1 DESCRIPTION
jpayne@69 14
jpayne@69 15 This module defines a structure for Perl programs to utilize
jpayne@69 16 logging, version reporting, and dependency checking in a simple way.
jpayne@69 17
jpayne@69 18 =cut
jpayne@69 19
jpayne@69 20 BEGIN {
jpayne@69 21 require 5.006_00; # error if using Perl < v5.6.0
jpayne@69 22 }
jpayne@69 23
jpayne@69 24 use strict;
jpayne@69 25 use Cwd;
jpayne@69 26 use Cwd 'chdir';
jpayne@69 27 use Cwd 'abs_path';
jpayne@69 28 use File::Basename;
jpayne@69 29 use Getopt::Long;
jpayne@69 30 use IO::Handle;
jpayne@69 31 use POSIX qw(strftime);
jpayne@69 32 use Sys::Hostname;
jpayne@69 33 use English;
jpayne@69 34
jpayne@69 35 require Exporter;
jpayne@69 36
jpayne@69 37 our @ISA;
jpayne@69 38 our @EXPORT;
jpayne@69 39 @ISA = ('Exporter');
jpayne@69 40 @EXPORT = qw(
jpayne@69 41 isReadableFile
jpayne@69 42 isWritableFile
jpayne@69 43 isExecutableFile
jpayne@69 44 isCreatableFile
jpayne@69 45 isReadableDir
jpayne@69 46 isWritableDir
jpayne@69 47 isCreatableDir
jpayne@69 48 isCreatablePath
jpayne@69 49
jpayne@69 50 getISODate
jpayne@69 51 getSybaseDate
jpayne@69 52 getMySQLDate
jpayne@69 53 getFilelabelDate
jpayne@69 54 getLogfileDate
jpayne@69 55 );
jpayne@69 56
jpayne@69 57 ## internal variables and identifiers
jpayne@69 58 our $REVISION = (qw$Revision: 1.1.1.1 $)[-1];
jpayne@69 59 our $VERSION = '1.1';
jpayne@69 60 our $VERSION_STRING = "$VERSION (Build $REVISION)";
jpayne@69 61 our @DEPEND = (); # there are no dependencies
jpayne@69 62
jpayne@69 63
jpayne@69 64 ## prototypes
jpayne@69 65
jpayne@69 66 # Functional Class : general
jpayne@69 67 sub new();
jpayne@69 68 sub getProgramInfo($);
jpayne@69 69 sub runCommand($);
jpayne@69 70
jpayne@69 71 # Functional Class : depend
jpayne@69 72 sub printDependInfo();
jpayne@69 73 sub printDependInfoAndExit();
jpayne@69 74 sub addDependInfo(@);
jpayne@69 75
jpayne@69 76 # Functional Class : version
jpayne@69 77 sub getVersionInfo();
jpayne@69 78 sub printVersionInfo();
jpayne@69 79 sub printVersionInfoAndExit();
jpayne@69 80 sub setVersionInfo($);
jpayne@69 81
jpayne@69 82 # Functional Class : help
jpayne@69 83 sub printHelpInfo();
jpayne@69 84 sub printHelpInfoAndExit();
jpayne@69 85 sub setHelpInfo($);
jpayne@69 86
jpayne@69 87 # Functional Class : usage
jpayne@69 88 sub printUsageInfo();
jpayne@69 89 sub printUsageInfoAndExit();
jpayne@69 90 sub setUsageInfo($);
jpayne@69 91
jpayne@69 92 # Functional Class : files
jpayne@69 93 sub isReadableFile($);
jpayne@69 94 sub isExecutableFile($);
jpayne@69 95 sub isWritableFile($);
jpayne@69 96 sub isCreatableFile($);
jpayne@69 97 sub isReadableDir($);
jpayne@69 98 sub isWritableDir($);
jpayne@69 99 sub isCreatableDir($);
jpayne@69 100 sub isCreatablePath($);
jpayne@69 101
jpayne@69 102 # Functional Class : date
jpayne@69 103 sub getISODate(;@);
jpayne@69 104 sub getSybaseDate(;@);
jpayne@69 105 sub getMySQLDate(;@);
jpayne@69 106 sub getFilelabelDate(;@);
jpayne@69 107 sub getLogfileDate(;@);
jpayne@69 108
jpayne@69 109 # Functional Class : logging
jpayne@69 110 sub setDebugLevel($;$);
jpayne@69 111 sub getDebugLevel();
jpayne@69 112 sub setLogFile($;$);
jpayne@69 113 sub getLogFile();
jpayne@69 114 sub getErrorFile();
jpayne@69 115 sub printDependInfo();
jpayne@69 116 sub invalidateLogFILES();
jpayne@69 117 sub cleanLogFILES();
jpayne@69 118 sub closeLogERROR();
jpayne@69 119 sub closeLogMSG();
jpayne@69 120 sub openLogERROR();
jpayne@69 121 sub openLogMSG();
jpayne@69 122 sub logAppend($;$);
jpayne@69 123 sub debugPush();
jpayne@69 124 sub debugPop();
jpayne@69 125 sub logLocal($$);
jpayne@69 126 sub logError($;$);
jpayne@69 127 sub bail($;$);
jpayne@69 128
jpayne@69 129 # Functional Class : modified methods
jpayne@69 130 sub TIGR_GetOptions(@);
jpayne@69 131
jpayne@69 132 ## Implementation
jpayne@69 133
jpayne@69 134
jpayne@69 135 # Functional Class : general
jpayne@69 136
jpayne@69 137 =over
jpayne@69 138
jpayne@69 139 =item $obj_instance = new TIGR::Foundation;
jpayne@69 140
jpayne@69 141 This function creates a new instance of the TIGR::Foundation
jpayne@69 142 object. A reference pointing to the object is returned on success. Otherwise,
jpayne@69 143 this method returns undefined.
jpayne@69 144
jpayne@69 145 =cut
jpayne@69 146
jpayne@69 147
jpayne@69 148 sub new() {
jpayne@69 149
jpayne@69 150 my $self = {};
jpayne@69 151 my $pkg = shift;
jpayne@69 152 my $user_name = getpwuid($<);
jpayne@69 153 my $host_name = hostname();
jpayne@69 154
jpayne@69 155 # create the object
jpayne@69 156 bless $self, $pkg;
jpayne@69 157
jpayne@69 158 ## Instance variables and identifiers, by functional class
jpayne@69 159
jpayne@69 160 # Functional Class : general
jpayne@69 161 my $pname = basename($0, ()); # extract the script name
jpayne@69 162
jpayne@69 163 if((defined ($pname)) && ($pname =~ /^(.*)$/)) {
jpayne@69 164 $pname = $1;
jpayne@69 165 $self->{program_name} = $pname ;
jpayne@69 166 }
jpayne@69 167
jpayne@69 168 if ($self->{program_name} =~ /^-$/) { # check if '-' is the input
jpayne@69 169 $self->{program_name} = "STDIN";
jpayne@69 170 }
jpayne@69 171
jpayne@69 172 my $pcommand = join (' ', @ARGV);
jpayne@69 173
jpayne@69 174 if((defined ($pcommand)) && ($pcommand =~ /^(.*)$/)) {
jpayne@69 175 $pcommand = $1;
jpayne@69 176 $self->{invocation} = $pcommand ;
jpayne@69 177 }
jpayne@69 178
jpayne@69 179 # The following four variables are to contain information specified by
jpayne@69 180 # the 'host' program; there are methods of setting and retrieving each
jpayne@69 181
jpayne@69 182 # Functional Class : depend
jpayne@69 183 @{$self->{depend_info}} = ();
jpayne@69 184
jpayne@69 185 # Functional Class : version
jpayne@69 186 $self->{version_info} = undef;
jpayne@69 187
jpayne@69 188 # Functional Class : help
jpayne@69 189 $self->{help_info} = undef;
jpayne@69 190
jpayne@69 191 # Functional Class : usage
jpayne@69 192 $self->{usage_info} = undef;
jpayne@69 193
jpayne@69 194 # Functional Class : logging
jpayne@69 195 $self->{debug_level} = undef; # default debug is not defined
jpayne@69 196 @{$self->{debug_store}} = (); # the backup debug level stack
jpayne@69 197 @{$self->{debug_queue}} = (); # queue used by MSG routine
jpayne@69 198 @{$self->{error_queue}} = (); # queue used by ERROR routine
jpayne@69 199 $self->{max_debug_queue_size} = 100; # maximum size for queue before
jpayne@69 200 # log entries are expired
jpayne@69 201 @{$self->{log_files}} = # these log files are consulted
jpayne@69 202 ("$self->{program_name}.log", # on file write error and are
jpayne@69 203 "/tmp/$self->{program_name}.$$.log"); # modified by setLogFile
jpayne@69 204 $self->{msg_file_open_flag} = 0; # flag to check logLocal file
jpayne@69 205 $self->{error_file_open_flag} = 0; # flag to check logError file
jpayne@69 206 $self->{msg_file_used} = 0; # flag to indicate if log file
jpayne@69 207 $self->{error_file_used} = 0; # has been written to
jpayne@69 208 $self->{msg_append_flag} = 0; # by default logs are truncated
jpayne@69 209 $self->{error_append_flag} = 0; # by default logs are truncated
jpayne@69 210 $self->{log_append_setting} = 0; # (truncate == 0)
jpayne@69 211 $self->{static_log_file} = undef; # user defined log file
jpayne@69 212 $self->{start_time} = undef; # program start time
jpayne@69 213 $self->{finish_time} = undef; # program stop time
jpayne@69 214
jpayne@69 215 # Log program invocation
jpayne@69 216 $self->logLocal("START: " . "Username:$user_name, ".
jpayne@69 217 "Hostname: $host_name ". $self->getProgramInfo('name') .
jpayne@69 218 " " . $self->getProgramInfo('invocation'), 0);
jpayne@69 219 $self->{start_time} = time;
jpayne@69 220
jpayne@69 221 return $self;
jpayne@69 222 }
jpayne@69 223
jpayne@69 224
jpayne@69 225
jpayne@69 226 =item $value = $obj_instance->getProgramInfo($field_type);
jpayne@69 227
jpayne@69 228 This function returns field values for specified field types describing
jpayne@69 229 attributes of the program. The C<$field_type> parameter must be a listed
jpayne@69 230 attribute: C<name>, C<invocation>, C<env_path>, C<abs_path>.
jpayne@69 231 The C<name> field specifies the bare name of the executable. The
jpayne@69 232 C<invocation> field specifies the command line arguments passed to the
jpayne@69 233 executable. The C<env_path> value returns the environment path to the
jpayne@69 234 working directory. The C<abs_path> value specifies the absolute path to the
jpayne@69 235 working directory. If C<env_path> is found to be inconsistent, then that
jpayne@69 236 value will return the C<abs_path> value. If an invalid C<$field_type> is
jpayne@69 237 passed, the function returns undefined.
jpayne@69 238
jpayne@69 239 =cut
jpayne@69 240
jpayne@69 241
jpayne@69 242 sub getProgramInfo($) {
jpayne@69 243 my $self = shift;
jpayne@69 244 my $field_type = shift;
jpayne@69 245 my $return_value = undef;
jpayne@69 246 if (defined $field_type) {
jpayne@69 247 $field_type =~ /^name$/ && do {
jpayne@69 248 $return_value = $self->{program_name};
jpayne@69 249 };
jpayne@69 250 $field_type =~ /^invocation$/ && do {
jpayne@69 251 $return_value = $self->{invocation};
jpayne@69 252 };
jpayne@69 253 $field_type =~ /^env_path$/ && do {
jpayne@69 254 my $return_value = "";
jpayne@69 255 if (
jpayne@69 256 (defined $ENV{'PWD'}) &&
jpayne@69 257 (abs_path($ENV{'PWD'}) eq abs_path(".")) &&
jpayne@69 258 ($ENV{'PWD'} =~ /^(.*)$/)
jpayne@69 259 ) {
jpayne@69 260 $ENV{'PWD'} = $1;
jpayne@69 261 $return_value = $ENV{'PWD'};
jpayne@69 262 }
jpayne@69 263 else {
jpayne@69 264 my $tmp_val = abs_path(".");
jpayne@69 265
jpayne@69 266 if((defined ($tmp_val)) && ($tmp_val =~ /^(.*)$/)) {
jpayne@69 267 $tmp_val = $1;
jpayne@69 268 $return_value = $tmp_val;
jpayne@69 269 }
jpayne@69 270 }
jpayne@69 271 return $return_value;
jpayne@69 272 };
jpayne@69 273
jpayne@69 274 $field_type =~ /^abs_path$/ && do {
jpayne@69 275 my $tmp_val = abs_path(".");
jpayne@69 276
jpayne@69 277 if((defined ($tmp_val)) && ($tmp_val =~ /^(.*)$/)) {
jpayne@69 278 $tmp_val = $1;
jpayne@69 279 $return_value = $tmp_val;
jpayne@69 280 }
jpayne@69 281 };
jpayne@69 282 }
jpayne@69 283 return $return_value;
jpayne@69 284 }
jpayne@69 285
jpayne@69 286 =item $exit_code = $obj_instance->runCommand($command_str);
jpayne@69 287
jpayne@69 288 This function passes the argument C<$command_str> to /bin/sh
jpayne@69 289 for processing. The return value is the exit code of the
jpayne@69 290 C<$command_str>. If the exit code is not defined, then either the signal or
jpayne@69 291 core dump value of the execution is returned, whichever is applicable. Perl
jpayne@69 292 variables C<$?> and C<$!> are set accordingly. If C<$command_str> is not
jpayne@69 293 defined, this function returns undefined. Log messages are recorded at log
jpayne@69 294 level 4 to indicate the type of exit status and the corresponding code.
jpayne@69 295 Invalid commands return -1.
jpayne@69 296
jpayne@69 297 =cut
jpayne@69 298
jpayne@69 299
jpayne@69 300 sub runCommand($) {
jpayne@69 301 my $self = shift;
jpayne@69 302 my $command_str = shift;
jpayne@69 303 my $exit_code = undef;
jpayne@69 304 my $signal_num = undef;
jpayne@69 305 my $dumped_core = undef;
jpayne@69 306 my $invalid_command = undef;
jpayne@69 307 my $return_value = undef;
jpayne@69 308 my @info_arr = getpwuid($<);
jpayne@69 309 my $len = @info_arr;
jpayne@69 310 my $home_dir = $info_arr[7];
jpayne@69 311 my $current_dir = $self->getProgramInfo("abs_path");
jpayne@69 312
jpayne@69 313 if((defined ($ENV{PATH})) && ($ENV{PATH} =~ /^(.*)$/)) {#taint checking
jpayne@69 314 $ENV{PATH} = $1;
jpayne@69 315 my $path_var = $ENV{PATH};
jpayne@69 316 my @paths = split /:/, $path_var;
jpayne@69 317 my $pathval = undef;
jpayne@69 318 my $i = 0;
jpayne@69 319 my $paths_len = @paths;
jpayne@69 320
jpayne@69 321 for ($i = 0; $i < $paths_len ; $i++) {
jpayne@69 322 #substituting ~ with the home pathname.
jpayne@69 323 $pathval = $paths[$i];
jpayne@69 324 $pathval =~ s/^~$/$home_dir/g;
jpayne@69 325 my $home_root = $home_dir."\/";
jpayne@69 326 $pathval =~ s/^~\//$home_root/g;
jpayne@69 327
jpayne@69 328 #substituting . with the current pathname.
jpayne@69 329 $pathval =~ s/^\.$/$current_dir/g;
jpayne@69 330 my $current_root = $current_dir."\/";
jpayne@69 331 $pathval =~ s/^\.\//$current_root/g;
jpayne@69 332 $paths[$i] = $pathval;
jpayne@69 333 }
jpayne@69 334
jpayne@69 335 $ENV{PATH} = join(":", @paths);
jpayne@69 336 }
jpayne@69 337
jpayne@69 338 if((defined ($command_str)) && ($command_str =~ /^(.*)$/)) {#taint
jpayne@69 339 #checking
jpayne@69 340 $command_str = $1;
jpayne@69 341 system($command_str);
jpayne@69 342 $exit_code = $? >> 8;
jpayne@69 343 $signal_num = $? & 127;
jpayne@69 344 $dumped_core = $? & 128;
jpayne@69 345
jpayne@69 346 if ($? == -1) {
jpayne@69 347 $invalid_command = -1;
jpayne@69 348 }
jpayne@69 349
jpayne@69 350 if (
jpayne@69 351 (!defined $invalid_command) &&
jpayne@69 352 ($exit_code == 0) &&
jpayne@69 353 ($signal_num == 0) &&
jpayne@69 354 ($dumped_core != 0)
jpayne@69 355 ) {
jpayne@69 356
jpayne@69 357 $self->logLocal("Command '" . $command_str . "' core dumped", 4);
jpayne@69 358 $return_value = $dumped_core;
jpayne@69 359 }
jpayne@69 360 elsif (
jpayne@69 361 (!defined $invalid_command) &&
jpayne@69 362 ($exit_code == 0) &&
jpayne@69 363 ($signal_num != 0)
jpayne@69 364 ) {
jpayne@69 365
jpayne@69 366 $self->logLocal("Command '" . $command_str .
jpayne@69 367 "' exited on signal " . $signal_num, 4);
jpayne@69 368 $return_value = $signal_num;
jpayne@69 369 }
jpayne@69 370 elsif ((!defined $invalid_command)) {
jpayne@69 371
jpayne@69 372 $self->logLocal("Command '" . $command_str .
jpayne@69 373 "' exited with exit code " . $exit_code, 4);
jpayne@69 374 $return_value = $exit_code;
jpayne@69 375 }
jpayne@69 376 else {
jpayne@69 377
jpayne@69 378 $self->logLocal("Command '" . $command_str .
jpayne@69 379 "' exited with invalid code " . $?, 4);
jpayne@69 380 $return_value = $?;
jpayne@69 381 }
jpayne@69 382 }
jpayne@69 383 return $return_value;
jpayne@69 384 }
jpayne@69 385
jpayne@69 386
jpayne@69 387 # Functional Class : depend
jpayne@69 388
jpayne@69 389 =item $obj_instance->printDependInfo();
jpayne@69 390
jpayne@69 391 The C<printDependInfo()> function prints the dependency list created by
jpayne@69 392 C<addDependInfo()>. One item is printed per line.
jpayne@69 393
jpayne@69 394 =cut
jpayne@69 395
jpayne@69 396
jpayne@69 397 sub printDependInfo() {
jpayne@69 398 my $self = shift;
jpayne@69 399 foreach my $dependent (@{$self->{depend_info}}) {
jpayne@69 400 print STDERR $dependent, "\n";
jpayne@69 401 }
jpayne@69 402 }
jpayne@69 403
jpayne@69 404
jpayne@69 405 =item $obj_instance->printDependInfoAndExit();
jpayne@69 406
jpayne@69 407 The C<printDependInfoAndExit()> function prints the dependency list created by
jpayne@69 408 C<addDependInfo()>. One item is printed per line. The function exits with
jpayne@69 409 exit code 0.
jpayne@69 410
jpayne@69 411 =cut
jpayne@69 412
jpayne@69 413
jpayne@69 414 sub printDependInfoAndExit() {
jpayne@69 415 my $self = shift;
jpayne@69 416 $self->printDependInfo();
jpayne@69 417 exit 0;
jpayne@69 418 }
jpayne@69 419
jpayne@69 420
jpayne@69 421 =item $obj_instance->addDependInfo(@depend_list);
jpayne@69 422
jpayne@69 423 The C<addDependInfo()> function adds C<@depend_list> information
jpayne@69 424 to the dependency list. If C<@depend_list> is empty, the internal
jpayne@69 425 dependency list is emptied. Contents of C<@depend_list> are not checked
jpayne@69 426 for validity (eg. they can be composed entirely of white space or
jpayne@69 427 multiple files per record). The first undefined record in C<@depend_list>
jpayne@69 428 halts reading in of dependency information.
jpayne@69 429
jpayne@69 430 =cut
jpayne@69 431
jpayne@69 432
jpayne@69 433 sub addDependInfo(@) {
jpayne@69 434 my $self = shift;
jpayne@69 435 my $num_elts = 0;
jpayne@69 436 while (my $data_elt = shift @_) {
jpayne@69 437 push (@{$self->{depend_info}}, $data_elt);
jpayne@69 438 $num_elts++;
jpayne@69 439 }
jpayne@69 440 if ($num_elts == 0) {
jpayne@69 441 @{$self->{depend_info}} = ();
jpayne@69 442 }
jpayne@69 443 }
jpayne@69 444
jpayne@69 445
jpayne@69 446 # Functional Class : version
jpayne@69 447
jpayne@69 448 =item $version_string = $obj_instance->getVersionInfo();
jpayne@69 449
jpayne@69 450 The C<getVersionInfo()> function returns the version information set by the
jpayne@69 451 C<setVersionInfo()> function.
jpayne@69 452
jpayne@69 453 =cut
jpayne@69 454
jpayne@69 455
jpayne@69 456 sub getVersionInfo() {
jpayne@69 457 my $self = shift;
jpayne@69 458 return $self->{version_info};
jpayne@69 459 }
jpayne@69 460
jpayne@69 461
jpayne@69 462 =item $obj_instance->printVersionInfo();
jpayne@69 463
jpayne@69 464 The C<printVersionInfo()> function prints the version information set by the
jpayne@69 465 C<setVersionInfo()> function. If there is no defined version information,
jpayne@69 466 a message is returned notifying the user.
jpayne@69 467
jpayne@69 468 =cut
jpayne@69 469
jpayne@69 470
jpayne@69 471 sub printVersionInfo() {
jpayne@69 472 my $self = shift;
jpayne@69 473 if (defined $self->getVersionInfo()) {
jpayne@69 474 print STDERR $self->getProgramInfo('name'),
jpayne@69 475 " ", $self->getVersionInfo(), "\n";
jpayne@69 476 }
jpayne@69 477 else {
jpayne@69 478 print STDERR $self->getProgramInfo('name'),
jpayne@69 479 " has no defined version information\n";
jpayne@69 480 }
jpayne@69 481 }
jpayne@69 482
jpayne@69 483
jpayne@69 484 =item $obj_instance->printVersionInfoAndExit();
jpayne@69 485
jpayne@69 486 The C<printVersionInfoAndExit()> function prints version info set by the
jpayne@69 487 C<setVersionInfo()> function. If there is no defined version information,
jpayne@69 488 a message is printed notifying the user. This function calls exit with
jpayne@69 489 exit code 0.
jpayne@69 490
jpayne@69 491 =cut
jpayne@69 492
jpayne@69 493
jpayne@69 494 sub printVersionInfoAndExit() {
jpayne@69 495 my $self = shift;
jpayne@69 496 $self->printVersionInfo();
jpayne@69 497 exit 0;
jpayne@69 498 }
jpayne@69 499
jpayne@69 500
jpayne@69 501 =item $obj_instance->setVersionInfo($version_string);
jpayne@69 502
jpayne@69 503 The C<setVersionInfo()> function sets the version information to be reported
jpayne@69 504 by C<getVersionInfo()>. If C<$version_string> is empty, invalid, or
jpayne@69 505 undefined, the stored version information will be undefined.
jpayne@69 506
jpayne@69 507 =cut
jpayne@69 508
jpayne@69 509
jpayne@69 510 sub setVersionInfo($) {
jpayne@69 511 my $self = shift;
jpayne@69 512 my $v_info = shift;
jpayne@69 513 if (
jpayne@69 514 (defined $v_info) &&
jpayne@69 515 ($v_info =~ /\S/) &&
jpayne@69 516 ((ref $v_info) eq "")
jpayne@69 517 ) {
jpayne@69 518 $self->{version_info} = $v_info;
jpayne@69 519 }
jpayne@69 520 else {
jpayne@69 521 $self->{version_info} = undef;
jpayne@69 522 }
jpayne@69 523 }
jpayne@69 524
jpayne@69 525
jpayne@69 526 # Functional Class : help
jpayne@69 527
jpayne@69 528 =item $obj_instance->printHelpInfo();
jpayne@69 529
jpayne@69 530 The C<printHelpInfo()> function prints the help information passed by the
jpayne@69 531 C<setHelpInfo()> function.
jpayne@69 532
jpayne@69 533 =cut
jpayne@69 534
jpayne@69 535
jpayne@69 536 sub printHelpInfo() {
jpayne@69 537 my $self = shift;
jpayne@69 538 if (defined $self->{help_info}) {
jpayne@69 539 print STDERR $self->{help_info};
jpayne@69 540 }
jpayne@69 541 else {
jpayne@69 542 print STDERR "No help information defined.\n";
jpayne@69 543 }
jpayne@69 544 }
jpayne@69 545
jpayne@69 546
jpayne@69 547 =item $obj_instance->printHelpInfoAndExit();
jpayne@69 548
jpayne@69 549 The C<printHelpInfoAndExit()> function prints the help info passed by the
jpayne@69 550 C<setHelpInfo()> function. This function exits with exit code 0.
jpayne@69 551
jpayne@69 552 =cut
jpayne@69 553
jpayne@69 554
jpayne@69 555 sub printHelpInfoAndExit() {
jpayne@69 556 my $self = shift;
jpayne@69 557 $self->printHelpInfo();
jpayne@69 558 exit 0;
jpayne@69 559 }
jpayne@69 560
jpayne@69 561
jpayne@69 562 =item $obj_instance->setHelpInfo($help_string);
jpayne@69 563
jpayne@69 564 The C<setHelpInfo()> function sets the help information via C<$help_string>.
jpayne@69 565 If C<$help_string> is undefined, invalid, or empty, the help information
jpayne@69 566 is undefined.
jpayne@69 567
jpayne@69 568 =cut
jpayne@69 569
jpayne@69 570
jpayne@69 571 sub setHelpInfo($) {
jpayne@69 572 my $self = shift;
jpayne@69 573 my $help_string = shift;
jpayne@69 574 if (
jpayne@69 575 (defined $help_string) &&
jpayne@69 576 ($help_string =~ /\S/) &&
jpayne@69 577 ((ref $help_string) eq "")
jpayne@69 578 ) {
jpayne@69 579 chomp($help_string);#removing a new line if it is there.
jpayne@69 580 $self->{help_info} = $help_string."\n";#adding a new line to help.
jpayne@69 581 }
jpayne@69 582 else {
jpayne@69 583 $self->{help_info} = undef;
jpayne@69 584 }
jpayne@69 585 }
jpayne@69 586
jpayne@69 587
jpayne@69 588 # Functional Class : usage
jpayne@69 589
jpayne@69 590 =item $obj_instance->printUsageInfo();
jpayne@69 591
jpayne@69 592 The C<printUsageInfo()> function prints the usage information reported by the
jpayne@69 593 C<setUsageInfo()> function. If no usage information is defined, but help
jpayne@69 594 information is defined, help information will be printed.
jpayne@69 595
jpayne@69 596 =cut
jpayne@69 597
jpayne@69 598
jpayne@69 599 sub printUsageInfo() {
jpayne@69 600
jpayne@69 601 my $self = shift;
jpayne@69 602 if (defined $self->{usage_info}) {
jpayne@69 603 print STDERR $self->{usage_info};
jpayne@69 604 }
jpayne@69 605 elsif (defined $self->{help_info}) {
jpayne@69 606 print STDERR $self->{help_info};
jpayne@69 607 }
jpayne@69 608 else {
jpayne@69 609 print STDERR "No usage information defined.\n";
jpayne@69 610 }
jpayne@69 611 }
jpayne@69 612
jpayne@69 613
jpayne@69 614 =item $obj_instance->printUsageInfoAndExit();
jpayne@69 615
jpayne@69 616 The C<printUsageInfoAndExit()> function prints the usage information the
jpayne@69 617 reported by the C<setUsageInfo()> function and exits with status 1.
jpayne@69 618
jpayne@69 619 =cut
jpayne@69 620
jpayne@69 621
jpayne@69 622 sub printUsageInfoAndExit() {
jpayne@69 623 my $self = shift;
jpayne@69 624 $self->printUsageInfo();
jpayne@69 625 $self->bail("Incorrect command line");
jpayne@69 626 }
jpayne@69 627
jpayne@69 628
jpayne@69 629 =item $obj_instance->setUsageInfo($usage_string);
jpayne@69 630
jpayne@69 631 The C<setUsageInfo()> function sets the usage information via C<$usage_string>.
jpayne@69 632 If C<$usage_string> is undefined, invalid, or empty, the usage information
jpayne@69 633 is undefined.
jpayne@69 634
jpayne@69 635 =cut
jpayne@69 636
jpayne@69 637
jpayne@69 638 sub setUsageInfo($) {
jpayne@69 639 my $self = shift;
jpayne@69 640 my $usage_string = shift;
jpayne@69 641 if (
jpayne@69 642 (defined $usage_string) &&
jpayne@69 643 ($usage_string =~ /\S/) &&
jpayne@69 644 ((ref $usage_string) eq "")
jpayne@69 645 ) {
jpayne@69 646 chomp($usage_string); #removing a new line if it is there.
jpayne@69 647 $self->{usage_info} = $usage_string."\n";#adding a new line to usage
jpayne@69 648 }
jpayne@69 649 else {
jpayne@69 650 $self->{usage_info} = undef;
jpayne@69 651 }
jpayne@69 652 }
jpayne@69 653
jpayne@69 654
jpayne@69 655 # Functional Class : files
jpayne@69 656
jpayne@69 657 =item $valid = isReadableFile($file_name);
jpayne@69 658
jpayne@69 659 This function accepts a single scalar parameter containing a file name.
jpayne@69 660 If the file corresponding to the file name is a readable plain file or symbolic
jpayne@69 661 link, this function returns 1. Otherwise, the function returns 0. If the file
jpayne@69 662 name passed is undefined, this function returns 0 as well.
jpayne@69 663
jpayne@69 664 =cut
jpayne@69 665
jpayne@69 666
jpayne@69 667 sub isReadableFile($) {
jpayne@69 668 my $file = shift;
jpayne@69 669 if (scalar(@_) != 0) { #incase the method was invoked as an instance
jpayne@69 670 #method
jpayne@69 671 $file = shift;
jpayne@69 672 }
jpayne@69 673
jpayne@69 674 if (defined ($file) && # was a file name passed?
jpayne@69 675 ((-f $file) || (-l $file)) && # is the file a file or sym. link?
jpayne@69 676 (-r $file) # is the file readable?
jpayne@69 677 ) {
jpayne@69 678 return 1;
jpayne@69 679 }
jpayne@69 680 else {
jpayne@69 681 return 0;
jpayne@69 682 }
jpayne@69 683 }
jpayne@69 684
jpayne@69 685
jpayne@69 686 =item $valid = isExecutableFile($file_name);
jpayne@69 687
jpayne@69 688 This function accepts a single scalar parameter containing a file name.
jpayne@69 689 If the file corresponding to the file name is an executable plain file
jpayne@69 690 or symbolic link, this function returns 1. Otherwise, the function returns 0.
jpayne@69 691 If the file name passed is undefined, this function returns 0 as well.
jpayne@69 692
jpayne@69 693 =cut
jpayne@69 694
jpayne@69 695
jpayne@69 696 sub isExecutableFile($) {
jpayne@69 697 my $file = shift;
jpayne@69 698 if (scalar(@_) != 0) { # incase the method was invoked as a instance
jpayne@69 699 # method
jpayne@69 700 $file = shift;
jpayne@69 701 }
jpayne@69 702
jpayne@69 703 if (defined ($file) && # was a file name passed?
jpayne@69 704 ((-f $file) || (-l $file)) && # is the file a file or sym. link?
jpayne@69 705 (-x $file) # is the file executable?
jpayne@69 706 ) {
jpayne@69 707 return 1;
jpayne@69 708 }
jpayne@69 709 else {
jpayne@69 710 return 0;
jpayne@69 711 }
jpayne@69 712 }
jpayne@69 713
jpayne@69 714
jpayne@69 715 =item $valid = isWritableFile($file_name);
jpayne@69 716
jpayne@69 717 This function accepts a single scalar parameter containing a file name.
jpayne@69 718 If the file corresponding to the file name is a writable plain file
jpayne@69 719 or symbolic link, this function returns 1. Otherwise, the function returns 0.
jpayne@69 720 If the file name passed is undefined, this function returns 0 as well.
jpayne@69 721
jpayne@69 722 =cut
jpayne@69 723
jpayne@69 724
jpayne@69 725 sub isWritableFile($) {
jpayne@69 726 my $file = shift;
jpayne@69 727 if (scalar(@_) != 0) { # incase the method was invoked as a instance
jpayne@69 728 # method
jpayne@69 729 $file = shift;
jpayne@69 730 }
jpayne@69 731
jpayne@69 732 if (defined ($file) && # was a file name passed?
jpayne@69 733 ((-f $file) || (-l $file)) && # is the file a file or sym. link?
jpayne@69 734 (-w $file) # is the file writable?
jpayne@69 735 ) {
jpayne@69 736 return 1;
jpayne@69 737 }
jpayne@69 738 else {
jpayne@69 739 return 0;
jpayne@69 740 }
jpayne@69 741 }
jpayne@69 742
jpayne@69 743
jpayne@69 744 =item $valid = isCreatableFile($file_name);
jpayne@69 745
jpayne@69 746 This function accepts a single scalar parameter containing a file name. If
jpayne@69 747 the file corresponding to the file name is creatable this function returns 1.
jpayne@69 748 The function checks if the location of the file is writable by the effective
jpayne@69 749 user id (EUID). If the file location does not exist or the location is not
jpayne@69 750 writable, the function returns 0. If the file name passed is undefined,
jpayne@69 751 this function returns 0 as well. Note that files with suffix F</> are not
jpayne@69 752 supported under UNIX platforms, and will return 0.
jpayne@69 753
jpayne@69 754 =cut
jpayne@69 755
jpayne@69 756
jpayne@69 757 sub isCreatableFile($) {
jpayne@69 758 my $file = shift;
jpayne@69 759 if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69 760 # method
jpayne@69 761 $file = shift;
jpayne@69 762 }
jpayne@69 763
jpayne@69 764 my $return_code = 0;
jpayne@69 765
jpayne@69 766 if (
jpayne@69 767 (defined ($file)) &&
jpayne@69 768 (! -e $file) &&
jpayne@69 769 ($file !~ /\/$/)
jpayne@69 770 ) {
jpayne@69 771 my $dirname = dirname($file);
jpayne@69 772 # check the writability of the directory
jpayne@69 773 $return_code = isWritableDir($dirname);
jpayne@69 774 }
jpayne@69 775 else {
jpayne@69 776 # the file exists, it's not creatable
jpayne@69 777 $return_code = 0;
jpayne@69 778 }
jpayne@69 779 return $return_code;
jpayne@69 780 }
jpayne@69 781
jpayne@69 782
jpayne@69 783 =item $valid = isReadableDir($directory_name);
jpayne@69 784
jpayne@69 785 This function accepts a single scalar parameter containing a directory name.
jpayne@69 786 If the name corresponding to the directory is a readable, searchable directory
jpayne@69 787 entry, this function returns 1. Otherwise, the function returns 0. If the
jpayne@69 788 name passed is undefined, this function returns 0 as well.
jpayne@69 789
jpayne@69 790 =cut
jpayne@69 791
jpayne@69 792
jpayne@69 793 sub isReadableDir($) {
jpayne@69 794 my $file = shift;
jpayne@69 795 if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69 796 # method
jpayne@69 797 $file = shift;
jpayne@69 798 }
jpayne@69 799
jpayne@69 800 if (defined ($file) && # was a name passed?
jpayne@69 801 (-d $file) && # is the name a directory?
jpayne@69 802 (-r $file) && # is the directory readable?
jpayne@69 803 (-x $file) # is the directory searchable?
jpayne@69 804 ) {
jpayne@69 805 return 1;
jpayne@69 806 }
jpayne@69 807 else {
jpayne@69 808 return 0;
jpayne@69 809 }
jpayne@69 810 }
jpayne@69 811
jpayne@69 812
jpayne@69 813 =item $valid = isWritableDir($directory_name);
jpayne@69 814
jpayne@69 815 This function accepts a single scalar parameter containing a directory name.
jpayne@69 816 If the name corresponding to the directory is a writable, searchable directory
jpayne@69 817 entry, this function returns 1. Otherwise, the function returns 0. If the
jpayne@69 818 name passed is undefined, this function returns 0 as well.
jpayne@69 819
jpayne@69 820 =cut
jpayne@69 821
jpayne@69 822
jpayne@69 823 sub isWritableDir($) {
jpayne@69 824 my $file = shift;
jpayne@69 825 if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69 826 # method
jpayne@69 827 $file = shift;
jpayne@69 828 }
jpayne@69 829
jpayne@69 830 if (defined ($file) && # was a name passed?
jpayne@69 831 (-d $file) && # is the name a directory?
jpayne@69 832 (-w $file) && # is the directory writable?
jpayne@69 833 (-x $file) # is the directory searchable?
jpayne@69 834 ) {
jpayne@69 835 return 1;
jpayne@69 836 }
jpayne@69 837 else {
jpayne@69 838 return 0;
jpayne@69 839 }
jpayne@69 840 }
jpayne@69 841
jpayne@69 842
jpayne@69 843 =item $valid = isCreatableDir($directory_name);
jpayne@69 844
jpayne@69 845 This function accepts a single scalar parameter containing a directory name.
jpayne@69 846 If the name corresponding to the directory is creatable this function returns
jpayne@69 847 1. The function checks if the immediate parent of the directory is writable by
jpayne@69 848 the effective user id (EUID). If the parent directory does not exist or the
jpayne@69 849 tree is not writable, the function returns 0. If the directory name passed is
jpayne@69 850 undefined, this function returns 0 as well.
jpayne@69 851
jpayne@69 852 =cut
jpayne@69 853
jpayne@69 854
jpayne@69 855 sub isCreatableDir($) {
jpayne@69 856 my $dir = shift;
jpayne@69 857 if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69 858 # method
jpayne@69 859 $dir = shift;
jpayne@69 860 }
jpayne@69 861 my $return_code = 0;
jpayne@69 862
jpayne@69 863 if (defined ($dir)) {
jpayne@69 864 $dir =~ s/\/$//g;
jpayne@69 865 $return_code = isCreatableFile($dir);
jpayne@69 866 }
jpayne@69 867 return $return_code;
jpayne@69 868 }
jpayne@69 869
jpayne@69 870
jpayne@69 871 =item $valid = isCreatablePath($path_name);
jpayne@69 872
jpayne@69 873 This function accepts a single scalar parameter containing a path name. If
jpayne@69 874 the C<$path_name> is creatable this function returns 1. The function checks
jpayne@69 875 if the directory hierarchy of the path is creatable or writable by the
jpayne@69 876 effective user id (EUID). This function calls itself recursively until
jpayne@69 877 an existing directory node is found. If that node is writable, ie. the path
jpayne@69 878 can be created in it, then this function returns 1. Otherwise, the function
jpayne@69 879 returns 0. This function also returns zero if the C<$path_name> supplied
jpayne@69 880 is disconnected from a reachable directory tree on the file system.
jpayne@69 881 If the path already exists, this function returns 0. The C<$path_name> may
jpayne@69 882 imply either a path to a file or a directory. Path names may be relative or
jpayne@69 883 absolute paths. Any unresolvable relative paths will return 0 as well. This
jpayne@69 884 includes paths with F<..> back references to nonexistent directories.
jpayne@69 885 This function is recursive whereas C<isCreatableFile()> and
jpayne@69 886 C<isCreatableDir()> are not.
jpayne@69 887
jpayne@69 888 =cut
jpayne@69 889
jpayne@69 890
jpayne@69 891 sub isCreatablePath($) {
jpayne@69 892 my $pathname = shift;
jpayne@69 893 if (scalar(@_) != 0) { # incase the method was invoked as an instance
jpayne@69 894 # method
jpayne@69 895 $pathname = shift;
jpayne@69 896 }
jpayne@69 897 my $return_code = 0;
jpayne@69 898
jpayne@69 899 if (defined $pathname) {
jpayne@69 900 # strip trailing '/'
jpayne@69 901 $pathname =~ s/(.+)\/$/$1/g;
jpayne@69 902 my $filename = basename($pathname);
jpayne@69 903 my $dirname = dirname($pathname);
jpayne@69 904 if (
jpayne@69 905 (! -e $pathname) &&
jpayne@69 906 ($dirname ne $pathname) &&
jpayne@69 907 ($filename ne "..")
jpayne@69 908 ) {
jpayne@69 909 if (-e $dirname) {
jpayne@69 910 $return_code = isWritableDir($dirname);
jpayne@69 911 }
jpayne@69 912 else {
jpayne@69 913 $return_code = isCreatablePath($dirname);
jpayne@69 914 }
jpayne@69 915 }
jpayne@69 916 else {
jpayne@69 917 $return_code = 0;
jpayne@69 918 }
jpayne@69 919 }
jpayne@69 920 return $return_code;
jpayne@69 921 }
jpayne@69 922
jpayne@69 923
jpayne@69 924 # Functional Class : date
jpayne@69 925
jpayne@69 926 =item $date_string = getISODate($tm);
jpayne@69 927
jpayne@69 928 This function returns the ISO 8601 datetime as a string given a time
jpayne@69 929 structure as returned by the C<time> function. If no arguments
jpayne@69 930 are supplied, this function returns the current time. If incorrect
jpayne@69 931 arguments are supplied, this function returns undefined.
jpayne@69 932
jpayne@69 933 =cut
jpayne@69 934
jpayne@69 935
jpayne@69 936 sub getISODate(;@) {
jpayne@69 937 #checking if the function is invoked as an instance method.
jpayne@69 938 if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69 939 shift;
jpayne@69 940 }
jpayne@69 941 my @time_val = @_;
jpayne@69 942 my $time_str = undef;
jpayne@69 943 if (scalar(@time_val) == 0) {
jpayne@69 944 @time_val = localtime;
jpayne@69 945 }
jpayne@69 946 eval {
jpayne@69 947 $time_str = strftime "%Y-%m-%d %H:%M:%S", @time_val;
jpayne@69 948 };
jpayne@69 949 return $time_str;
jpayne@69 950 }
jpayne@69 951
jpayne@69 952
jpayne@69 953 =item $date_string = getSybaseDate(@tm);
jpayne@69 954
jpayne@69 955 This function returns a Sybase formatted datetime as a string given a time
jpayne@69 956 structure as returned by the C<time> function. If no arguments
jpayne@69 957 are supplied, this function returns the current time. If incorrect
jpayne@69 958 arguments are supplied, this function returns undefined. The date string
jpayne@69 959 returned is quoted according to Sybase requirements.
jpayne@69 960
jpayne@69 961 =cut
jpayne@69 962
jpayne@69 963
jpayne@69 964 sub getSybaseDate(;@) {
jpayne@69 965 #checking if the function is invoked as an instance method.
jpayne@69 966 if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69 967 shift;
jpayne@69 968 }
jpayne@69 969 my @time_val = @_;
jpayne@69 970 my $time_str = undef;
jpayne@69 971 if (scalar(@time_val) == 0) {
jpayne@69 972 @time_val = localtime;
jpayne@69 973 }
jpayne@69 974 eval {
jpayne@69 975 $time_str = strftime "\'%b %d %Y %I:%M%p\'", @time_val;
jpayne@69 976 };
jpayne@69 977 return $time_str;
jpayne@69 978 }
jpayne@69 979
jpayne@69 980
jpayne@69 981 =item $date_string = getMySQLDate(@tm);
jpayne@69 982
jpayne@69 983 This function returns a MySQL formatted datetime as a string given a time
jpayne@69 984 structure as returned by the C<time> function. If no arguments
jpayne@69 985 are supplied, this function returns the current time. If incorrect
jpayne@69 986 arguments are supplied, this function returns undefined. The datetime string
jpayne@69 987 returned is prequoted according to MySQL requirements.
jpayne@69 988
jpayne@69 989 =cut
jpayne@69 990
jpayne@69 991
jpayne@69 992 sub getMySQLDate(;@) {
jpayne@69 993 #checking if the function is invoked as an instance method.
jpayne@69 994 if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69 995 shift;
jpayne@69 996 }
jpayne@69 997 my @time_val = @_;
jpayne@69 998 my $time_str = undef;
jpayne@69 999 if (scalar(@time_val) == 0) {
jpayne@69 1000 @time_val = localtime;
jpayne@69 1001 }
jpayne@69 1002 $time_str = getISODate(@time_val);
jpayne@69 1003 if (defined $time_str) {
jpayne@69 1004 $time_str = "\'$time_str\'";
jpayne@69 1005 }
jpayne@69 1006 return $time_str;
jpayne@69 1007 }
jpayne@69 1008
jpayne@69 1009
jpayne@69 1010 =item $date_string = getFilelabelDate(@tm);
jpayne@69 1011
jpayne@69 1012 This function returns the date (not time) as a compressed string
jpayne@69 1013 suitable for use as part of a file name. The format is YYMMDD.
jpayne@69 1014 The optional parameter should be a time structure as returned by
jpayne@69 1015 the C<time> function. If no arguments are supplied, the current time
jpayne@69 1016 is used. If incorrect arguments are supplied, this function returns
jpayne@69 1017 undefined.
jpayne@69 1018
jpayne@69 1019 =cut
jpayne@69 1020
jpayne@69 1021
jpayne@69 1022 sub getFilelabelDate(;@) {
jpayne@69 1023 #checking if the function is invoked as an instance method.
jpayne@69 1024 if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69 1025 shift;
jpayne@69 1026 }
jpayne@69 1027 my @time_val = @_;
jpayne@69 1028 my $time_str = undef;
jpayne@69 1029 if (scalar(@time_val) == 0) {
jpayne@69 1030 @time_val = localtime;
jpayne@69 1031 }
jpayne@69 1032 eval {
jpayne@69 1033 $time_str = strftime "%y%m%d", @time_val;
jpayne@69 1034 };
jpayne@69 1035 return $time_str;
jpayne@69 1036 }
jpayne@69 1037
jpayne@69 1038
jpayne@69 1039 =item $date_string = $obj_instance->getLogfileDate(@tm);
jpayne@69 1040
jpayne@69 1041 This function returns the datetime as a formatted string
jpayne@69 1042 suitable for use as a log entry header. The optional parameter
jpayne@69 1043 should be a time structure as returned by the C<time> function.
jpayne@69 1044 If no arguments are supplied, this function uses the current time.
jpayne@69 1045 If incorrect arguments are supplied, this function sets the date/time fields
jpayne@69 1046 of the log entry string to C< INVALID|XXXXXX|>.
jpayne@69 1047
jpayne@69 1048 =cut
jpayne@69 1049
jpayne@69 1050
jpayne@69 1051 sub getLogfileDate(;@) {
jpayne@69 1052 #checking if the function is invoked as an instance method.
jpayne@69 1053 if((defined(ref $_[0])) && ((ref $_[0]) eq "TIGR::Foundation")){
jpayne@69 1054 shift;
jpayne@69 1055 }
jpayne@69 1056 my @time_val = @_;
jpayne@69 1057 my $time_str = undef;
jpayne@69 1058 my $log_form = undef;
jpayne@69 1059 if (scalar(@time_val) == 0) {
jpayne@69 1060 @time_val = localtime;
jpayne@69 1061 }
jpayne@69 1062 eval {
jpayne@69 1063 $time_str = strftime("%Y%m%d|%H%M%S|", @time_val);
jpayne@69 1064 };
jpayne@69 1065 if (!defined $time_str) {
jpayne@69 1066 $time_str = " INVALID|XXXXXX|";
jpayne@69 1067 }
jpayne@69 1068 $log_form = $time_str . sprintf("%6d| ", $$);
jpayne@69 1069 return $log_form;
jpayne@69 1070 }
jpayne@69 1071
jpayne@69 1072
jpayne@69 1073 # Functional Class : logging
jpayne@69 1074
jpayne@69 1075 =item $obj_instance->setDebugLevel($new_level);
jpayne@69 1076
jpayne@69 1077 This function sets the level of debug reporting according to C<$new_level>.
jpayne@69 1078 If the debug level is less than 0, all debug reporting is turned off.
jpayne@69 1079 It is impossible to turn off error reporting from C<bail()>. If C<$new_level>
jpayne@69 1080 is undefined, the debug level is set to 0. This function maintains
jpayne@69 1081 compatibility with C<GetOptions()>, and will accept a second parameter
jpayne@69 1082 the debug level, provided it is an integer. In such cases, the first parameter
jpayne@69 1083 is checked only if the second parameter is invalid. By default, the default
jpayne@69 1084 level is undefined. To turn on debugging, you must invoke this function.
jpayne@69 1085
jpayne@69 1086 =cut
jpayne@69 1087
jpayne@69 1088
jpayne@69 1089 sub setDebugLevel($;$) {
jpayne@69 1090 my $self = shift;
jpayne@69 1091 my $new_level = shift;
jpayne@69 1092 my $getopts_new_level = shift;
jpayne@69 1093
jpayne@69 1094 if (
jpayne@69 1095 (defined $getopts_new_level) &&
jpayne@69 1096 ($getopts_new_level =~ /^-?\d+$/)
jpayne@69 1097 ) {
jpayne@69 1098 $new_level = $getopts_new_level;
jpayne@69 1099 }
jpayne@69 1100 elsif (
jpayne@69 1101 (!defined $new_level) ||
jpayne@69 1102 ($new_level !~ /^-?\d+$/)
jpayne@69 1103 ) {
jpayne@69 1104 $new_level = 0;
jpayne@69 1105 $self->logLocal("No or invalid parameter to setDebugLevel(), " .
jpayne@69 1106 "setting debug level to 0", 3);
jpayne@69 1107 }
jpayne@69 1108
jpayne@69 1109 if ($new_level < 0) {
jpayne@69 1110 $new_level = -1;
jpayne@69 1111 }
jpayne@69 1112
jpayne@69 1113 $self->{debug_level} = $new_level;
jpayne@69 1114 $self->logLocal("Set debug level to " . $self->getDebugLevel(), 2);
jpayne@69 1115 }
jpayne@69 1116
jpayne@69 1117
jpayne@69 1118 =item $level = $obj_instance->getDebugLevel();
jpayne@69 1119
jpayne@69 1120 This function returns the current debug level. If the current debug
jpayne@69 1121 level is not defined, this function returns undefined.
jpayne@69 1122
jpayne@69 1123 =cut
jpayne@69 1124
jpayne@69 1125
jpayne@69 1126 sub getDebugLevel() {
jpayne@69 1127 my $self = shift;
jpayne@69 1128 return $self->{debug_level};
jpayne@69 1129 }
jpayne@69 1130
jpayne@69 1131
jpayne@69 1132 =item $obj_instance->setLogFile($log_file);
jpayne@69 1133
jpayne@69 1134 This function sets the log file name for the C<logLocal()> function.
jpayne@69 1135 B<The programmer should call this function before invoking C<setDebugLevel()>>
jpayne@69 1136 if the default log file is not to be used. The function takes one parameter,
jpayne@69 1137 C<$log_file>, which defines the new log file name. If a log file is already
jpayne@69 1138 open, it is closed. The old log file is not truncated or deleted.
jpayne@69 1139 Future calls to C<logLocal()> or C<bail()> will log to C<$log_file> if it
jpayne@69 1140 is successfully opened. If the new log file is not successfully opened,
jpayne@69 1141 the function will try to open the default log file, F<program_name.log>.
jpayne@69 1142 If that file cannot be opened, F</tmp/program_name.$process_id.log> will
jpayne@69 1143 be used. If no log file argument is passed, the function will try to open
jpayne@69 1144 the default log file. This function is C<GetOptions()> aware; it will accept
jpayne@69 1145 two parameters, using the second one as the log file and ignoring the first if
jpayne@69 1146 and only if two parameters are passed. Any other usage specifies the first
jpayne@69 1147 parameter as the log file name.
jpayne@69 1148
jpayne@69 1149 =cut
jpayne@69 1150
jpayne@69 1151
jpayne@69 1152 sub setLogFile($;$) {
jpayne@69 1153 my $self = shift;
jpayne@69 1154 my $old_log_file = defined $self->{static_log_file} ?
jpayne@69 1155 $self->{static_log_file} : undef;
jpayne@69 1156 $self->{static_log_file} = shift;
jpayne@69 1157 if (scalar(@_) == 1) {
jpayne@69 1158 $self->{static_log_file} = shift;
jpayne@69 1159 }
jpayne@69 1160
jpayne@69 1161 # only consider a new log file that is definable as a file
jpayne@69 1162 if ((defined ($self->{static_log_file})) &&
jpayne@69 1163 ($self->{static_log_file} !~ /^\s*$/)) {
jpayne@69 1164 # delete an old log file entry added by "setLogFile"
jpayne@69 1165 for (my $idx = 0;
jpayne@69 1166 ($idx <= $#{$self->{log_files}}) && defined($old_log_file);
jpayne@69 1167 $idx++) {
jpayne@69 1168 if ($self->{log_files}[$idx] eq $old_log_file) {
jpayne@69 1169 splice @{$self->{log_files}}, $idx, 1;
jpayne@69 1170 $old_log_file = undef;
jpayne@69 1171 }
jpayne@69 1172 }
jpayne@69 1173 unshift @{$self->{log_files}}, $self->{static_log_file};
jpayne@69 1174
jpayne@69 1175 # initialize the log file variables and file spaces
jpayne@69 1176 $self->{msg_file_used} = 0;
jpayne@69 1177 $self->{error_file_used} = 0;
jpayne@69 1178 $self->cleanLogFILES();
jpayne@69 1179 }
jpayne@69 1180 }
jpayne@69 1181
jpayne@69 1182
jpayne@69 1183 =item $log_file_name = $obj_instance->getLogFile();
jpayne@69 1184
jpayne@69 1185 This function returns the name of the log file to be used for printing
jpayne@69 1186 log messages. If no log file is available, this function returns undefined.
jpayne@69 1187
jpayne@69 1188 =cut
jpayne@69 1189
jpayne@69 1190
jpayne@69 1191 sub getLogFile() {
jpayne@69 1192 my $self = shift;
jpayne@69 1193 my $return_val = undef;
jpayne@69 1194 if (
jpayne@69 1195 (scalar(@{$self->{log_files}}) != 0) &&
jpayne@69 1196 (defined($self->{log_files}[0]))
jpayne@69 1197 ) {
jpayne@69 1198 $return_val = $self->{log_files}[0];
jpayne@69 1199 }
jpayne@69 1200 return $return_val;
jpayne@69 1201 }
jpayne@69 1202
jpayne@69 1203
jpayne@69 1204 =item $error_file_name = $obj_instance->getErrorFile();
jpayne@69 1205
jpayne@69 1206 This function returns the name of the error file to be used for printing
jpayne@69 1207 error messages. The error file is derived from the log file; a F<.log>
jpayne@69 1208 extension is replaced by a F<.error> extension. If there is no F<.log>
jpayne@69 1209 extension, then F<.error> is appended to the log file name. If no
jpayne@69 1210 log files are defined, this function returns undefined.
jpayne@69 1211
jpayne@69 1212 =cut
jpayne@69 1213
jpayne@69 1214
jpayne@69 1215 sub getErrorFile() {
jpayne@69 1216 my $self = shift;
jpayne@69 1217 my $return_val = $self->getLogFile();
jpayne@69 1218 if (defined $return_val) {
jpayne@69 1219 $return_val =~ s/\.log$//g;
jpayne@69 1220 $return_val .= '.error';
jpayne@69 1221 }
jpayne@69 1222 return $return_val;
jpayne@69 1223 }
jpayne@69 1224
jpayne@69 1225
jpayne@69 1226 # the following private functions are used for logging
jpayne@69 1227
jpayne@69 1228
jpayne@69 1229 # push items onto the debug level stack
jpayne@69 1230 sub debugPush() {
jpayne@69 1231 my $self = shift;
jpayne@69 1232 if (defined ($self->{debug_level})) {
jpayne@69 1233 push @{$self->{debug_store}}, $self->{debug_level};
jpayne@69 1234 }
jpayne@69 1235 else {
jpayne@69 1236 push @{$self->{debug_store}}, "undef";
jpayne@69 1237 }
jpayne@69 1238 $self->{debug_level} = undef;
jpayne@69 1239 }
jpayne@69 1240
jpayne@69 1241
jpayne@69 1242 # pop items from the debug level stack
jpayne@69 1243 sub debugPop() {
jpayne@69 1244 my $self = shift;
jpayne@69 1245 $self->{debug_level} = pop @{$self->{debug_store}};
jpayne@69 1246 if (
jpayne@69 1247 (!defined ($self->{debug_level})) ||
jpayne@69 1248 ($self->{debug_level} eq "undef")
jpayne@69 1249 ) {
jpayne@69 1250 $self->{debug_level} = undef;
jpayne@69 1251 }
jpayne@69 1252 }
jpayne@69 1253
jpayne@69 1254
jpayne@69 1255 # remove log files
jpayne@69 1256 sub removeLogERROR() {
jpayne@69 1257
jpayne@69 1258 my $self = shift;
jpayne@69 1259 $self->debugPush();
jpayne@69 1260 if (
jpayne@69 1261 (defined $self->getErrorFile()) &&
jpayne@69 1262 (isWritableFile($self->getErrorFile()))
jpayne@69 1263 ) {
jpayne@69 1264 unlink $self->getErrorFile() or
jpayne@69 1265 $self->logLocal("Unable to remove error file " .
jpayne@69 1266 $self->getErrorFile(), 3);
jpayne@69 1267 }
jpayne@69 1268 $self->debugPop();
jpayne@69 1269 }
jpayne@69 1270
jpayne@69 1271
jpayne@69 1272 sub removeLogMSG() {
jpayne@69 1273 my $self = shift;
jpayne@69 1274 $self->debugPush();
jpayne@69 1275
jpayne@69 1276 if (
jpayne@69 1277 (defined $self->getLogFile()) &&
jpayne@69 1278 (isWritableFile($self->getLogFile()))
jpayne@69 1279 ) {
jpayne@69 1280 unlink $self->getLogFile() or
jpayne@69 1281 $self->logLocal("Unable to remove error file " .
jpayne@69 1282 $self->getLogFile(), 3);
jpayne@69 1283 }
jpayne@69 1284 $self->debugPop();
jpayne@69 1285 }
jpayne@69 1286
jpayne@69 1287
jpayne@69 1288 # invalidate log files
jpayne@69 1289 sub invalidateLogFILES() {
jpayne@69 1290 my $self = shift;
jpayne@69 1291 $self->debugPush();
jpayne@69 1292 if (defined $self->getLogFile()) {
jpayne@69 1293 $self->logLocal("Invalidating " . $self->getLogFile(), 2);
jpayne@69 1294 shift @{$self->{log_files}};
jpayne@69 1295 $self->{msg_append_flag} = $self->{error_append_flag} =
jpayne@69 1296 $self->{log_append_setting};
jpayne@69 1297 $self->{msg_file_used} = $self->{error_file_used} = 0;
jpayne@69 1298 $self->cleanLogFILES();
jpayne@69 1299 }
jpayne@69 1300 $self->debugPop();
jpayne@69 1301 }
jpayne@69 1302
jpayne@69 1303
jpayne@69 1304 # clean previous log files
jpayne@69 1305 sub cleanLogFILES() {
jpayne@69 1306 my $self = shift;
jpayne@69 1307 if ($self->{log_append_setting} == 0) {
jpayne@69 1308 if ($self->{msg_file_used} == 0) {
jpayne@69 1309 $self->removeLogMSG();
jpayne@69 1310 }
jpayne@69 1311 if ($self->{error_file_used} == 0) {
jpayne@69 1312 $self->removeLogERROR();
jpayne@69 1313 }
jpayne@69 1314 }
jpayne@69 1315 }
jpayne@69 1316
jpayne@69 1317
jpayne@69 1318 # close log files
jpayne@69 1319 sub closeLogERROR() {
jpayne@69 1320 my $self = shift;
jpayne@69 1321 my $return_code = 1; # need to return true for success, false for fail
jpayne@69 1322
jpayne@69 1323 $self->debugPush();
jpayne@69 1324 if (!close(ERRLOG) && (defined $self->getErrorFile())) {
jpayne@69 1325 $self->logLocal("Cannot close " . $self->getErrorFile(), 3);
jpayne@69 1326 $return_code = 0;
jpayne@69 1327 }
jpayne@69 1328 else {
jpayne@69 1329 $return_code = 1;
jpayne@69 1330 }
jpayne@69 1331 $self->{error_file_open_flag} = 0;
jpayne@69 1332 $self->debugPop();
jpayne@69 1333 return $return_code;
jpayne@69 1334 }
jpayne@69 1335
jpayne@69 1336
jpayne@69 1337 sub closeLogMSG() {
jpayne@69 1338 my $self = shift;
jpayne@69 1339 my $return_code = 1; # need to return true for success, false for fail
jpayne@69 1340
jpayne@69 1341 $self->debugPush();
jpayne@69 1342 if (!close(MSGLOG) && (defined $self->getLogFile())) {
jpayne@69 1343 $self->logLocal("Cannot close " . $self->getLogFile(), 3);
jpayne@69 1344 $return_code = 0;
jpayne@69 1345 }
jpayne@69 1346 else {
jpayne@69 1347 $return_code = 1;
jpayne@69 1348 }
jpayne@69 1349 $self->{msg_file_open_flag} = 0;
jpayne@69 1350 $self->debugPop();
jpayne@69 1351 return $return_code;
jpayne@69 1352 }
jpayne@69 1353
jpayne@69 1354
jpayne@69 1355 # open log files
jpayne@69 1356 sub openLogERROR() {
jpayne@69 1357 my $self = shift;
jpayne@69 1358 my $return_code = 1; # need to return true for success, false for fail
jpayne@69 1359
jpayne@69 1360 $self->debugPush();
jpayne@69 1361 if ((defined $self->getErrorFile()) &&
jpayne@69 1362 ($self->{error_file_open_flag} == 0)) {
jpayne@69 1363 my $fileop;
jpayne@69 1364 $self->{error_file_open_flag} = 1;
jpayne@69 1365 if ($self->{error_append_flag} == 0) {
jpayne@69 1366 $fileop = '>';
jpayne@69 1367 $self->{error_append_flag} = 1;
jpayne@69 1368 }
jpayne@69 1369 else {
jpayne@69 1370 $fileop = '>>';
jpayne@69 1371 }
jpayne@69 1372 if (open(ERRLOG, $fileop . $self->getErrorFile())) {
jpayne@69 1373 autoflush ERRLOG 1;
jpayne@69 1374 }
jpayne@69 1375 else {
jpayne@69 1376 $self->logLocal("Cannot open " . $self->getErrorFile() .
jpayne@69 1377 " for logging", 4);
jpayne@69 1378 $self->{error_file_open_flag} = 0;
jpayne@69 1379 }
jpayne@69 1380 }
jpayne@69 1381 $return_code = $self->{error_file_open_flag};
jpayne@69 1382 $self->debugPop();
jpayne@69 1383
jpayne@69 1384 # this is 1 if the file stream is open, 0 if not
jpayne@69 1385 return $return_code;
jpayne@69 1386 }
jpayne@69 1387
jpayne@69 1388
jpayne@69 1389 sub openLogMSG() {
jpayne@69 1390 my $self = shift;
jpayne@69 1391 my $return_code = 1; # need to return true for success, false for fail
jpayne@69 1392
jpayne@69 1393 $self->debugPush();
jpayne@69 1394 if ((defined $self->getLogFile()) && ($self->{msg_file_open_flag} == 0)){
jpayne@69 1395 my $fileop;
jpayne@69 1396 $self->{msg_file_open_flag} = 1;
jpayne@69 1397 if ($self->{msg_append_flag} == 0) {
jpayne@69 1398 $fileop = '>';
jpayne@69 1399 $self->{msg_append_flag} = 1;
jpayne@69 1400 }
jpayne@69 1401 else {
jpayne@69 1402 $fileop = '>>';
jpayne@69 1403 }
jpayne@69 1404
jpayne@69 1405 if (open(MSGLOG, $fileop . $self->getLogFile())) {
jpayne@69 1406 autoflush MSGLOG 1;
jpayne@69 1407 }
jpayne@69 1408 else {
jpayne@69 1409 $self->logLocal("Cannot open " . $self->getLogFile() .
jpayne@69 1410 " for logging", 4);
jpayne@69 1411 $self->{msg_file_open_flag} = 0;
jpayne@69 1412 }
jpayne@69 1413 }
jpayne@69 1414 $return_code = $self->{msg_file_open_flag};
jpayne@69 1415 $self->debugPop();
jpayne@69 1416
jpayne@69 1417 # this is 1 if the file stream is open, 0 if not
jpayne@69 1418 return $return_code;
jpayne@69 1419 }
jpayne@69 1420
jpayne@69 1421
jpayne@69 1422 =item $obj_instance->logAppend($log_append_flag);
jpayne@69 1423
jpayne@69 1424 The C<logAppend()> function takes either C<0> or C<1> as a flag to
jpayne@69 1425 disable or enable log file appending. By default, log files are
jpayne@69 1426 truncated at the start of program execution or logging. Error files are
jpayne@69 1427 controlled by this variable as well. Invalid or undefined calls are ignored.
jpayne@69 1428 Calling this function with a C<0> argument after the log files have started
jpayne@69 1429 to be written may cause them to be truncated undesirably. This function is
jpayne@69 1430 C<GetOptions()> compliant; if 2 and only 2 variables are passed, the second
jpayne@69 1431 option is treated as C<$log_append_flag>.
jpayne@69 1432
jpayne@69 1433 =cut
jpayne@69 1434
jpayne@69 1435
jpayne@69 1436 sub logAppend($;$) {
jpayne@69 1437 my $self = shift;
jpayne@69 1438 my $log_append_flag = shift;
jpayne@69 1439 if (defined $_[0]) {
jpayne@69 1440 $log_append_flag = shift;
jpayne@69 1441 }
jpayne@69 1442 if (
jpayne@69 1443 (defined ($log_append_flag)) &&
jpayne@69 1444 (($log_append_flag eq "0") ||
jpayne@69 1445 ($log_append_flag eq "1"))
jpayne@69 1446 ) {
jpayne@69 1447 $self->{log_append_setting} = $self->{msg_append_flag} =
jpayne@69 1448 $self->{error_append_flag} = $log_append_flag;
jpayne@69 1449 }
jpayne@69 1450 }
jpayne@69 1451
jpayne@69 1452
jpayne@69 1453 =item $obj_instance->logLocal($log_message, $log_level);
jpayne@69 1454
jpayne@69 1455 The C<logLocal()> function takes two arguments. The C<$log_message>
jpayne@69 1456 argument specifies the message to be written to the log file. The
jpayne@69 1457 C<$log_level> argument specifies the level at which C<$log_message> is printed.
jpayne@69 1458 The active level of logging is set via the C<setDebugLevel()> function.
jpayne@69 1459 Only messages at C<$log_level> less than or equal to the active debug
jpayne@69 1460 level are logged. The default debug level is undefined. Note, a trailing
jpayne@69 1461 new line, if it exists, is stripped from the log message.
jpayne@69 1462
jpayne@69 1463 =cut
jpayne@69 1464
jpayne@69 1465
jpayne@69 1466 sub logLocal($$) {
jpayne@69 1467 my $self = shift;
jpayne@69 1468 my $log_message = shift;
jpayne@69 1469 my $log_level = shift;
jpayne@69 1470
jpayne@69 1471 if ((!defined $log_level) || ($log_level =~ /\D/)) {
jpayne@69 1472 $log_level = 1;
jpayne@69 1473 }
jpayne@69 1474
jpayne@69 1475 if (defined $log_message) {
jpayne@69 1476 chomp $log_message; # strip end new line, if it exists
jpayne@69 1477
jpayne@69 1478 $log_message = getLogfileDate() . $log_message;
jpayne@69 1479 push @{$self->{debug_queue}}, [ $log_message, $log_level ];
jpayne@69 1480
jpayne@69 1481 if ((defined ($self->getDebugLevel())) &&
jpayne@69 1482 ($self->getDebugLevel() > -1)) {
jpayne@69 1483 while (
jpayne@69 1484 (defined(my $log_record = $self->{debug_queue}[0])) &&
jpayne@69 1485 (defined($self->getLogFile()))
jpayne@69 1486 ) {
jpayne@69 1487 ($log_message, $log_level) = @{$log_record};
jpayne@69 1488 if (
jpayne@69 1489 (
jpayne@69 1490 ($log_level <= $self->getDebugLevel()) && # debug level
jpayne@69 1491 ($self->openLogMSG()) && # check log file
jpayne@69 1492 (print MSGLOG "$log_message\n") && # print message
jpayne@69 1493 ($self->closeLogMSG()) && # close log file
jpayne@69 1494 ($self->{msg_file_used} = 1) # log file used
jpayne@69 1495 ) ||
jpayne@69 1496 (
jpayne@69 1497 ($log_level > $self->getDebugLevel()) # bad dbg level
jpayne@69 1498 )
jpayne@69 1499 ) {
jpayne@69 1500 # log message is successfully processed, so shift it off
jpayne@69 1501 shift @{$self->{debug_queue}};
jpayne@69 1502 }
jpayne@69 1503 else {
jpayne@69 1504 $self->debugPush();
jpayne@69 1505 $self->logLocal("Cannot log message \'$log_message\' to " .
jpayne@69 1506 $self->getLogFile() . " = " . $!, 9);
jpayne@69 1507 $self->invalidateLogFILES();
jpayne@69 1508 $self->debugPop();
jpayne@69 1509 }
jpayne@69 1510 }
jpayne@69 1511 }
jpayne@69 1512 }
jpayne@69 1513 else {
jpayne@69 1514 $self->logLocal("logLocal() called without any parameters!",3);
jpayne@69 1515 }
jpayne@69 1516
jpayne@69 1517 while ($#{$self->{debug_queue}} >= $self->{max_debug_queue_size}) {
jpayne@69 1518 # expire old entries; this needs to happen if $self->{debug_level}
jpayne@69 1519 # is undefined or there is no writable log file, otherwise the
jpayne@69 1520 # queue could exhaust RAM.
jpayne@69 1521 shift @{$self->{debug_queue}};
jpayne@69 1522 }
jpayne@69 1523 }
jpayne@69 1524
jpayne@69 1525
jpayne@69 1526 =item $obj_instance->logError($log_message,$flag);
jpayne@69 1527
jpayne@69 1528 The C<logError()> function takes two arguments, the second one being optional.
jpayne@69 1529 The C<$log_message> argument specifies the message to be written to the error
jpayne@69 1530 file. If the C<$flag> argument is defined and is non-zero, the C<$log_message>
jpayne@69 1531 is also written to STDERR. The C<$log_message> is also passed to C<logLocal>.
jpayne@69 1532 A message passed via logError() will always get logged to the log file
jpayne@69 1533 regardles of the debug level. Note, a trailing new line, if it exists, is
jpayne@69 1534 stripped from the log message.
jpayne@69 1535
jpayne@69 1536 =cut
jpayne@69 1537
jpayne@69 1538
jpayne@69 1539 sub logError($;$) {
jpayne@69 1540
jpayne@69 1541 my $self = shift;
jpayne@69 1542 my $log_message = shift;
jpayne@69 1543 my $flag = shift;
jpayne@69 1544 if (defined $log_message) {
jpayne@69 1545 chomp $log_message; # strip end new line, if it exists
jpayne@69 1546 $self->logLocal($log_message, 0);
jpayne@69 1547
jpayne@69 1548 #printing error message to STDERR if flag is non zero.
jpayne@69 1549 if((defined($flag)) && ($flag ne '0')) {
jpayne@69 1550 print STDERR "$log_message\n";
jpayne@69 1551 }
jpayne@69 1552
jpayne@69 1553 $log_message = getLogfileDate() . $log_message;
jpayne@69 1554 push(@{$self->{error_queue}}, $log_message);
jpayne@69 1555
jpayne@69 1556 while (
jpayne@69 1557 (defined(my $log_message = $self->{error_queue}[0])) &&
jpayne@69 1558 (defined($self->getErrorFile()))
jpayne@69 1559 ) {
jpayne@69 1560
jpayne@69 1561 if (
jpayne@69 1562 ($self->openLogERROR()) &&
jpayne@69 1563 (print ERRLOG "$log_message\n") &&
jpayne@69 1564 ($self->closeLogERROR()) &&
jpayne@69 1565 ($self->{error_file_used} = 1) # that is an '='
jpayne@69 1566 ) {
jpayne@69 1567 shift @{$self->{error_queue}};
jpayne@69 1568 }
jpayne@69 1569 else {
jpayne@69 1570 $self->debugPush();
jpayne@69 1571 $self->logLocal("Cannot log message \'$log_message\' to " .
jpayne@69 1572 $self->getErrorFile() . " = $!", 6);
jpayne@69 1573 $self->invalidateLogFILES();
jpayne@69 1574 $self->debugPop();
jpayne@69 1575 }
jpayne@69 1576 }
jpayne@69 1577 }
jpayne@69 1578 else {
jpayne@69 1579 $self->logLocal("logError() called without any parameters!",3);
jpayne@69 1580 }
jpayne@69 1581
jpayne@69 1582 while ($#{$self->{error_queue}} >= $self->{max_debug_queue_size}) {
jpayne@69 1583 # expire old entries; this needs to happen if $self->{debug_level}
jpayne@69 1584 # is undefined or there is no writable log file, otherwise the
jpayne@69 1585 # queue could exhaust RAM.
jpayne@69 1586 shift @{$self->{error_queue}};
jpayne@69 1587 }
jpayne@69 1588 }
jpayne@69 1589
jpayne@69 1590
jpayne@69 1591 =item $obj_instance->bail($log_message);
jpayne@69 1592
jpayne@69 1593 The C<bail()> function takes a single required argument. The C<$log_message>
jpayne@69 1594 argument specifies the message to be passed to C<logLocal()> and displayed
jpayne@69 1595 to the screen in using the C<warn> function. All messages passed to C<bail()>
jpayne@69 1596 are logged regardless of the debug level. The C<bail()> function
jpayne@69 1597 calls C<exit(1)> to terminate the program. Optionally, a second positive
jpayne@69 1598 integer argument can be passed as the exit code to use. Note, a trailing
jpayne@69 1599 new line, if it exists, is stripped from the end of the line.
jpayne@69 1600
jpayne@69 1601 =cut
jpayne@69 1602
jpayne@69 1603
jpayne@69 1604 sub bail($;$) {
jpayne@69 1605 my $self = shift;
jpayne@69 1606 my $log_message = shift;
jpayne@69 1607 my $exit_code = shift;
jpayne@69 1608
jpayne@69 1609 if (
jpayne@69 1610 (!defined $exit_code) ||
jpayne@69 1611 ($exit_code !~ /^\d+$/)
jpayne@69 1612 ) {
jpayne@69 1613 $exit_code = 1;
jpayne@69 1614 }
jpayne@69 1615 if (defined $log_message) {
jpayne@69 1616 chomp $log_message; # strip end new line, if it exists
jpayne@69 1617
jpayne@69 1618 $self->logError($log_message);
jpayne@69 1619 print STDERR $log_message, "\n";
jpayne@69 1620 }
jpayne@69 1621
jpayne@69 1622 exit $exit_code;
jpayne@69 1623 }
jpayne@69 1624
jpayne@69 1625
jpayne@69 1626 # Functional Class : modified methods
jpayne@69 1627
jpayne@69 1628 =item $getopts_error_code = $obj_instance->TIGR_GetOptions(@getopts_arguments);
jpayne@69 1629
jpayne@69 1630 This function extends C<Getopt::Long::GetOptions()>. It may be used
jpayne@69 1631 as C<GetOptions()> is used. Extended functionality eliminates the need
jpayne@69 1632 to C<eval {}> the block of code containing the function. Further, TIGR
jpayne@69 1633 standard options, such as C<-help>, are defined implicitly. Using this
jpayne@69 1634 function promotes proper module behavior. Log and error files from
jpayne@69 1635 previous runs are removed if the log file append option, C<-appendlog>,
jpayne@69 1636 is not set to 1.
jpayne@69 1637
jpayne@69 1638 The following options are defined by this function:
jpayne@69 1639
jpayne@69 1640 =over
jpayne@69 1641
jpayne@69 1642 =item -appendlog APPEND_FLAG
jpayne@69 1643
jpayne@69 1644 Passing '1' to this argument turns on log file appending.
jpayne@69 1645
jpayne@69 1646 =item -debug DEBUG_LEVEL
jpayne@69 1647
jpayne@69 1648 Set debugging to DEBUG_LEVEL.
jpayne@69 1649
jpayne@69 1650 =item -logfile LOG_FILE_NAME
jpayne@69 1651
jpayne@69 1652 Set the default TIGR Foundation log file to LOG_FILE_NAME.
jpayne@69 1653
jpayne@69 1654 =item -version, -V
jpayne@69 1655
jpayne@69 1656 Print version information and exit.
jpayne@69 1657
jpayne@69 1658 =item -help, -h
jpayne@69 1659
jpayne@69 1660 Print help information and exit.
jpayne@69 1661
jpayne@69 1662 =item -depend
jpayne@69 1663
jpayne@69 1664 Print dependency information and exit.
jpayne@69 1665
jpayne@69 1666 =back
jpayne@69 1667
jpayne@69 1668 Regular C<GetOptions()> may still be used, however the C<TIGR_GetOptions()>
jpayne@69 1669 function eliminates some of the confusing issues with setting log files
jpayne@69 1670 and debug levels. B<The options defined by C<TIGR_GetOptions()> cannot be
jpayne@69 1671 overridden or recorded>. To get the log file and debug level after parsing
jpayne@69 1672 the command line, use C<getLogFile()> and C<getDebugLevel()>. C<GetOptions()>
jpayne@69 1673 default variables, ie. those of the form C<$opt_I<optionname>>, are not
jpayne@69 1674 supported. This function will return 1 on success.
jpayne@69 1675
jpayne@69 1676 =cut
jpayne@69 1677
jpayne@69 1678
jpayne@69 1679 sub TIGR_GetOptions(@) {
jpayne@69 1680 my $self = shift;
jpayne@69 1681 my @user_options = @_;
jpayne@69 1682
jpayne@69 1683 my $appendlog_var = undef;
jpayne@69 1684 my $logfile_var = undef;
jpayne@69 1685 my $debug_var = undef;
jpayne@69 1686 my $version_var = undef;
jpayne@69 1687 my $help_var = undef;
jpayne@69 1688 my $depend_var = undef;
jpayne@69 1689
jpayne@69 1690 # these foundation options support the defaults
jpayne@69 1691 my @foundation_options = (
jpayne@69 1692 "appendlog=i" => \$appendlog_var,
jpayne@69 1693 "logfile=s" => \$logfile_var,
jpayne@69 1694 "debug=i" => \$debug_var,
jpayne@69 1695 "version|V" => \$version_var,
jpayne@69 1696 "help|h" => \$help_var,
jpayne@69 1697 "depend" => \$depend_var
jpayne@69 1698 );
jpayne@69 1699
jpayne@69 1700 Getopt::Long::Configure('no_ignore_case');
jpayne@69 1701 my $getopt_code = eval 'GetOptions (@user_options, @foundation_options)';
jpayne@69 1702
jpayne@69 1703 if ((defined $help_var) && ($help_var =~ /^(.*)$/)) {
jpayne@69 1704 $self->printHelpInfoAndExit();
jpayne@69 1705 }
jpayne@69 1706
jpayne@69 1707 if ((defined $version_var) && ($version_var =~ /^(.*)$/)) {
jpayne@69 1708 $self->printVersionInfoAndExit();
jpayne@69 1709 }
jpayne@69 1710
jpayne@69 1711 if ((defined $depend_var) && ($depend_var =~ /^(.*)$/)) {
jpayne@69 1712 $self->printDependInfoAndExit();
jpayne@69 1713 }
jpayne@69 1714
jpayne@69 1715 if ((defined $appendlog_var) && ($appendlog_var =~ /^(.*)$/)) {
jpayne@69 1716 $appendlog_var = $1;
jpayne@69 1717 $self->logAppend($appendlog_var);
jpayne@69 1718 }
jpayne@69 1719
jpayne@69 1720 if ((defined $logfile_var) && ($logfile_var =~ /^(.*)$/)) {
jpayne@69 1721 $logfile_var = $1;
jpayne@69 1722 $self->setLogFile($logfile_var);
jpayne@69 1723 }
jpayne@69 1724
jpayne@69 1725 if ((defined $debug_var) && ($debug_var =~ /^(.*)$/)) {
jpayne@69 1726 $debug_var = $1;
jpayne@69 1727 $self->setDebugLevel($debug_var);
jpayne@69 1728 }
jpayne@69 1729
jpayne@69 1730 # remove old log files, if necessary
jpayne@69 1731 for (
jpayne@69 1732 my $file_control_var = 0;
jpayne@69 1733 $file_control_var <= $#{$self->{log_files}};
jpayne@69 1734 $file_control_var++
jpayne@69 1735 ) {
jpayne@69 1736 $self->cleanLogFILES();
jpayne@69 1737 push(@{$self->{log_files}}, shift @{$self->{log_files}});
jpayne@69 1738 }
jpayne@69 1739 return $getopt_code;
jpayne@69 1740 }
jpayne@69 1741
jpayne@69 1742 DESTROY {
jpayne@69 1743 my $self = shift;
jpayne@69 1744 $self->{finish_time} = time;
jpayne@69 1745 my $time_difference = $self->{finish_time} - $self->{start_time};
jpayne@69 1746 my $num_days = int($time_difference / 86400); # there are 86400 sec/day
jpayne@69 1747 $time_difference -= $num_days * 86400;
jpayne@69 1748 my $num_hours = int($time_difference / 3600); # there are 3600 sec/hour
jpayne@69 1749 $time_difference -= $num_hours * 3600;
jpayne@69 1750 my $num_min = int($time_difference / 60); # there are 60 sec/hour
jpayne@69 1751 $time_difference -= $num_min * 60;
jpayne@69 1752 my $num_sec = $time_difference; # the left overs are seconds
jpayne@69 1753 my $time_str = sprintf "%03d-%02d:%02d:%02d", $num_days, $num_hours,
jpayne@69 1754 $num_min, $num_sec;
jpayne@69 1755 $self->logLocal("FINISH: " . $self->getProgramInfo('name') .
jpayne@69 1756 ", elapsed ".$time_str ,0);
jpayne@69 1757 }
jpayne@69 1758 }
jpayne@69 1759
jpayne@69 1760 =back
jpayne@69 1761
jpayne@69 1762 =head1 USAGE
jpayne@69 1763
jpayne@69 1764 To use this module, load the C<TIGR::Foundation> package
jpayne@69 1765 via the C<use> function. Then, create a new instance of the
jpayne@69 1766 object via the C<new()> method, as shown below. If applicable,
jpayne@69 1767 C<START> and C<FINISH> log messages are printed when the object
jpayne@69 1768 is created and destroyed, respectively. It is advisable to
jpayne@69 1769 keep the instance of the object in scope for the whole program
jpayne@69 1770 to achieve maximum functionality.
jpayne@69 1771
jpayne@69 1772 An example script using this module follows:
jpayne@69 1773
jpayne@69 1774 use strict;
jpayne@69 1775 use TIGR::Foundation;
jpayne@69 1776
jpayne@69 1777 my $tfobject = new TIGR::Foundation;
jpayne@69 1778
jpayne@69 1779 MAIN:
jpayne@69 1780 {
jpayne@69 1781 # The following dependencies are not used in
jpayne@69 1782 # this script, but are provided as an example.
jpayne@69 1783
jpayne@69 1784 my @DEPEND = ("/usr/bin/tee", "/sbin/stty");
jpayne@69 1785
jpayne@69 1786 # The user defined $VERSION variable is usable by Perl.
jpayne@69 1787 # The auto defined $REVISION variable stores the RCS/CVS revision
jpayne@69 1788 # The user defined $VERSION_STRING reports both.
jpayne@69 1789
jpayne@69 1790 my $VERSION = '1.0';
jpayne@69 1791 my $REVISION = (qw$Revision: 1.1.1.1 $)[-1];
jpayne@69 1792 my $VERSION_STRING = "$VERSION (Build $REVISION)";
jpayne@69 1793
jpayne@69 1794 my $HELP_INFO = "This is my help\n";
jpayne@69 1795
jpayne@69 1796 # All of the necessary information must be passed
jpayne@69 1797 # to the foundation object instance, as below.
jpayne@69 1798
jpayne@69 1799 $tfobject->addDependInfo(@DEPEND);
jpayne@69 1800 $tfobject->setVersionInfo($VERSION_STRING);
jpayne@69 1801 $tfobject->setHelpInfo($HELP_INFO);
jpayne@69 1802
jpayne@69 1803 my $input_file;
jpayne@69 1804 my $output_file;
jpayne@69 1805
jpayne@69 1806 $tfobject->TIGR_GetOptions("input=s" => \$input_file,
jpayne@69 1807 "output=s" => \$output_file);
jpayne@69 1808
jpayne@69 1809 # GetOptions(), and subsequently TIGR_GetOptions(), leaves
jpayne@69 1810 # the variables unchanged if no corresponding command line
jpayne@69 1811 # arguments are parsed. The passed variables are checked below.
jpayne@69 1812
jpayne@69 1813 if (defined $input_file) {
jpayne@69 1814
jpayne@69 1815 # The log message is written only if debugging is turned on.
jpayne@69 1816 # By default, debugging is off. To turn on debugging, use the
jpayne@69 1817 # '-debug DEBUG_LEVEL' option on the command line.
jpayne@69 1818 # In this example, '-debug 1' would set debugging to level 1
jpayne@69 1819 # and report these log messages.
jpayne@69 1820
jpayne@69 1821 $tfobject->logLocal("My input file is $input_file", 1);
jpayne@69 1822 }
jpayne@69 1823
jpayne@69 1824 print "Hello world", "\n";
jpayne@69 1825
jpayne@69 1826 # This case is similar to the previous one above...
jpayne@69 1827 if (defined $output_file) {
jpayne@69 1828 $tfobject->logLocal("My output file is $output_file.", 1);
jpayne@69 1829 }
jpayne@69 1830 }
jpayne@69 1831
jpayne@69 1832 =cut
jpayne@69 1833
jpayne@69 1834 1;
jpayne@69 1835
jpayne@69 1836
jpayne@69 1837
jpayne@69 1838