[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.6, Mon Mar 7 02:01:51 2005 UTC revision 1.34, Fri Jan 6 05:34:21 2006 UTC
# Line 1  Line 1 
1    #
2    # Copyright (c) 2003-2006 University of Chicago and Fellowship
3    # for Interpretations of Genomes. All Rights Reserved.
4    #
5    # This file is part of the SEED Toolkit.
6    #
7    # The SEED Toolkit is free software. You can redistribute
8    # it and/or modify it under the terms of the SEED Toolkit
9    # Public License.
10    #
11    # You should have received a copy of the SEED Toolkit Public License
12    # along with this program; if not write to the University of Chicago
13    # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14    # Genomes at veronika@thefig.info or download a copy from
15    # http://www.theseed.org/LICENSE.TXT.
16    #
17    
18  package Tracer;  package Tracer;
19    
20          require Exporter;          require Exporter;
21          @ISA = ('Exporter');          @ISA = ('Exporter');
22          @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup);
23          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
24          use strict;          use strict;
25          use Carp qw(longmess croak);          use Carp qw(longmess croak);
26          use CGI;          use CGI;
27        use FIG_Config;
28        use PageBuilder;
29        use Digest::MD5;
30    
31  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
32    
# Line 18  Line 38 
38  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
39  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
40  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
41  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
42  appear. To generate a trace message, use the following syntax.  appear. To generate a trace message, use the following syntax.
43    
44  C<< Trace($message) if T(errors => 4); >>  C<< Trace($message) if T(errors => 4); >>
# Line 36  Line 56 
56    
57  C<< Trace($message) if T(2); >>  C<< Trace($message) if T(2); >>
58    
59  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
60  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
61  specified as a space-delimited string. Thus  specified as a space-delimited string. Thus
62    
63  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
64    
65  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
66  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.
67  input tracing configuration on a web form.  
68    To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
69    level 3 and writes the output to the standard error output. This sort of thing might be
70    useful in a CGI environment.
71    
72    C<< TSetup('3 *', 'WARN'); >>
73    
74  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
75  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 84 
84  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
85  being used out in the field.  being used out in the field.
86    
87    There is no hard and fast rule on how to use trace levels. The following is therefore only
88    a suggestion.
89    
90    =over 4
91    
92    =item Error 0
93    
94    Message indicates an error that may lead to incorrect results or that has stopped the
95    application entirely.
96    
97    =item Warning 1
98    
99    Message indicates something that is unexpected but that probably did not interfere
100    with program execution.
101    
102    =item Notice 2
103    
104    Message indicates the beginning or end of a major task.
105    
106    =item Information 3
107    
108    Message indicates a subtask. In the FIG system, a subtask generally relates to a single
109    genome. This would be a big loop that is not expected to execute more than 500 times or so.
110    
111    =item Detail 4
112    
113    Message indicates a low-level loop iteration.
114    
115    =back
116    
117  =cut  =cut
118    
119  # Declare the configuration variables.  # Declare the configuration variables.
120    
121  my $Destination = "NONE";       # Description of where to send the trace output.  my $Destination = "NONE";       # Description of where to send the trace output.
122    my $TeeFlag = 0;            # TRUE if output is going to a file and to the
123                                # standard output
124  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
125                                                          # hash of active category names                                                          # hash of active category names
126  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
127                                                          # messages                                                          # messages
128  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
129    my $LastCategory = "main";  # name of the last category interrogated
130    my $SetupCount = 0;         # number of times TSetup called
131    my $AllTrace = 0;           # TRUE if we are tracing all categories.
132    
133  =head2 Public Methods  =head2 Public Methods
134    
# Line 90  Line 150 
150    
151  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
152  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
153  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 ">"
154  the trace messages to a file, you can specify a special destination. C<HTML> will cause  symbol with a C<+> to echo output to a file AND to the standard output. In addition to
155  tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>  sending the trace messages to a file, you can specify a special destination. C<HTML> will
156    cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
157  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace
158  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace
159  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
# Line 110  Line 171 
171          my @categoryData = split /\s+/, $categoryList;          my @categoryData = split /\s+/, $categoryList;
172          # Extract the trace level.          # Extract the trace level.
173          $TraceLevel = shift @categoryData;          $TraceLevel = shift @categoryData;
174          # Build the category hash.      # Presume category-based tracing until we learn otherwise.
175        $AllTrace = 0;
176        # Build the category hash. Note that if we find a "*", we turn on non-category
177        # tracing. We must also clear away any pre-existing data.
178        %Categories = ( main => 1 );
179          for my $category (@categoryData) {          for my $category (@categoryData) {
180                  $Categories{$category} = 1;          if ($category eq '*') {
181                $AllTrace = 1;
182            } else {
183                $Categories{lc $category} = 1;
184            }
185          }          }
186          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
187          # 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
188          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
189        if ($target =~ m/^\+?>>?/) {
190            if ($target =~ m/^\+/) {
191                $TeeFlag = 1;
192                $target = substr($target, 1);
193            }
194          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
195                  open TRACEFILE, $target;                  open TRACEFILE, $target;
196                  print TRACEFILE Now() . " Tracing initialized.\n";                  print TRACEFILE Now() . " Tracing initialized.\n";
197                  close TRACEFILE;                  close TRACEFILE;
198                  $Destination = ">$target";                  $Destination = ">$target";
199          } else {          } else {
200                $Destination = $target;
201            }
202        } else {
203                  $Destination = uc($target);                  $Destination = uc($target);
204          }          }
205        # Increment the setup counter.
206        $SetupCount++;
207    }
208    
209    =head3 StandardSetup
210    
211    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, @ARGV); >>
212    
213    This method performs standard command-line parsing and tracing setup. The return
214    values are a hash of the command-line options and a list of the positional
215    parameters. Tracing is automatically set up and the command-line options are
216    validated.
217    
218    This is a complex method that does a lot of grunt work. The parameters can
219    be more easily understood, however, once they are examined individually.
220    
221    The I<categories> parameter is the most obtuse. It is a reference to a list of
222    special-purpose tracing categories. Most tracing categories are PERL package
223    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
224    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
225    
226        ["Sprout", "SproutLoad", "ERDB"]
227    
228    This would cause trace messages in the specified three packages to appear in
229    the output. There are threer special tracing categories that are automatically
230    handled by this method. In other words, if you used L</TSetup> you would need
231    to include these categories manually, but if you use this method they are turned
232    on automatically.
233    
234    =over 4
235    
236    =item FIG
237    
238    Turns on trace messages inside the B<FIG> package.
239    
240    =item SQL
241    
242    Traces SQL commands and activity.
243    
244    =item Tracer
245    
246    Traces error messages and call stacks.
247    
248    =back
249    
250    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
251    The trace level is specified using the C<-trace> command-line option. For example,
252    the following command line for C<TransactFeatures> turns on SQL tracing and runs
253    all tracing at level 3.
254    
255        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
256    
257    Standard tracing is output to the standard output and echoed to the file
258    C<trace.log> in the FIG temporary directory.
259    
260    The default trace level is 3. This dumps out all SQL commands if SQL tracing
261    is turned on and tends to produce one flurry of messages per genome. To get all
262    messages, specify a trace level of 4. For generally quiet output, use 2.
263    
264    The I<options> parameter is a reference to a hash containing the command-line
265    options and their default values. Command-line options may be in the form of switches
266    or keywords. In the case of a switch, the option value is 1 if it is specified and
267    0 if it is not specified. In the case of a keyword, the value is separated from the
268    option name by an equal sign. You can see this last in the command-line example above.
269    
270    An example at this point would help. Consider, for example, the command-line utility
271    C<TransactFeatures>. It accepts a list of positional parameters plus the options
272    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
273    the following code.
274    
275        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
276                                                          { trace => 3, sql => 0,
277                                                            safe => 0, noAlias => 0,
278                                                            start => ' ', tblFiles => 0},
279                                                        @ARGV);
280    
281    
282    The call to C<ParseCommand> specifies the default values for the options and
283    stores the actual options in a hash that is returned as C<$options>. The
284    positional parameters are returned in C<@parameters>.
285    
286    The following is a sample command line for C<TransactFeatures>.
287    
288        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
289    
290    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
291    parameters, and would find themselves in I<@parameters> after executing the
292    above code fragment. The tracing would be set to level 2, and the categories
293    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
294    and C<DocUtils> was included because it came in within the first parameter
295    to this method. The I<$options> hash would be
296    
297        { trace => 2, sql => 0, safe => 0,
298          noAlias => 1, start => ' ', tblFiles => 0 }
299    
300    Use of C<StandardSetup> in this way provides a simple way of performing
301    standard tracing setup and command-line parsing. Note that the caller is
302    not even aware of the command-line switches C<-trace> and C<-sql>, which
303    are used by this method to control the tracing. If additional tracing features
304    need to be added in the future, they can be processed by this method without
305    upsetting the command-line utilities.
306    
307    The parameters to this method are as follows.
308    
309    =over 4
310    
311    =item categories
312    
313    Reference to a list of tracing category names. These should be names of
314    packages whose internal workings will need to be debugged to get the
315    command working.
316    
317    =item options
318    
319    Reference to a hash containing the legal options for the current command mapped
320    to their default values. The use can override the defaults by specifying the
321    options as command-line switches prefixed by a hyphen. Tracing-related options
322    may be added to this hash.
323    
324    =item ARGV
325    
326    List of command line parameters, including the option switches, which must
327    precede the positional parameters and be prefixed by a hyphen.
328    
329    =item RETURN
330    
331    Returns a list. The first element of the list is the reference to a hash that
332    maps the command-line option switches to their values. These will either be the
333    default values or overrides specified on the command line. The remaining
334    elements of the list are the position parameters, in order.
335    
336    =back
337    
338    =cut
339    
340    sub StandardSetup {
341        # Get the parameters.
342        my ($categories, $options, @argv) = @_;
343        # Add the tracing options.
344        $options->{trace} = 3;
345        $options->{sql} = 0;
346        # Parse the command line.
347        my ($retOptions, @retParameters) = ParseCommand($options, @argv);
348        # Now we want to set up tracing. First, we need to know if SQL is to
349        # be traced.
350        my @cats = @{$categories};
351        if ($retOptions->{sql}) {
352            push @cats, "SQL";
353        }
354        # Add the default categories.
355        push @cats, "Tracer", "FIG";
356        # Next, we create the category string by prefixing the trace level
357        # and joining the categories.
358        my $cats = join(" ", $options->{trace}, @cats);
359        # Now set up the tracing.
360        TSetup($cats, "+>$FIG_Config::temp/trace.log");
361        # Return the parsed parameters.
362        return ($retOptions, @retParameters);
363    }
364    
365    =head3 Setups
366    
367    C<< my $count = Tracer::Setups(); >>
368    
369    Return the number of times L</TSetup> has been called.
370    
371    This method allows for the creation of conditional tracing setups where, for example, we
372    may want to set up tracing if nobody else has done it before us.
373    
374    =cut
375    
376    sub Setups {
377        return $SetupCount;
378    }
379    
380    =head3 Open
381    
382    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
383    
384    Open a file.
385    
386    The I<$fileSpec> is essentially the second argument of the PERL C<open>
387    function. The mode is specified using Unix-like shell information. So, for
388    example,
389    
390        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
391    
392    would open for output appended to the specified file, and
393    
394        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
395    
396    would open a pipe that sorts the records written and removes duplicates. Note
397    the use of file handle syntax in the Open call. To use anonymous file handles,
398    code as follows.
399    
400        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
401    
402    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
403    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
404    failed open will throw an exception and the third parameter will be used to construct
405    an error message. If the parameter is omitted, a standard message is constructed
406    using the file spec.
407    
408        Could not open "/usr/spool/news/twitlog"
409    
410    Note that the mode characters are automatically cleaned from the file name.
411    The actual error message from the file system will be captured and appended to the
412    message in any case.
413    
414        Could not open "/usr/spool/news/twitlog": file not found.
415    
416    In some versions of PERL the only error message we get is a number, which
417    corresponds to the C++ C<errno> value.
418    
419        Could not open "/usr/spool/news/twitlog": 6.
420    
421    =over 4
422    
423    =item fileHandle
424    
425    File handle. If this parameter is C<undef>, a file handle will be generated
426    and returned as the value of this method.
427    
428    =item fileSpec
429    
430    File name and mode, as per the PERL C<open> function.
431    
432    =item message (optional)
433    
434    Error message to use if the open fails. If omitted, a standard error message
435    will be generated. In either case, the error information from the file system
436    is appended to the message. To specify a conditional open that does not throw
437    an error if it fails, use C<0>.
438    
439    =item RETURN
440    
441    Returns the name of the file handle assigned to the file, or C<undef> if the
442    open failed.
443    
444    =back
445    
446    =cut
447    
448    sub Open {
449        # Get the parameters.
450        my ($fileHandle, $fileSpec, $message) = @_;
451        # Attempt to open the file.
452        my $rv = open $fileHandle, $fileSpec;
453        # If the open failed, generate an error message.
454        if (! $rv) {
455            # Save the system error message.
456            my $sysMessage = $!;
457            # See if we need a default message.
458            if (!$message) {
459                # Clean any obvious mode characters and leading spaces from the
460                # filename.
461                my ($fileName) = FindNamePart($fileSpec);
462                $message = "Could not open \"$fileName\"";
463            }
464            # Terminate with an error using the supplied message and the
465            # error message from the file system.
466            Confess("$message: $!");
467        }
468        # Return the file handle.
469        return $fileHandle;
470    }
471    
472    =head3 FindNamePart
473    
474    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
475    
476    Extract the portion of a file specification that contains the file name.
477    
478    A file specification is the string passed to an C<open> call. It specifies the file
479    mode and name. In a truly complex situation, it can specify a pipe sequence. This
480    method assumes that the file name is whatever follows the first angle bracket
481    sequence.  So, for example, in the following strings the file name is
482    C</usr/fig/myfile.txt>.
483    
484        >>/usr/fig/myfile.txt
485        </usr/fig/myfile.txt
486        | sort -u > /usr/fig/myfile.txt
487    
488    If the method cannot find a file name using its normal methods, it will return the
489    whole incoming string.
490    
491    =over 4
492    
493    =item fileSpec
494    
495    File specification string from which the file name is to be extracted.
496    
497    =item RETURN
498    
499    Returns a three-element list. The first element contains the file name portion of
500    the specified string, or the whole string if a file name cannot be found via normal
501    methods. The second element contains the start position of the file name portion and
502    the third element contains the length.
503    
504    =back
505    
506    =cut
507    #: Return Type $;
508    sub FindNamePart {
509        # Get the parameters.
510        my ($fileSpec) = @_;
511        # Default to the whole input string.
512        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
513        # Parse out the file name if we can.
514        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
515            $retVal = $2;
516            $len = length $retVal;
517            $pos = (length $fileSpec) - (length $3) - $len;
518        }
519        # Return the result.
520        return ($retVal, $pos, $len);
521    }
522    
523    =head3 OpenDir
524    
525    C<< my @files = OpenDir($dirName, $filtered, $flag); >>
526    
527    Open a directory and return all the file names. This function essentially performs
528    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
529    set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
530    or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
531    filtered out of the return list. If the directory does not open and I<$flag> is not
532    set, an exception is thrown. So, for example,
533    
534        my @files = OpenDir("/Volumes/fig/contigs", 1);
535    
536    is effectively the same as
537    
538        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
539        my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
540    
541    Similarly, the following code
542    
543        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
544    
545    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
546    automatically returns an empty list if the directory fails to open.
547    
548    =over 4
549    
550    =item dirName
551    
552    Name of the directory to open.
553    
554    =item filtered
555    
556    TRUE if files whose names begin with a period (C<.>) should be automatically removed
557    from the list, else FALSE.
558    
559    =item flag
560    
561    TRUE if a failure to open is okay, else FALSE
562    
563    =back
564    
565    =cut
566    #: Return Type @;
567    sub OpenDir {
568        # Get the parameters.
569        my ($dirName, $filtered, $flag) = @_;
570        # Declare the return variable.
571        my @retVal = ();
572        # Open the directory.
573        if (opendir(my $dirHandle, $dirName)) {
574            # The directory opened successfully. Get the appropriate list according to the
575            # strictures of the filter parameter.
576            if ($filtered) {
577                @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
578            } else {
579                @retVal = readdir $dirHandle;
580            }
581        } elsif (! $flag) {
582            # Here the directory would not open and it's considered an error.
583            Confess("Could not open directory $dirName.");
584        }
585        # Return the result.
586        return @retVal;
587  }  }
588    
589  =head3 SetLevel  =head3 SetLevel
# Line 370  Line 829 
829          my ($message) = @_;          my ($message) = @_;
830          # Get the timestamp.          # Get the timestamp.
831          my $timeStamp = Now();          my $timeStamp = Now();
832          # Format the message.      # Format the message. Note we strip off any line terminators at the end.
833          my $formatted = "$timeStamp $message";      my $formatted = "$timeStamp <$LastCategory>: " . Strip($message);
834          # Process according to the destination.          # Process according to the destination.
835          if ($Destination eq "TEXT") {          if ($Destination eq "TEXT") {
836                  # Write the message to the standard output.                  # Write the message to the standard output.
# Line 391  Line 850 
850         warn $message;         warn $message;
851          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
852                  # Write the trace message to an output file.                  # Write the trace message to an output file.
853                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
854                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
855                  close TRACING;                  close TRACING;
856            # If the Tee flag is on, echo it to the standard output.
857            if ($TeeFlag) {
858                print "$formatted\n";
859            }
860          }          }
861  }  }
862    
# Line 436  Line 899 
899                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
900                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
901                          # 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.
902                # The calling package is normally the first parameter. If it is
903                # omitted, the first parameter will be the tracelevel. So, the
904                # first thing we do is shift the so-called category into the
905                # $traceLevel variable where it belongs.
906                          $traceLevel = $category;                          $traceLevel = $category;
907                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
908              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 445  Line 912 
912                                  $category = $package;                                  $category = $package;
913                          }                          }
914                  }                  }
915                  # Use the package and tracelevel to compute the result.          # Save the category name.
916                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          $LastCategory = $category;
917            # Convert it to lower case before we hash it.
918            $category = lc $category;
919            # Use the category and tracelevel to compute the result.
920            $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
921      }      }
922          # Return the computed result.          # Return the computed result.
923      return $retVal;      return $retVal;
# Line 528  Line 999 
999          return ($optionTable, @retVal);          return ($optionTable, @retVal);
1000  }  }
1001    
1002    =head3 Escape
1003    
1004    C<< my $codedString = Tracer::Escape($realString); >>
1005    
1006    Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1007    replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1008    result is to reverse the effect of L</UnEscape>.
1009    
1010    =over 4
1011    
1012    =item realString
1013    
1014    String to escape.
1015    
1016    =item RETURN
1017    
1018    Escaped equivalent of the real string.
1019    
1020    =back
1021    
1022    =cut
1023    
1024    sub Escape {
1025        # Get the parameter.
1026        my ($realString) = @_;
1027        # Initialize the return variable.
1028        my $retVal = "";
1029        # Loop through the parameter string, looking for sequences to escape.
1030        while (length $realString > 0) {
1031            # Look for the first sequence to escape.
1032            if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1033                # Here we found it. The text preceding the sequence is in $1. The sequence
1034                # itself is in $2. First, move the clear text to the return variable.
1035                $retVal .= $1;
1036                # Strip the processed section off the real string.
1037                $realString = substr $realString, (length $2) + (length $1);
1038                # Get the matched character.
1039                my $char = $2;
1040                # If we have a CR, we are done.
1041                if ($char ne "\r") {
1042                    # It's not a CR, so encode the escape sequence.
1043                    $char =~ tr/\t\n/tn/;
1044                    $retVal .= "\\" . $char;
1045                }
1046            } else {
1047                # Here there are no more escape sequences. The rest of the string is
1048                # transferred unmodified.
1049                $retVal .= $realString;
1050                $realString = "";
1051            }
1052        }
1053        # Return the result.
1054        return $retVal;
1055    }
1056    
1057  =head3 UnEscape  =head3 UnEscape
1058    
1059  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1060    
1061  Replace escape sequences with their actual equivalents. C<\b> will be replaced by a space,  Replace escape sequences with their actual equivalents. C<\t> will be replaced by
1062  C<\t> by a tab, C<\n> by a new-line character, and C<\\> by a back-slash.  a tab, C<\n> by a new-line character, and C<\\> by a backslash. C<\r> codes will
1063    be deleted.
1064    
1065  =over 4  =over 4
1066    
# Line 555  Line 1082 
1082          my ($codedString) = @_;          my ($codedString) = @_;
1083          # Initialize the return variable.          # Initialize the return variable.
1084          my $retVal = "";          my $retVal = "";
1085        # Only proceed if the incoming string is nonempty.
1086        if (defined $codedString) {
1087          # 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
1088          # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1089          # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1090          while (length $codedString > 0) {          while (length $codedString > 0) {
1091                  # Look for the first escape sequence.                  # Look for the first escape sequence.
1092                  if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1093                          # Here we found it. The text preceding the sequence is in $1. The sequence                          # Here we found it. The text preceding the sequence is in $1. The sequence
1094                          # itself is in $2. First, move the clear text to the return variable.                          # itself is in $2. First, move the clear text to the return variable.
1095                          $retVal .= $1;                          $retVal .= $1;
1096                          $codedString = substr $codedString, (2 + length $1);                          $codedString = substr $codedString, (2 + length $1);
1097                          # Decode the escape sequence.                  # Get the escape value.
1098                          my $char = $2;                          my $char = $2;
1099                          $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1100                    if ($char ne 'r') {
1101                        # Here it's not an 'r', so we convert it.
1102                        $char =~ tr/\\tn/\\\t\n/;
1103                          $retVal .= $char;                          $retVal .= $char;
1104                    }
1105                  } else {                  } else {
1106                          # Here there are no more escape sequences. The rest of the string is                          # Here there are no more escape sequences. The rest of the string is
1107                          # transferred unmodified.                          # transferred unmodified.
# Line 576  Line 1109 
1109                          $codedString = "";                          $codedString = "";
1110                  }                  }
1111          }          }
1112        }
1113          # Return the result.          # Return the result.
1114          return $retVal;          return $retVal;
1115  }  }
# Line 703  Line 1237 
1237          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1238          if (!$ok) {          if (!$ok) {
1239                  # If we had an error, trace it. We will automatically return a null value.                  # If we had an error, trace it. We will automatically return a null value.
1240                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1241          } else {          } else {
1242                  # Read the whole file into the return variable, stripping off an terminator          # Read the whole file into the return variable, stripping off any terminator
1243          # characters.          # characters.
1244          my $lineCount = 0;          my $lineCount = 0;
1245                  while (my $line = <INPUTFILE>) {                  while (my $line = <INPUTFILE>) {
1246              $lineCount++;              $lineCount++;
1247              $line =~ s/(\r|\n)+$//g;              $line = Strip($line);
1248                          push @retVal, $line;                          push @retVal, $line;
1249                  }                  }
1250                  # Close it.                  # Close it.
1251                  close INPUTFILE;                  close INPUTFILE;
1252          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(0);  
1253          }          }
1254          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1255      if (wantarray) {      if (wantarray) {
# Line 747  Line 1280 
1280          my ($format) = @_;          my ($format) = @_;
1281          # Create the return variable.          # Create the return variable.
1282          my $retVal = "";          my $retVal = "";
1283        # Only proceed if there is an actual queue.
1284        if (@Queue) {
1285          # Process according to the format.          # Process according to the format.
1286          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1287                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 762  Line 1297 
1297          }          }
1298          # Clear the queue.          # Clear the queue.
1299          @Queue = ();          @Queue = ();
1300        }
1301          # Return the formatted list.          # Return the formatted list.
1302          return $retVal;          return $retVal;
1303  }  }
# Line 770  Line 1306 
1306    
1307  C<< Confess($message); >>  C<< Confess($message); >>
1308    
1309  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
 trace will only appear if the trace level for this package is 1 or more. When used with  
1310  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.
1311  So, for example  So, for example
1312    
# Line 793  Line 1328 
1328          # Get the parameters.          # Get the parameters.
1329          my ($message) = @_;          my ($message) = @_;
1330          # Trace the call stack.          # Trace the call stack.
1331          Cluck($message) if T(1);      Cluck($message);
1332          # Abort the program.          # Abort the program.
1333          croak(">>> $message");          croak(">>> $message");
1334  }  }
# Line 803  Line 1338 
1338  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1339    
1340  Return TRUE if all the conditions are true. This method can be used in conjunction with  Return TRUE if all the conditions are true. This method can be used in conjunction with
1341  the OR operator and the L</Confess> method, B<Assert> can function as a debugging assert.  the OR operator and the L</Confess> method as a debugging assert.
1342  So, for example  So, for example
1343    
1344  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 958  Line 1493 
1493      }      }
1494  }  }
1495    
1496    =head3 DebugMode
1497    
1498    C<< if (Tracer::DebugMode) { ...code... } >>
1499    
1500    Return TRUE if debug mode has been turned on, else output an error
1501    page and return FALSE.
1502    
1503    Certain CGI scripts are too dangerous to exist in the production
1504    environment. This method provides a simple way to prevent them
1505    from working unless they are explicitly turned on by creating a password
1506    cookie via the B<SetPassword> script.  If debugging mode
1507    is not turned on, an error web page will be output directing the
1508    user to enter in the correct password.
1509    
1510    =cut
1511    
1512    sub DebugMode {
1513        # Declare the return variable.
1514        my $retVal = 0;
1515        # Check the debug configuration.
1516        my $password = CGI::cookie("DebugMode");
1517        my $encrypted = Digest::MD5::md5_hex($password);
1518        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1519            $retVal = 1;
1520        } else {
1521            # Here debug mode is off, so we generate an error page.
1522            my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");
1523            print $pageString;
1524        }
1525        # Return the determination indicator.
1526        return $retVal;
1527    }
1528    
1529    =head3 Strip
1530    
1531    C<< my $string = Tracer::Strip($line); >>
1532    
1533    Strip all line terminators off a string. This is necessary when dealing with files
1534    that may have been transferred back and forth several times among different
1535    operating environments.
1536    
1537    =over 4
1538    
1539    =item line
1540    
1541    Line of text to be stripped.
1542    
1543    =item RETURN
1544    
1545    The same line of text with all the line-ending characters chopped from the end.
1546    
1547    =back
1548    
1549    =cut
1550    
1551    sub Strip {
1552        # Get a copy of the parameter string.
1553        my ($string) = @_;
1554        my $retVal = (defined $string ? $string : "");
1555        # Strip the line terminator characters.
1556        $retVal =~ s/(\r|\n)+$//g;
1557        # Return the result.
1558        return $retVal;
1559    }
1560    
1561    =head3 Pad
1562    
1563    C<< my $paddedString = Tracer::Pad($string, $len, $left, $padChar); >>
1564    
1565    Pad a string to a specified length. The pad character will be a
1566    space, and the padding will be on the right side unless specified
1567    in the third parameter.
1568    
1569    =over 4
1570    
1571    =item string
1572    
1573    String to be padded.
1574    
1575    =item len
1576    
1577    Desired length of the padded string.
1578    
1579    =item left (optional)
1580    
1581    TRUE if the string is to be left-padded; otherwise it will be padded on the right.
1582    
1583    =item padChar (optional)
1584    
1585    Character to use for padding. The default is a space.
1586    
1587    =item RETURN
1588    
1589    Returns a copy of the original string with the pad character added to the
1590    specified end so that it achieves the desired length.
1591    
1592    =back
1593    
1594    =cut
1595    
1596    sub Pad {
1597        # Get the parameters.
1598        my ($string, $len, $left, $padChar) = @_;
1599        # Compute the padding character.
1600        if (! defined $padChar) {
1601            $padChar = " ";
1602        }
1603        # Compute the number of spaces needed.
1604        my $needed = $len - length $string;
1605        # Copy the string into the return variable.
1606        my $retVal = $string;
1607        # Only proceed if padding is needed.
1608        if ($needed > 0) {
1609            # Create the pad string.
1610            my $pad = $padChar x $needed;
1611            # Affix it to the return value.
1612            if ($left) {
1613                $retVal = $pad . $retVal;
1614            } else {
1615                $retVal .= $pad;
1616            }
1617        }
1618        # Return the result.
1619        return $retVal;
1620    }
1621    
1622    =head3 EOF
1623    
1624    This is a constant that is lexically greater than any useful string.
1625    
1626    =cut
1627    
1628    sub EOF {
1629        return "\xFF\xFF\xFF\xFF\xFF";
1630    }
1631    
1632    =head3 TICK
1633    
1634    C<< my @results = TICK($commandString); >>
1635    
1636    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1637    dot-slash (C<./> will be removed. So, for example, if you were doing
1638    
1639        `./protein.cgi`
1640    
1641    from inside a CGI script, it would work fine in Unix, but would issue an error message
1642    in Windows complaining that C<'.'> is not a valid command. If instead you code
1643    
1644        TICK("./protein.cgi")
1645    
1646    it will work correctly in both environments.
1647    
1648    =over 4
1649    
1650    =item commandString
1651    
1652    The command string to pass to the system.
1653    
1654    =item RETURN
1655    
1656    Returns the standard output from the specified command, as a list.
1657    
1658    =back
1659    
1660    =cut
1661    #: Return Type @;
1662    sub TICK {
1663        # Get the parameters.
1664        my ($commandString) = @_;
1665        # Chop off the dot-slash if this is Windows.
1666        if ($FIG_Config::win_mode) {
1667            $commandString =~ s!^\./!!;
1668        }
1669        # Activate the command and return the result.
1670        return `$commandString`;
1671    }
1672    
1673  1;  1;

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.34

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3