[Bio] / FigKernelPackages / Tracer.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/Tracer.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4, Thu Jan 27 00:32:17 2005 UTC revision 1.23, Tue Sep 13 05:36:12 2005 UTC
# Line 2  Line 2 
2    
3          require Exporter;          require Exporter;
4          @ISA = ('Exporter');          @ISA = ('Exporter');
5          @EXPORT = qw(Trace T TSetup QTrace Confess Cluck);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK);
6          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
7          use strict;          use strict;
8          use Carp qw(longmess croak);          use Carp qw(longmess croak);
9          use CGI;          use CGI;
10        use FIG_Config;
11        use PageBuilder;
12        use Digest::MD5;
13    
14  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
15    
# Line 18  Line 21 
21  has a list of categories and a single trace level set by the B<TSetup> method. Only messages whose trace  has a list of categories and a single trace level set by the B<TSetup> method. Only messages whose trace
22  level is less than or equal to this package's trace level and whose category is activated will  level is less than or equal to this package's trace level and whose category is activated will
23  be written. Thus, a higher trace level on a message indicates that the message  be written. Thus, a higher trace level on a message indicates that the message
24  is less likely to be seen. A higher trace level passed to B<Setup> means more trace messages will  is less likely to be seen. A higher trace level passed to B<TSetup> means more trace messages will
25  appear. To generate a trace message, use the following syntax.  appear. To generate a trace message, use the following syntax.
26    
27  C<< Trace($message) if T(errors => 4); >>  C<< Trace($message) if T(errors => 4); >>
# Line 36  Line 39 
39    
40  C<< Trace($message) if T(2); >>  C<< Trace($message) if T(2); >>
41    
42  To set up tracing, you call the C</Setup> method. The method takes as input a trace level, a list  To set up tracing, you call the L</TSetup> method. The method takes as input a trace level, a list
43  of category names, and a set of options. The trace level and list of category names are  of category names, and a set of options. The trace level and list of category names are
44  specified as a space-delimited string. Thus  specified as a space-delimited string. Thus
45    
46  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
47    
48  sets the trace level to 3, activated the C<errors>, C<Sprout>, and C<ERDB> categories, and  sets the trace level to 3, activates the C<errors>, C<Sprout>, and C<ERDB> categories, and
49  specifies that messages should be output as HTML paragraphs. The idea is to make it easier to  specifies that messages should be output as HTML paragraphs.
50  input tracing configuration on a web form.  
51    To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
52    level 3 and writes the output to the standard error output. This sort of thing might be
53    useful in a CGI environment.
54    
55    C<< TSetup('3 *', 'WARN'); >>
56    
57  In addition to HTML and file output for trace messages, you can specify that the trace messages  In addition to HTML and file output for trace messages, you can specify that the trace messages
58  be queued. The messages can then be retrieved by calling the L</QTrace> method. This approach  be queued. The messages can then be retrieved by calling the L</QTrace> method. This approach
# Line 59  Line 67 
67  Thus, debugging information is available and easily retrieved even when the application is  Thus, debugging information is available and easily retrieved even when the application is
68  being used out in the field.  being used out in the field.
69    
70    There is no hard and fast rule on how to use trace levels. The following is therefore only
71    a suggestion.
72    
73    =over 4
74    
75    =item 0 Error
76    
77    Message indicates an error that may lead to incorrect results or that has stopped the
78    application entirely.
79    
80    =item 1 Warning
81    
82    Message indicates something that is unexpected but that probably did not interfere
83    with program execution.
84    
85    =item 2 Notice
86    
87    Message indicates the beginning or end of a major task.
88    
89    =item 3 Information
90    
91    Message indicates a subtask. In the FIG system, a subtask generally relates to a single
92    genome. This would be a big loop that is not expected to execute more than 500 times or so.
93    
94    =item 4 Detail
95    
96    Message indicates a low-level loop iteration.
97    
98    =back
99    
100  =cut  =cut
101    
102  # Declare the configuration variables.  # Declare the configuration variables.
103    
104  my $Destination = "NONE";       # Description of where to send the trace output.  my $Destination = "NONE";       # Description of where to send the trace output.
105    my $TeeFlag = 0;            # TRUE if output is going to a file and to the
106                                # standard output
107  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
108                                                          # hash of active category names                                                          # hash of active category names
109  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
110                                                          # messages                                                          # messages
111  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
112    my $LastCategory = "main";  # name of the last category interrogated
113    my $SetupCount = 0;         # number of times TSetup called
114    my $AllTrace = 0;           # TRUE if we are tracing all categories.
115    
116  =head2 Public Methods  =head2 Public Methods
117    
# Line 90  Line 133 
133    
134  The destination for the trace output. To send the trace output to a file, specify the file  The destination for the trace output. To send the trace output to a file, specify the file
135  name preceded by a ">" symbol. If a double symbol is used (">>"), then the data is appended  name preceded by a ">" symbol. If a double symbol is used (">>"), then the data is appended
136  to the file. Otherwise the file is cleared before tracing begins. In addition to sending  to the file. Otherwise the file is cleared before tracing begins. Precede the first ">"
137  the trace messages to a file, you can specify a special destination. C<HTML> will  symbol with a C<+> to echo output to a file AND to the standard output. In addition to
138    sending the trace messages to a file, you can specify a special destination. C<HTML> will
139  cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>  cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
140  will cause tracing to the standard output as ordinary text. C<QUEUE> will cause trace messages  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace
141  to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will cause  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace
142  trace messages to be emitted as warnings using the B<warn> directive.  C<NONE> will cause  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
143  tracing to be suppressed.  cause trace messages to be emitted as warnings using the B<warn> directive.  C<NONE> will
144    cause tracing to be suppressed.
145    
146  =back  =back
147    
# Line 109  Line 154 
154          my @categoryData = split /\s+/, $categoryList;          my @categoryData = split /\s+/, $categoryList;
155          # Extract the trace level.          # Extract the trace level.
156          $TraceLevel = shift @categoryData;          $TraceLevel = shift @categoryData;
157          # Build the category hash.      # Presume category-based tracing until we learn otherwise.
158        $AllTrace = 0;
159        # Build the category hash. Note that if we find a "*", we turn on non-category
160        # tracing.
161          for my $category (@categoryData) {          for my $category (@categoryData) {
162                  $Categories{$category} = 1;          if ($category eq '*') {
163                $AllTrace = 1;
164            } else {
165                $Categories{lc $category} = 1;
166            }
167          }          }
168          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
169          # case is the single ">", which requires we clear the file first. After doing      # cases are the single ">", which requires we clear the file first, and the
170          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
171        if ($target =~ m/^\+?>>?/) {
172            if ($target =~ m/^\+/) {
173                $TeeFlag = 1;
174                $target = substr($target, 1);
175            }
176          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
177                  open TRACEFILE, $target;                  open TRACEFILE, $target;
178                  print TRACEFILE Now() . " Tracing initialized.\n";                  print TRACEFILE Now() . " Tracing initialized.\n";
179                  close TRACEFILE;                  close TRACEFILE;
180                  $Destination = ">$target";                  $Destination = ">$target";
181          } else {          } else {
182                $Destination = $target;
183            }
184        } else {
185                  $Destination = uc($target);                  $Destination = uc($target);
186          }          }
187        # Increment the setup counter.
188        $SetupCount++;
189    }
190    
191    =head3 Setups
192    
193    C<< my $count = Tracer::Setups(); >>
194    
195    Return the number of times L</TSetup> has been called.
196    
197    This method allows for the creation of conditional tracing setups where, for example, we
198    may want to set up tracing if nobody else has done it before us.
199    
200    =cut
201    
202    sub Setups {
203        return $SetupCount;
204    }
205    
206    =head3 Open
207    
208    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
209    
210    Open a file.
211    
212    The I<$fileSpec> is essentially the second argument of the PERL C<open>
213    function. The mode is specified using Unix-like shell information. So, for
214    example,
215    
216        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
217    
218    would open for output appended to the specified file, and
219    
220        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
221    
222    would open a pipe that sorts the records written and removes duplicates. Note
223    the use of file handle syntax in the Open call. To use anonymous file handles,
224    code as follows.
225    
226        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
227    
228    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
229    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
230    failed open will throw an exception and the third parameter will be used to construct
231    an error message. If the parameter is omitted, a standard message is constructed
232    using the file spec.
233    
234        Could not open "/usr/spool/news/twitlog"
235    
236    Note that the mode characters are automatically cleaned from the file name.
237    The actual error message from the file system will be captured and appended to the
238    message in any case.
239    
240        Could not open "/usr/spool/news/twitlog": file not found.
241    
242    In some versions of PERL the only error message we get is a number, which
243    corresponds to the C++ C<errno> value.
244    
245        Could not open "/usr/spool/news/twitlog": 6.
246    
247    =over 4
248    
249    =item fileHandle
250    
251    File handle. If this parameter is C<undef>, a file handle will be generated
252    and returned as the value of this method.
253    
254    =item fileSpec
255    
256    File name and mode, as per the PERL C<open> function.
257    
258    =item message (optional)
259    
260    Error message to use if the open fails. If omitted, a standard error message
261    will be generated. In either case, the error information from the file system
262    is appended to the message. To specify a conditional open that does not throw
263    an error if it fails, use C<0>.
264    
265    =item RETURN
266    
267    Returns the name of the file handle assigned to the file, or C<undef> if the
268    open failed.
269    
270    =back
271    
272    =cut
273    
274    sub Open {
275        # Get the parameters.
276        my ($fileHandle, $fileSpec, $message) = @_;
277        # Attempt to open the file.
278        my $rv = open $fileHandle, $fileSpec;
279        # If the open failed, generate an error message.
280        if (! $rv) {
281            # Save the system error message.
282            my $sysMessage = $!;
283            # See if we need a default message.
284            if (!$message) {
285                # Clean any obvious mode characters and leading spaces from the
286                # filename.
287                my ($fileName) = FindNamePart($fileSpec);
288                $message = "Could not open \"$fileName\"";
289            }
290            # Terminate with an error using the supplied message and the
291            # error message from the file system.
292            Confess("$message: $!");
293        }
294        # Return the file handle.
295        return $fileHandle;
296    }
297    
298    =head3 FindNamePart
299    
300    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
301    
302    Extract the portion of a file specification that contains the file name.
303    
304    A file specification is the string passed to an C<open> call. It specifies the file
305    mode and name. In a truly complex situation, it can specify a pipe sequence. This
306    method assumes that the file name is whatever follows the first angle bracket
307    sequence.  So, for example, in the following strings the file name is
308    C</usr/fig/myfile.txt>.
309    
310        >>/usr/fig/myfile.txt
311        </usr/fig/myfile.txt
312        | sort -u > /usr/fig/myfile.txt
313    
314    If the method cannot find a file name using its normal methods, it will return the
315    whole incoming string.
316    
317    =over 4
318    
319    =item fileSpec
320    
321    File specification string from which the file name is to be extracted.
322    
323    =item RETURN
324    
325    Returns a three-element list. The first element contains the file name portion of
326    the specified string, or the whole string if a file name cannot be found via normal
327    methods. The second element contains the start position of the file name portion and
328    the third element contains the length.
329    
330    =back
331    
332    =cut
333    #: Return Type $;
334    sub FindNamePart {
335        # Get the parameters.
336        my ($fileSpec) = @_;
337        # Default to the whole input string.
338        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
339        # Parse out the file name if we can.
340        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
341            $retVal = $2;
342            $len = length $retVal;
343            $pos = (length $fileSpec) - (length $3) - $len;
344        }
345        # Return the result.
346        return ($retVal, $pos, $len);
347    }
348    
349    =head3 OpenDir
350    
351    C<< my @files = OpenDir($dirName, $filtered); >>
352    
353    Open a directory and return all the file names. This function essentially performs
354    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
355    set to TRUE, all filenames beginning with a period (C<.>) will be filtered out of
356    the return list. If the directory does not open, an exception is thrown. So,
357    for example,
358    
359        my @files = OpenDir("/Volumes/fig/contigs", 1);
360    
361    is effectively the same as
362    
363        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
364        my @files = grep { $_ !~ /^\./ } readdir(TMP);
365    
366    Similarly, the following code
367    
368        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs");
369    
370    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
371    automatically throws an error if the directory fails to open.
372    
373    =over 4
374    
375    =item dirName
376    
377    Name of the directory to open.
378    
379    =item filtered
380    
381    TRUE if files whose names begin with a period (C<.>) should be automatically removed
382    from the list, else FALSE.
383    
384    =back
385    
386    =cut
387    #: Return Type @;
388    sub OpenDir {
389        # Get the parameters.
390        my ($dirName, $filtered) = @_;
391        # Declare the return variable.
392        my @retVal;
393        # Open the directory.
394        if (opendir(my $dirHandle, $dirName)) {
395            # The directory opened successfully. Get the appropriate list according to the
396            # strictures of the filter parameter.
397            if ($filtered) {
398                @retVal = grep { $_ !~ /^\./ } readdir $dirHandle;
399            } else {
400                @retVal = readdir $dirHandle;
401            }
402        } else {
403            # Here the directory would not open.
404            Confess("Could not open directory $dirName.");
405        }
406        # Return the result.
407        return @retVal;
408    }
409    
410    =head3 SetLevel
411    
412    C<< Tracer::SetLevel($newLevel); >>
413    
414    Modify the trace level. A higher trace level will cause more messages to appear.
415    
416    =over 4
417    
418    =item newLevel
419    
420    Proposed new trace level.
421    
422    =back
423    
424    =cut
425    
426    sub SetLevel {
427        $TraceLevel = $_[0];
428  }  }
429    
430  =head3 Now  =head3 Now
# Line 171  Line 472 
472          open STDERR, '>', $fileName;          open STDERR, '>', $fileName;
473  }  }
474    
475    =head3 ReadOptions
476    
477    C<< my %options = Tracer::ReadOptions($fileName); >>
478    
479    Read a set of options from a file. Each option is encoded in a line of text that has the
480    format
481    
482    I<optionName>C<=>I<optionValue>C<; >I<comment>
483    
484    The option name must consist entirely of letters, digits, and the punctuation characters
485    C<.> and C<_>, and is case sensitive. Blank lines and lines in which the first nonblank
486    character is a semi-colon will be ignored. The return hash will map each option name to
487    the corresponding option value.
488    
489    =over 4
490    
491    =item fileName
492    
493    Name of the file containing the option data.
494    
495    =item RETURN
496    
497    Returns a hash mapping the option names specified in the file to their corresponding option
498    value.
499    
500    =back
501    
502    =cut
503    
504    sub ReadOptions {
505        # Get the parameters.
506        my ($fileName) = @_;
507        # Open the file.
508        (open CONFIGFILE, "<$fileName") || Confess("Could not open option file $fileName.");
509        # Count the number of records read.
510        my ($records, $comments) = 0;
511        # Create the return hash.
512        my %retVal = ();
513        # Loop through the file, accumulating key-value pairs.
514        while (my $line = <CONFIGFILE>) {
515            # Denote we've read a line.
516            $records++;
517            # Determine the line type.
518            if ($line =~ /^\s*[\n\r]/) {
519                # A blank line is a comment.
520                $comments++;
521            } elsif ($line =~ /^\s*([A-Za-z0-9_\.]+)=([^;]*);/) {
522                # Here we have an option assignment.
523                retVal{$1} = $2;
524            } elsif ($line =~ /^\s*;/) {
525                # Here we have a text comment.
526                $comments++;
527            } else {
528                # Here we have an invalid line.
529                Trace("Invalid option statement in record $records.") if T(0);
530            }
531        }
532        # Return the hash created.
533        return %retVal;
534    }
535    
536  =head3 GetOptions  =head3 GetOptions
537    
538  C<< Tracer::GetOptions(\%defaults, \%options); >>  C<< Tracer::GetOptions(\%defaults, \%options); >>
# Line 288  Line 650 
650          my ($message) = @_;          my ($message) = @_;
651          # Get the timestamp.          # Get the timestamp.
652          my $timeStamp = Now();          my $timeStamp = Now();
653        # Format the message. Note we strip off any line terminators at the end.
654        my $formatted = "$timeStamp <$LastCategory>: " . Strip($message);
655          # Process according to the destination.          # Process according to the destination.
656          if ($Destination eq "TEXT") {          if ($Destination eq "TEXT") {
657                  # Write the message to the standard output.                  # Write the message to the standard output.
658                  print "$timeStamp $message\n";          print "$formatted\n";
659        } elsif ($Destination eq "ERROR") {
660            # Write the message to the error output.
661            print STDERR "$formatted\n";
662          } elsif ($Destination eq "QUEUE") {          } elsif ($Destination eq "QUEUE") {
663                  # Push the message into the queue.                  # Push the message into the queue.
664                  push @Queue, "$timeStamp $message";          push @Queue, "$formatted";
665          } elsif ($Destination eq "HTML") {          } elsif ($Destination eq "HTML") {
666                  # Convert the message to HTML and write it to the standard output.                  # Convert the message to HTML and write it to the standard output.
667                  my $escapedMessage = CGI::escapeHTML($message);                  my $escapedMessage = CGI::escapeHTML($message);
668                  print "<p>$timeStamp $message</p>\n";          print "<p>$formatted</p>\n";
669      } elsif ($Destination eq "WARN") {      } elsif ($Destination eq "WARN") {
670         # Emit the message as a warning.         # Emit the message as a warning.
671         warn $message;         warn $message;
672          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
673                  # Write the trace message to an output file.                  # Write the trace message to an output file.
674                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
675                  print TRACING "$timeStamp $message\n";          print TRACING "$formatted\n";
676                  close TRACING;                  close TRACING;
677            # If the Tee flag is on, echo it to the standard output.
678            if ($TeeFlag) {
679                print "$formatted\n";
680            }
681          }          }
682  }  }
683    
# Line 349  Line 720 
720                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
721                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
722                          # Here we have no category, so we need to get the calling package.                          # Here we have no category, so we need to get the calling package.
723                # The calling package is normally the first parameter. If it is
724                # omitted, the first parameter will be the tracelevel. So, the
725                # first thing we do is shift the so-called category into the
726                # $traceLevel variable where it belongs.
727                          $traceLevel = $category;                          $traceLevel = $category;
728                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
729              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 358  Line 733 
733                                  $category = $package;                                  $category = $package;
734                          }                          }
735                  }                  }
736                  # Use the package and tracelevel to compute the result.          # Save the category name.
737                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          $LastCategory = $category;
738            # Convert it to lower case before we hash it.
739            $category = lc $category;
740            # Use the category and tracelevel to compute the result.
741            $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
742      }      }
743          # Return the computed result.          # Return the computed result.
744      return $retVal;      return $retVal;
# Line 441  Line 820 
820          return ($optionTable, @retVal);          return ($optionTable, @retVal);
821  }  }
822    
823    =head3 Escape
824    
825    C<< my $codedString = Tracer::Escape($realString); >>
826    
827    Escape a string for use in a command length. Spaces will be replaced by C<\b>,
828    tabs replaced by C<\t>, new-lines replaced by C<\n>, and backslashes will be
829    doubled. The effect is to exactly reverse the effect of L</UnEscape>.
830    
831    =over 4
832    
833    =item realString
834    
835    String to escape.
836    
837    =item RETURN
838    
839    Escaped equivalent of the real string.
840    
841    =back
842    
843    =cut
844    
845    sub Escape {
846        # Get the parameter.
847        my ($realString) = @_;
848        # Initialize the return variable.
849        my $retVal = "";
850        # Loop through the parameter string, looking for sequences to escape.
851        while (length $realString > 0) {
852            # Look for the first sequence to escape.
853            if ($realString =~ /^(.*?)([ \n\t\\])/) {
854                # Here we found it. The text preceding the sequence is in $1. The sequence
855                # itself is in $2. First, move the clear text to the return variable.
856                $retVal .= $1;
857                # Strip the processed section off the real string.
858                $realString = substr $realString, (length $2) + (length $1);
859                # Encode the escape sequence.
860                my $char = $2;
861                $char =~ tr/ \t\n/btn/;
862                $retVal .= "\\" . $char;
863            } else {
864                # Here there are no more escape sequences. The rest of the string is
865                # transferred unmodified.
866                $retVal .= $realString;
867                $realString = "";
868            }
869        }
870        # Return the result.
871        return $retVal;
872    }
873    
874  =head3 UnEscape  =head3 UnEscape
875    
876  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
# Line 466  Line 896 
896  sub UnEscape {  sub UnEscape {
897          # Get the parameter.          # Get the parameter.
898          my ($codedString) = @_;          my ($codedString) = @_;
899        Tracer("Coded string is \"$codedString\".") if T(4);
900          # Initialize the return variable.          # Initialize the return variable.
901          my $retVal = "";          my $retVal = "";
902        # Only proceed if the incoming string is nonempty.
903        if (defined $codedString) {
904          # Loop through the parameter string, looking for escape sequences. We can't do          # Loop through the parameter string, looking for escape sequences. We can't do
905          # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\b" becomes
906          # "\ " no matter what we do.)          # "\ " no matter what we do.)
# Line 489  Line 922 
922                          $codedString = "";                          $codedString = "";
923                  }                  }
924          }          }
925        }
926          # Return the result.          # Return the result.
927          return $retVal;          return $retVal;
928  }  }
# Line 588  Line 1022 
1022    
1023  =head3 GetFile  =head3 GetFile
1024    
1025  C<< my $fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1026    
1027  Return the entire contents of a file.  Return the entire contents of a file.
1028    
# Line 600  Line 1034 
1034    
1035  =item RETURN  =item RETURN
1036    
1037  Returns the entire file as a single string. If an error occurs, will return  In a list context, returns the entire file as a list with the line terminators removed.
1038  an empty string.  In a scalar context, returns the entire file as a string.
1039    
1040  =back  =back
1041    
# Line 611  Line 1045 
1045          # Get the parameters.          # Get the parameters.
1046          my ($fileName) = @_;          my ($fileName) = @_;
1047          # Declare the return variable.          # Declare the return variable.
1048          my $retVal = "";      my @retVal = ();
1049          # Open the file for input.          # Open the file for input.
1050          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1051          if (!$ok) {          if (!$ok) {
1052                  # If we had an error, trace it. We will automatically return a null string.          # If we had an error, trace it. We will automatically return a null value.
1053                  Trace(0, "Could not open \"$fileName\" for input.");          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1054          } else {          } else {
1055                  # Read the whole file into the return variable.          # Read the whole file into the return variable, stripping off any terminator
1056                  while (<INPUTFILE>) {          # characters.
1057                          $retVal .= $_;          my $lineCount = 0;
1058            while (my $line = <INPUTFILE>) {
1059                $lineCount++;
1060                $line = Strip($line);
1061                push @retVal, $line;
1062                  }                  }
1063                  # Close it.                  # Close it.
1064                  close INPUTFILE;                  close INPUTFILE;
1065            my $actualLines = @retVal;
1066        }
1067        # Return the file's contents in the desired format.
1068        if (wantarray) {
1069            return @retVal;
1070        } else {
1071            return join "\n", @retVal;
1072          }          }
         # Return the file's contents.  
         return $retVal;  
1073  }  }
1074    
1075  =head3 QTrace  =head3 QTrace
# Line 650  Line 1093 
1093          my ($format) = @_;          my ($format) = @_;
1094          # Create the return variable.          # Create the return variable.
1095          my $retVal = "";          my $retVal = "";
1096        # Only proceed if there is an actual queue.
1097        if (@Queue) {
1098          # Process according to the format.          # Process according to the format.
1099          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1100                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 665  Line 1110 
1110          }          }
1111          # Clear the queue.          # Clear the queue.
1112          @Queue = ();          @Queue = ();
1113        }
1114          # Return the formatted list.          # Return the formatted list.
1115          return $retVal;          return $retVal;
1116  }  }
# Line 673  Line 1119 
1119    
1120  C<< Confess($message); >>  C<< Confess($message); >>
1121    
1122  Trace the call stack and abort the program with the specified message. The stack  Trace the call stack and abort the program with the specified message. When used with
1123  trace will only appear if the trace level for this package is 1 or more. When used with  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.
1124  the OR operator, this method can function as a debugging assert. So, for example  So, for example
1125    
1126  C<< ($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
1127    
1128  Will abort the program with a stack trace if the value of C<$recNum> is negative.  Will abort the program with a stack trace if the value of C<$recNum> is negative.
1129    
# Line 695  Line 1141 
1141          # Get the parameters.          # Get the parameters.
1142          my ($message) = @_;          my ($message) = @_;
1143          # Trace the call stack.          # Trace the call stack.
1144          Cluck($message) if T(1);      Cluck($message);
1145          # Abort the program.          # Abort the program.
1146          die $message;      croak(">>> $message");
1147    }
1148    
1149    =head3 Assert
1150    
1151    C<< Assert($condition1, $condition2, ... $conditionN); >>
1152    
1153    Return TRUE if all the conditions are true. This method can be used in conjunction with
1154    the OR operator and the L</Confess> method, B<Assert> can function as a debugging assert.
1155    So, for example
1156    
1157    C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
1158    
1159    Will abort the program with a stack trace if the value of C<$recNum> is negative.
1160    
1161    =cut
1162    sub Assert {
1163        my $retVal = 1;
1164        LOOP: for my $condition (@_) {
1165            if (! $condition) {
1166                $retVal = 0;
1167                last LOOP;
1168            }
1169        }
1170        return $retVal;
1171  }  }
1172    
1173  =head3 Cluck  =head3 Cluck
# Line 724  Line 1194 
1194  sub Cluck {  sub Cluck {
1195          # Get the parameters.          # Get the parameters.
1196          my ($message) = @_;          my ($message) = @_;
1197        # Trace what's happening.
1198        Trace("Stack trace for event: $message");
1199          my $confession = longmess($message);          my $confession = longmess($message);
1200          # Convert the confession to a series of trace messages.      # Convert the confession to a series of trace messages. Note we skip any
1201        # messages relating to calls into Tracer.
1202          for my $line (split /\s*\n/, $confession) {          for my $line (split /\s*\n/, $confession) {
1203                  Trace($line);          Trace($line) if ($line !~ /Tracer\.pm/);
1204        }
1205    }
1206    
1207    =head3 Min
1208    
1209    C<< my $min = Min($value1, $value2, ... $valueN); >>
1210    
1211    Return the minimum argument. The arguments are treated as numbers.
1212    
1213    =over 4
1214    
1215    =item $value1, $value2, ... $valueN
1216    
1217    List of numbers to compare.
1218    
1219    =item RETURN
1220    
1221    Returns the lowest number in the list.
1222    
1223    =back
1224    
1225    =cut
1226    
1227    sub Min {
1228        # Get the parameters. Note that we prime the return value with the first parameter.
1229        my ($retVal, @values) = @_;
1230        # Loop through the remaining parameters, looking for the lowest.
1231        for my $value (@values) {
1232            if ($value < $retVal) {
1233                $retVal = $value;
1234            }
1235        }
1236        # Return the minimum found.
1237        return $retVal;
1238    }
1239    
1240    =head3 Max
1241    
1242    C<< my $max = Max($value1, $value2, ... $valueN); >>
1243    
1244    Return the maximum argument. The arguments are treated as numbers.
1245    
1246    =over 4
1247    
1248    =item $value1, $value2, ... $valueN
1249    
1250    List of numbers to compare.
1251    
1252    =item RETURN
1253    
1254    Returns the highest number in the list.
1255    
1256    =back
1257    
1258    =cut
1259    
1260    sub Max {
1261        # Get the parameters. Note that we prime the return value with the first parameter.
1262        my ($retVal, @values) = @_;
1263        # Loop through the remaining parameters, looking for the highest.
1264        for my $value (@values) {
1265            if ($value > $retVal) {
1266                $retVal = $value;
1267            }
1268        }
1269        # Return the maximum found.
1270        return $retVal;
1271    }
1272    
1273    =head3 AddToListMap
1274    
1275    C<< Tracer::AddToListMap(\%hash, $key, $value); >>
1276    
1277    Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list
1278    is created for the key. Otherwise, the new value is pushed onto the list.
1279    
1280    =over 4
1281    
1282    =item hash
1283    
1284    Reference to the target hash.
1285    
1286    =item key
1287    
1288    Key for which the value is to be added.
1289    
1290    =item value
1291    
1292    Value to add to the key's value list.
1293    
1294    =back
1295    
1296    =cut
1297    
1298    sub AddToListMap {
1299        # Get the parameters.
1300        my ($hash, $key, $value) = @_;
1301        # Process according to whether or not the key already has a value.
1302        if (! exists $hash->{$key}) {
1303            $hash->{$key} = [$value];
1304        } else {
1305            push @{$hash->{$key}}, $value;
1306          }          }
1307  }  }
1308    
1309    =head3 DebugMode
1310    
1311    C<< if (Tracer::DebugMode) { ...code... } >>
1312    
1313    Return TRUE if debug mode has been turned on, else output an error
1314    page and return FALSE.
1315    
1316    Certain CGI scripts are too dangerous to exist in the production
1317    environment. This method provides a simple way to prevent them
1318    from working unless they are explicitly turned on by creating a password
1319    cookie via the B<SetPassword> script.  If debugging mode
1320    is not turned on, an error web page will be output directing the
1321    user to enter in the correct password.
1322    
1323    =cut
1324    
1325    sub DebugMode {
1326        # Declare the return variable.
1327        my $retVal = 0;
1328        # Check the debug configuration.
1329        my $password = CGI::cookie("DebugMode");
1330        my $encrypted = Digest::MD5::md5_hex($password);
1331        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1332            $retVal = 1;
1333        } else {
1334            # Here debug mode is off, so we generate an error page.
1335            my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");
1336            print $pageString;
1337        }
1338        # Return the determination indicator.
1339        return $retVal;
1340    }
1341    
1342    =head3 Strip
1343    
1344    C<< my $string = Tracer::Strip($line); >>
1345    
1346    Strip all line terminators off a string. This is necessary when dealing with files
1347    that may have been transferred back and forth several times among different
1348    operating environments.
1349    
1350    =over 4
1351    
1352    =item line
1353    
1354    Line of text to be stripped.
1355    
1356    =item RETURN
1357    
1358    The same line of text with all the line-ending characters chopped from the end.
1359    
1360    =back
1361    
1362    =cut
1363    
1364    sub Strip {
1365        # Get a copy of the parameter string.
1366        my ($string) = @_;
1367        my $retVal = $string;
1368        # Strip the line terminator characters.
1369        $retVal =~ s/(\r|\n)+$//g;
1370        # Return the result.
1371        return $retVal;
1372    }
1373    
1374    =head3 Pad
1375    
1376    C<< my $paddedString = Tracer::Pad($string, $len, $left, $padChar); >>
1377    
1378    Pad a string to a specified length. The pad character will be a
1379    space, and the padding will be on the right side unless specified
1380    in the third parameter.
1381    
1382    =over 4
1383    
1384    =item string
1385    
1386    String to be padded.
1387    
1388    =item len
1389    
1390    Desired length of the padded string.
1391    
1392    =item left (optional)
1393    
1394    TRUE if the string is to be left-padded; otherwise it will be padded on the right.
1395    
1396    =item padChar (optional)
1397    
1398    Character to use for padding. The default is a space.
1399    
1400    =item RETURN
1401    
1402    Returns a copy of the original string with the pad character added to the
1403    specified end so that it achieves the desired length.
1404    
1405    =back
1406    
1407    =cut
1408    
1409    sub Pad {
1410        # Get the parameters.
1411        my ($string, $len, $left, $padChar) = @_;
1412        # Compute the padding character.
1413        if (! defined $padChar) {
1414            $padChar = " ";
1415        }
1416        # Compute the number of spaces needed.
1417        my $needed = $len - length $string;
1418        # Copy the string into the return variable.
1419        my $retVal = $string;
1420        # Only proceed if padding is needed.
1421        if ($needed > 0) {
1422            # Create the pad string.
1423            my $pad = $padChar x $needed;
1424            # Affix it to the return value.
1425            if ($left) {
1426                $retVal = $pad . $retVal;
1427            } else {
1428                $retVal .= $pad;
1429            }
1430        }
1431        # Return the result.
1432        return $retVal;
1433    }
1434    
1435    =head3 TICK
1436    
1437    C<< my @results = TICK($commandString); >>
1438    
1439    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1440    dot-slash (C<./> will be removed. So, for example, if you were doing
1441    
1442        `./protein.cgi`
1443    
1444    from inside a CGI script, it would work fine in Unix, but would issue an error message
1445    in Windows complaining that C<'.'> is not a valid command. If instead you code
1446    
1447        TICK("./protein.cgi")
1448    
1449    it will work correctly in both environments.
1450    
1451    =over 4
1452    
1453    =item commandString
1454    
1455    The command string to pass to the system.
1456    
1457    =item RETURN
1458    
1459    Returns the standard output from the specified command, as a list.
1460    
1461    =back
1462    
1463    =cut
1464    #: Return Type @;
1465    sub TICK {
1466        # Get the parameters.
1467        my ($commandString) = @_;
1468        # Chop off the dot-slash if this is Windows.
1469        if ($FIG_Config::win_mode) {
1470            $commandString =~ s!^\./!!;
1471        }
1472        # Activate the command and return the result.
1473        return `$commandString`;
1474    }
1475    
1476  1;  1;

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.23

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3