Mercurial > repos > rliterman > csp2

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