[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.9, Wed May 4 03:05:12 2005 UTC revision 1.36, Sun Jan 15 21:27:33 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 ScriptSetup ScriptFinish);
23          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);          @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;          use FIG_Config;
28      use PageBuilder;      use PageBuilder;
29        use Digest::MD5;
30        use File::Basename;
31    
32  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
33    
# Line 20  Line 39 
39  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
40  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
41  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
42  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
43  appear. To generate a trace message, use the following syntax.  appear. To generate a trace message, use the following syntax.
44    
45  C<< Trace($message) if T(errors => 4); >>  C<< Trace($message) if T(errors => 4); >>
# Line 38  Line 57 
57    
58  C<< Trace($message) if T(2); >>  C<< Trace($message) if T(2); >>
59    
60  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
61  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
62  specified as a space-delimited string. Thus  specified as a space-delimited string. Thus
63    
64  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
65    
66  sets the trace level to 3, activates 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
67  specifies that messages should be output as HTML paragraphs. The parameters are formatted  specifies that messages should be output as HTML paragraphs.
68  to make it easier to input tracing configuration on a web form.  
69    To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
70    level 3 and writes the output to the standard error output. This sort of thing might be
71    useful in a CGI environment.
72    
73    C<< TSetup('3 *', 'WARN'); >>
74    
75  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
76  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 61  Line 85 
85  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
86  being used out in the field.  being used out in the field.
87    
88    There is no hard and fast rule on how to use trace levels. The following is therefore only
89    a suggestion.
90    
91    =over 4
92    
93    =item Error 0
94    
95    Message indicates an error that may lead to incorrect results or that has stopped the
96    application entirely.
97    
98    =item Warning 1
99    
100    Message indicates something that is unexpected but that probably did not interfere
101    with program execution.
102    
103    =item Notice 2
104    
105    Message indicates the beginning or end of a major task.
106    
107    =item Information 3
108    
109    Message indicates a subtask. In the FIG system, a subtask generally relates to a single
110    genome. This would be a big loop that is not expected to execute more than 500 times or so.
111    
112    =item Detail 4
113    
114    Message indicates a low-level loop iteration.
115    
116    =back
117    
118  =cut  =cut
119    
120  # Declare the configuration variables.  # Declare the configuration variables.
121    
122  my $Destination = "NONE";       # Description of where to send the trace output.  my $Destination = "NONE";       # Description of where to send the trace output.
123    my $TeeFlag = 0;            # TRUE if output is going to a file and to the
124                                # standard output
125  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
126                                                          # hash of active category names                                                          # hash of active category names
127  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
128                                                          # messages                                                          # messages
129  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
130  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
131    my $SetupCount = 0;         # number of times TSetup called
132    my $AllTrace = 0;           # TRUE if we are tracing all categories.
133    
134  =head2 Public Methods  =head2 Public Methods
135    
# Line 93  Line 151 
151    
152  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
153  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
154  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 ">"
155  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
156  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
157    cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
158  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
159  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
160  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 113  Line 172 
172          my @categoryData = split /\s+/, $categoryList;          my @categoryData = split /\s+/, $categoryList;
173          # Extract the trace level.          # Extract the trace level.
174          $TraceLevel = shift @categoryData;          $TraceLevel = shift @categoryData;
175          # Build the category hash.      # Presume category-based tracing until we learn otherwise.
176        $AllTrace = 0;
177        # Build the category hash. Note that if we find a "*", we turn on non-category
178        # tracing. We must also clear away any pre-existing data.
179        %Categories = ( main => 1 );
180          for my $category (@categoryData) {          for my $category (@categoryData) {
181                  $Categories{$category} = 1;          if ($category eq '*') {
182                $AllTrace = 1;
183            } else {
184                $Categories{lc $category} = 1;
185            }
186          }          }
187          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
188          # 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
189          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
190        if ($target =~ m/^\+?>>?/) {
191            if ($target =~ m/^\+/) {
192                $TeeFlag = 1;
193                $target = substr($target, 1);
194            }
195          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
196                  open TRACEFILE, $target;                  open TRACEFILE, $target;
197                  print TRACEFILE Now() . " Tracing initialized.\n";                  print TRACEFILE Now() . " Tracing initialized.\n";
198                  close TRACEFILE;                  close TRACEFILE;
199                  $Destination = ">$target";                  $Destination = ">$target";
200          } else {          } else {
201                $Destination = $target;
202            }
203        } else {
204                  $Destination = uc($target);                  $Destination = uc($target);
205          }          }
206        # Increment the setup counter.
207        $SetupCount++;
208    }
209    
210    =head3 StandardSetup
211    
212    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
213    
214    This method performs standard command-line parsing and tracing setup. The return
215    values are a hash of the command-line options and a list of the positional
216    parameters. Tracing is automatically set up and the command-line options are
217    validated.
218    
219    This is a complex method that does a lot of grunt work. The parameters can
220    be more easily understood, however, once they are examined individually.
221    
222    The I<categories> parameter is the most obtuse. It is a reference to a list of
223    special-purpose tracing categories. Most tracing categories are PERL package
224    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
225    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
226    
227        ["Sprout", "SproutLoad", "ERDB"]
228    
229    This would cause trace messages in the specified three packages to appear in
230    the output. There are threer special tracing categories that are automatically
231    handled by this method. In other words, if you used L</TSetup> you would need
232    to include these categories manually, but if you use this method they are turned
233    on automatically.
234    
235    =over 4
236    
237    =item FIG
238    
239    Turns on trace messages inside the B<FIG> package.
240    
241    =item SQL
242    
243    Traces SQL commands and activity.
244    
245    =item Tracer
246    
247    Traces error messages and call stacks.
248    
249    =back
250    
251    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
252    The trace level is specified using the C<-trace> command-line option. For example,
253    the following command line for C<TransactFeatures> turns on SQL tracing and runs
254    all tracing at level 3.
255    
256        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
257    
258    Standard tracing is output to the standard output and echoed to the file
259    C<trace.log> in the FIG temporary directory.
260    
261    The default trace level is 2. To get all messages, specify a trace level of 4.
262    For a genome-by-genome update, use 3.
263    
264    The I<options> parameter is a reference to a hash containing the command-line
265    options, their default values, and an explanation of what they mean. Command-line
266    options may be in the form of switches or keywords. In the case of a switch, the
267    option value is 1 if it is specified and 0 if it is not specified. In the case
268    of a keyword, the value is separated from the option name by an equal sign. You
269    can see this last in the command-line example above.
270    
271    An example at this point would help. Consider, for example, the command-line utility
272    C<TransactFeatures>. It accepts a list of positional parameters plus the options
273    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
274    the following code.
275    
276        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
277                            { safe => [0, "use database transactions"],
278                              noAlias => [0, "do not expect aliases in CHANGE transactions"],
279                              start => [' ', "start with this genome"],
280                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
281                            "command transactionDirectory IDfile",
282                          @ARGV);
283    
284    
285    The call to C<ParseCommand> specifies the default values for the options and
286    stores the actual options in a hash that is returned as C<$options>. The
287    positional parameters are returned in C<@parameters>.
288    
289    The following is a sample command line for C<TransactFeatures>.
290    
291        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
292    
293    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
294    parameters, and would find themselves in I<@parameters> after executing the
295    above code fragment. The tracing would be set to level 2, and the categories
296    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
297    and C<DocUtils> was included because it came in within the first parameter
298    to this method. The I<$options> hash would be
299    
300        { trace => 2, sql => 0, safe => 0,
301          noAlias => 1, start => ' ', tblFiles => 0 }
302    
303    Use of C<StandardSetup> in this way provides a simple way of performing
304    standard tracing setup and command-line parsing. Note that the caller is
305    not even aware of the command-line switches C<-trace> and C<-sql>, which
306    are used by this method to control the tracing. If additional tracing features
307    need to be added in the future, they can be processed by this method without
308    upsetting the command-line utilities.
309    
310    Finally, if the special option C<-h> is specified, the option names will
311    be traced at level 0 and the program will exit without processing.
312    This provides a limited help capability. For example, if the user enters
313    
314        TransactFeatures -h
315    
316    he would see the following output.
317    
318        TransactFeatures [options] command transactionDirectory IDfile
319            -trace    tracing level (default 2)
320            -sql      trace SQL commands
321            -safe     use database transactions
322            -noAlias  do not expect aliases in CHANGE transactions
323            -start    start with this genome
324            -tblFiles output TBL files containing the corrected IDs
325    
326    The parameters to this method are as follows.
327    
328    =over 4
329    
330    =item categories
331    
332    Reference to a list of tracing category names. These should be names of
333    packages whose internal workings will need to be debugged to get the
334    command working.
335    
336    =item options
337    
338    Reference to a hash containing the legal options for the current command mapped
339    to their default values and descriptions. The user can override the defaults
340    by specifying the options as command-line switches prefixed by a hyphen.
341    Tracing-related options may be added to this hash. If the C<-h> option is
342    specified on the command line, the option descriptions will be used to
343    explain the options.
344    
345    =item parmHelp
346    
347    A string that vaguely describes the positional parameters. This is used
348    if the user specifies the C<-h> option.
349    
350    =item ARGV
351    
352    List of command line parameters, including the option switches, which must
353    precede the positional parameters and be prefixed by a hyphen.
354    
355    =item RETURN
356    
357    Returns a list. The first element of the list is the reference to a hash that
358    maps the command-line option switches to their values. These will either be the
359    default values or overrides specified on the command line. The remaining
360    elements of the list are the position parameters, in order.
361    
362    =back
363    
364    =cut
365    
366    sub StandardSetup {
367        # Get the parameters.
368        my ($categories, $options, $parmHelp, @argv) = @_;
369        # Add the tracing options.
370        $options->{trace} = [2, "tracing level"];
371        $options->{sql} = [0, "turn on SQL tracing"];
372        $options->{h} = [0, "display command-line options"];
373        # Create a parsing hash from the options hash. The parsing hash
374        # contains the default values rather than the default value
375        # and the description. While we're at it, we'll memorize the
376        # length of the longest option name.
377        my $longestName = 0;
378        my %parseOptions = ();
379        for my $key (keys %{$options}) {
380            if (length $key > $longestName) {
381                $longestName = length $key;
382            }
383            $parseOptions{$key} = $options->{$key}->[0];
384        }
385        # Parse the command line.
386        my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
387        # Now we want to set up tracing. First, we need to know if SQL is to
388        # be traced.
389        my @cats = @{$categories};
390        if ($retOptions->{sql}) {
391            push @cats, "SQL";
392        }
393        # Add the default categories.
394        push @cats, "Tracer", "FIG";
395        # Next, we create the category string by prefixing the trace level
396        # and joining the categories.
397        my $cats = join(" ", $parseOptions{trace}, @cats);
398        # Now set up the tracing.
399        TSetup($cats, "+>$FIG_Config::temp/trace.log");
400        # Check for the "h" option. If it is specified, dump the command-line
401        # options and exit the program.
402        if ($retOptions->{h}) {
403            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
404            Trace("$1 [options] $parmHelp") if T(0);
405            for my $key (sort keys %{$options}) {
406                my $name = Pad($key, $longestName, 0, ' ');
407                my $desc = $options->{$key}->[1];
408                if ($options->{$key}->[0]) {
409                    $desc .= " (default " . $options->{$key}->[0] . ")";
410                }
411                Trace("  $name $desc") if T(0);
412            }
413            exit(0);
414        }
415        # Return the parsed parameters.
416        return ($retOptions, @retParameters);
417    }
418    
419    =head3 Setups
420    
421    C<< my $count = Tracer::Setups(); >>
422    
423    Return the number of times L</TSetup> has been called.
424    
425    This method allows for the creation of conditional tracing setups where, for example, we
426    may want to set up tracing if nobody else has done it before us.
427    
428    =cut
429    
430    sub Setups {
431        return $SetupCount;
432    }
433    
434    =head3 Open
435    
436    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
437    
438    Open a file.
439    
440    The I<$fileSpec> is essentially the second argument of the PERL C<open>
441    function. The mode is specified using Unix-like shell information. So, for
442    example,
443    
444        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
445    
446    would open for output appended to the specified file, and
447    
448        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
449    
450    would open a pipe that sorts the records written and removes duplicates. Note
451    the use of file handle syntax in the Open call. To use anonymous file handles,
452    code as follows.
453    
454        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
455    
456    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
457    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
458    failed open will throw an exception and the third parameter will be used to construct
459    an error message. If the parameter is omitted, a standard message is constructed
460    using the file spec.
461    
462        Could not open "/usr/spool/news/twitlog"
463    
464    Note that the mode characters are automatically cleaned from the file name.
465    The actual error message from the file system will be captured and appended to the
466    message in any case.
467    
468        Could not open "/usr/spool/news/twitlog": file not found.
469    
470    In some versions of PERL the only error message we get is a number, which
471    corresponds to the C++ C<errno> value.
472    
473        Could not open "/usr/spool/news/twitlog": 6.
474    
475    =over 4
476    
477    =item fileHandle
478    
479    File handle. If this parameter is C<undef>, a file handle will be generated
480    and returned as the value of this method.
481    
482    =item fileSpec
483    
484    File name and mode, as per the PERL C<open> function.
485    
486    =item message (optional)
487    
488    Error message to use if the open fails. If omitted, a standard error message
489    will be generated. In either case, the error information from the file system
490    is appended to the message. To specify a conditional open that does not throw
491    an error if it fails, use C<0>.
492    
493    =item RETURN
494    
495    Returns the name of the file handle assigned to the file, or C<undef> if the
496    open failed.
497    
498    =back
499    
500    =cut
501    
502    sub Open {
503        # Get the parameters.
504        my ($fileHandle, $fileSpec, $message) = @_;
505        # Attempt to open the file.
506        my $rv = open $fileHandle, $fileSpec;
507        # If the open failed, generate an error message.
508        if (! $rv) {
509            # Save the system error message.
510            my $sysMessage = $!;
511            # See if we need a default message.
512            if (!$message) {
513                # Clean any obvious mode characters and leading spaces from the
514                # filename.
515                my ($fileName) = FindNamePart($fileSpec);
516                $message = "Could not open \"$fileName\"";
517            }
518            # Terminate with an error using the supplied message and the
519            # error message from the file system.
520            Confess("$message: $!");
521        }
522        # Return the file handle.
523        return $fileHandle;
524    }
525    
526    =head3 FindNamePart
527    
528    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
529    
530    Extract the portion of a file specification that contains the file name.
531    
532    A file specification is the string passed to an C<open> call. It specifies the file
533    mode and name. In a truly complex situation, it can specify a pipe sequence. This
534    method assumes that the file name is whatever follows the first angle bracket
535    sequence.  So, for example, in the following strings the file name is
536    C</usr/fig/myfile.txt>.
537    
538        >>/usr/fig/myfile.txt
539        </usr/fig/myfile.txt
540        | sort -u > /usr/fig/myfile.txt
541    
542    If the method cannot find a file name using its normal methods, it will return the
543    whole incoming string.
544    
545    =over 4
546    
547    =item fileSpec
548    
549    File specification string from which the file name is to be extracted.
550    
551    =item RETURN
552    
553    Returns a three-element list. The first element contains the file name portion of
554    the specified string, or the whole string if a file name cannot be found via normal
555    methods. The second element contains the start position of the file name portion and
556    the third element contains the length.
557    
558    =back
559    
560    =cut
561    #: Return Type $;
562    sub FindNamePart {
563        # Get the parameters.
564        my ($fileSpec) = @_;
565        # Default to the whole input string.
566        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
567        # Parse out the file name if we can.
568        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
569            $retVal = $2;
570            $len = length $retVal;
571            $pos = (length $fileSpec) - (length $3) - $len;
572        }
573        # Return the result.
574        return ($retVal, $pos, $len);
575    }
576    
577    =head3 OpenDir
578    
579    C<< my @files = OpenDir($dirName, $filtered, $flag); >>
580    
581    Open a directory and return all the file names. This function essentially performs
582    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
583    set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
584    or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
585    filtered out of the return list. If the directory does not open and I<$flag> is not
586    set, an exception is thrown. So, for example,
587    
588        my @files = OpenDir("/Volumes/fig/contigs", 1);
589    
590    is effectively the same as
591    
592        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
593        my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
594    
595    Similarly, the following code
596    
597        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
598    
599    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
600    automatically returns an empty list if the directory fails to open.
601    
602    =over 4
603    
604    =item dirName
605    
606    Name of the directory to open.
607    
608    =item filtered
609    
610    TRUE if files whose names begin with a period (C<.>) should be automatically removed
611    from the list, else FALSE.
612    
613    =item flag
614    
615    TRUE if a failure to open is okay, else FALSE
616    
617    =back
618    
619    =cut
620    #: Return Type @;
621    sub OpenDir {
622        # Get the parameters.
623        my ($dirName, $filtered, $flag) = @_;
624        # Declare the return variable.
625        my @retVal = ();
626        # Open the directory.
627        if (opendir(my $dirHandle, $dirName)) {
628            # The directory opened successfully. Get the appropriate list according to the
629            # strictures of the filter parameter.
630            if ($filtered) {
631                @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
632            } else {
633                @retVal = readdir $dirHandle;
634            }
635        } elsif (! $flag) {
636            # Here the directory would not open and it's considered an error.
637            Confess("Could not open directory $dirName.");
638        }
639        # Return the result.
640        return @retVal;
641  }  }
642    
643  =head3 SetLevel  =head3 SetLevel
# Line 394  Line 904 
904         warn $message;         warn $message;
905          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
906                  # Write the trace message to an output file.                  # Write the trace message to an output file.
907                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
908                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
909                  close TRACING;                  close TRACING;
910            # If the Tee flag is on, echo it to the standard output.
911            if ($TeeFlag) {
912                print "$formatted\n";
913            }
914          }          }
915  }  }
916    
# Line 439  Line 953 
953                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
954                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
955                          # 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.
956                # The calling package is normally the first parameter. If it is
957                # omitted, the first parameter will be the tracelevel. So, the
958                # first thing we do is shift the so-called category into the
959                # $traceLevel variable where it belongs.
960                          $traceLevel = $category;                          $traceLevel = $category;
961                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
962              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 450  Line 968 
968                  }                  }
969          # Save the category name.          # Save the category name.
970          $LastCategory = $category;          $LastCategory = $category;
971            # Convert it to lower case before we hash it.
972            $category = lc $category;
973                  # Use the category and tracelevel to compute the result.                  # Use the category and tracelevel to compute the result.
974                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          if (ref $traceLevel) {
975                Confess("Bad trace level.");
976            } elsif (ref $TraceLevel) {
977                Confess("Bad trace config.");
978            }
979            $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
980      }      }
981          # Return the computed result.          # Return the computed result.
982      return $retVal;      return $retVal;
# Line 537  Line 1062 
1062    
1063  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1064    
1065  Escape a string for use in a command length. Spaces will be replaced by C<\b>,  Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1066  tabs replaced by C<\t>, new-lines replaced by C<\n>, and backslashes will be  replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1067  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1068    
1069  =over 4  =over 4
1070    
# Line 563  Line 1088 
1088          # Loop through the parameter string, looking for sequences to escape.          # Loop through the parameter string, looking for sequences to escape.
1089          while (length $realString > 0) {          while (length $realString > 0) {
1090                  # Look for the first sequence to escape.                  # Look for the first sequence to escape.
1091                  if ($realString =~ /^(.*?)([ \n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1092                          # 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
1093                          # 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.
1094                          $retVal .= $1;                          $retVal .= $1;
1095                          $realString = substr $realString, (length $2 + length $1);              # Strip the processed section off the real string.
1096                          # Encode the escape sequence.              $realString = substr $realString, (length $2) + (length $1);
1097                # Get the matched character.
1098                          my $char = $2;                          my $char = $2;
1099                          $char =~ tr/ \t\n/btn/;              # If we have a CR, we are done.
1100                if ($char ne "\r") {
1101                    # It's not a CR, so encode the escape sequence.
1102                    $char =~ tr/\t\n/tn/;
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 587  Line 1117 
1117    
1118  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1119    
1120  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
1121  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
1122    be deleted.
1123    
1124  =over 4  =over 4
1125    
# Line 613  Line 1144 
1144          # Only proceed if the incoming string is nonempty.          # Only proceed if the incoming string is nonempty.
1145          if (defined $codedString) {          if (defined $codedString) {
1146                  # 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
1147                  # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1148                  # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1149                  while (length $codedString > 0) {                  while (length $codedString > 0) {
1150                          # Look for the first escape sequence.                          # Look for the first escape sequence.
1151                          if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1152                                  # 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
1153                                  # 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.
1154                                  $retVal .= $1;                                  $retVal .= $1;
1155                                  $codedString = substr $codedString, (2 + length $1);                                  $codedString = substr $codedString, (2 + length $1);
1156                                  # Decode the escape sequence.                  # Get the escape value.
1157                                  my $char = $2;                                  my $char = $2;
1158                                  $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1159                    if ($char ne 'r') {
1160                        # Here it's not an 'r', so we convert it.
1161                        $char =~ tr/\\tn/\\\t\n/;
1162                                  $retVal .= $char;                                  $retVal .= $char;
1163                    }
1164                          } else {                          } else {
1165                                  # 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
1166                                  # transferred unmodified.                                  # transferred unmodified.
# Line 735  Line 1270 
1270    
1271  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1272    
1273  Return the entire contents of a file.      or
1274    
1275    C<< my $fileContents = Tracer::GetFile($fileName); >>
1276    
1277    Return the entire contents of a file. In list context, line-ends are removed and
1278    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1279    
1280  =over 4  =over 4
1281    
# Line 761  Line 1301 
1301          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1302          if (!$ok) {          if (!$ok) {
1303                  # 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.
1304                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1305          } else {          } else {
1306                  # Read the whole file into the return variable, stripping off any terminator                  # Read the whole file into the return variable, stripping off any terminator
1307          # characters.          # characters.
# Line 774  Line 1314 
1314                  # Close it.                  # Close it.
1315                  close INPUTFILE;                  close INPUTFILE;
1316          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(3);  
1317          }          }
1318          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1319      if (wantarray) {      if (wantarray) {
# Line 805  Line 1344 
1344          my ($format) = @_;          my ($format) = @_;
1345          # Create the return variable.          # Create the return variable.
1346          my $retVal = "";          my $retVal = "";
1347        # Only proceed if there is an actual queue.
1348        if (@Queue) {
1349          # Process according to the format.          # Process according to the format.
1350          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1351                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 820  Line 1361 
1361          }          }
1362          # Clear the queue.          # Clear the queue.
1363          @Queue = ();          @Queue = ();
1364        }
1365          # Return the formatted list.          # Return the formatted list.
1366          return $retVal;          return $retVal;
1367  }  }
# Line 828  Line 1370 
1370    
1371  C<< Confess($message); >>  C<< Confess($message); >>
1372    
1373  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  
1374  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.
1375  So, for example  So, for example
1376    
# Line 851  Line 1392 
1392          # Get the parameters.          # Get the parameters.
1393          my ($message) = @_;          my ($message) = @_;
1394          # Trace the call stack.          # Trace the call stack.
1395          Cluck($message) if T(1);      Cluck($message);
1396          # Abort the program.          # Abort the program.
1397          croak(">>> $message");          croak(">>> $message");
1398  }  }
# Line 861  Line 1402 
1402  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1403    
1404  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
1405  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.
1406  So, for example  So, for example
1407    
1408  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1020  Line 1561 
1561    
1562  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1563    
1564  Return TRUE if debug mode has been turned on in FIG_Config, else output  Return TRUE if debug mode has been turned on, else output an error
1565  an error page and return FALSE.  page and return FALSE.
1566    
1567  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1568  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1569  from working unless they are explicitly turned on in the configuration  from working unless they are explicitly turned on by creating a password
1570  file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1571  is not turned on, an error web page will be output.  is not turned on, an error web page will be output directing the
1572    user to enter in the correct password.
1573    
1574  =cut  =cut
1575    
1576  sub DebugMode {  sub DebugMode {
1577          # Declare the return variable.          # Declare the return variable.
1578          my $retVal;      my $retVal = 0;
1579          # Check the debug configuration.          # Check the debug configuration.
1580          if ($FIG_Config::debug_mode) {      my $password = CGI::cookie("DebugMode");
1581        my $encrypted = Digest::MD5::md5_hex($password);
1582        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1583                  $retVal = 1;                  $retVal = 1;
1584          } else {          } else {
1585                  # Here debug mode is off, so we generate an error page.                  # Here debug mode is off, so we generate an error page.
# Line 1071  Line 1615 
1615  sub Strip {  sub Strip {
1616          # Get a copy of the parameter string.          # Get a copy of the parameter string.
1617          my ($string) = @_;          my ($string) = @_;
1618          my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1619      # Strip the line terminator characters.      # Strip the line terminator characters.
1620      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1621          # Return the result.          # Return the result.
# Line 1102  Line 1646 
1646    
1647  =item padChar (optional)  =item padChar (optional)
1648    
1649    Character to use for padding. The default is a space.
1650    
1651  =item RETURN  =item RETURN
1652    
1653  Returns a copy of the original string with the spaces added to the specified end so  Returns a copy of the original string with the pad character added to the
1654  that it achieves the desired length.  specified end so that it achieves the desired length.
1655    
1656  =back  =back
1657    
# Line 1137  Line 1683 
1683          return $retVal;          return $retVal;
1684  }  }
1685    
1686    =head3 EOF
1687    
1688    This is a constant that is lexically greater than any useful string.
1689    
1690    =cut
1691    
1692    sub EOF {
1693        return "\xFF\xFF\xFF\xFF\xFF";
1694    }
1695    
1696    =head3 TICK
1697    
1698    C<< my @results = TICK($commandString); >>
1699    
1700    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1701    dot-slash (C<./> will be removed. So, for example, if you were doing
1702    
1703        `./protein.cgi`
1704    
1705    from inside a CGI script, it would work fine in Unix, but would issue an error message
1706    in Windows complaining that C<'.'> is not a valid command. If instead you code
1707    
1708        TICK("./protein.cgi")
1709    
1710    it will work correctly in both environments.
1711    
1712    =over 4
1713    
1714    =item commandString
1715    
1716    The command string to pass to the system.
1717    
1718    =item RETURN
1719    
1720    Returns the standard output from the specified command, as a list.
1721    
1722    =back
1723    
1724    =cut
1725    #: Return Type @;
1726    sub TICK {
1727        # Get the parameters.
1728        my ($commandString) = @_;
1729        # Chop off the dot-slash if this is Windows.
1730        if ($FIG_Config::win_mode) {
1731            $commandString =~ s!^\./!!;
1732        }
1733        # Activate the command and return the result.
1734        return `$commandString`;
1735    }
1736    
1737    =head3 ScriptSetup
1738    
1739    C<< my ($query, $varHash) = ScriptSetup(); >>
1740    
1741    Perform standard tracing and debugging setup for scripts. The value returned is
1742    the CGI object followed by a pre-built variable hash.
1743    
1744    The C<Trace> query parameter is used to determine whether or not tracing is active and
1745    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1746    the C<CGI> trace module will trace parameter and environment information. Parameters are
1747    traced at level 3 and environment variables at level 4. At the end of the script, the
1748    client should call L</ScriptFinish> to output the web page.
1749    
1750    =cut
1751    
1752    sub ScriptSetup {
1753        # Get the CGI query object.
1754        my $query = CGI->new();
1755        # Check for tracing. Set it up if the user asked for it.
1756        if ($query->param('Trace')) {
1757            # Set up tracing to be queued for display at the bottom of the web page.
1758            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1759            # Trace the parameter and environment data.
1760            if (T(CGI => 3)) {
1761                # Here we want to trace the parameter data.
1762                my @names = $query->param;
1763                for my $parmName (sort @names) {
1764                    # Note we skip "Trace", which is for our use only.
1765                    if ($parmName ne 'Trace') {
1766                        my @values = $query->param($parmName);
1767                        Trace("CGI: $parmName = " . join(", ", @values));
1768                    }
1769                }
1770            }
1771            if (T(CGI => 4)) {
1772                # Here we want the environment data too.
1773                for my $envName (sort keys %ENV) {
1774                    Trace("ENV: $envName = $ENV{$envName}");
1775                }
1776            }
1777        } else {
1778            # Here tracing is to be turned off. All we allow is errors traced into the
1779            # error log.
1780            TSetup("0", "WARN");
1781        }
1782        # Create the variable hash.
1783        my $varHash = { DebugData => '' };
1784        # If we're in DEBUG mode, set up the debug mode data for forms.
1785        if (Tracer::DebugMode) {
1786            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1787        }
1788        # Return the query object and variable hash.
1789        return ($query, $varHash);
1790    }
1791    
1792    =head3 ScriptFinish
1793    
1794    C<< ScriptFinish($webData, $varHash); >>
1795    
1796    Output a web page at the end of a script. Either the string to be output or the
1797    name of a template file can be specified. If the second parameter is omitted,
1798    it is assumed we have a string to be output; otherwise, it is assumed we have the
1799    name of a template file. The template should have the variable C<DebugData>
1800    specified in any form that invokes a standard script. If debugging mode is turned
1801    on, a form field will be put in that allows the user to enter tracing data.
1802    Trace messages will be placed immediately before the terminal C<BODY> tag in
1803    the output, formatted as a list.
1804    
1805    A typical standard script would loook like the following.
1806    
1807        BEGIN {
1808            # Print the HTML header.
1809            print "CONTENT-TYPE: text/html\n\n";
1810        }
1811        use Tracer;
1812        use CGI;
1813        use FIG;
1814        # ... more uses ...
1815    
1816        my ($query, $varHash) = ScriptSetup();
1817        eval {
1818            # ... get data from $query, put it in $varHash ...
1819        };
1820        if ($@) {
1821            Trace("Script Error: $@") if T(0);
1822        }
1823        ScriptFinish("Html/MyTemplate.html", $varHash);
1824    
1825    The idea here is that even if the script fails, you'll see trace messages and
1826    useful output.
1827    
1828    =over 4
1829    
1830    =item webData
1831    
1832    A string containing either the full web page to be written to the output or the
1833    name of a template file from which the page is to be constructed. If the name
1834    of a template file is specified, then the second parameter must be present;
1835    otherwise, it must be absent.
1836    
1837    =item varHash (optional)
1838    
1839    If specified, then a reference to a hash mapping variable names for a template
1840    to their values. The template file will be read into memory, and variable markers
1841    will be replaced by data in this hash reference.
1842    
1843    =cut
1844    
1845    sub ScriptFinish {
1846        # Get the parameters.
1847        my ($webData, $varHash) = @_;
1848        # Check for a template file situation.
1849        my $outputString;
1850        if (defined $varHash) {
1851            # Here we have a template file. We need to apply the variables to the template.
1852            $outputString = PageBuilder::Build("<$webData", $varHash, "Html");
1853        } else {
1854            # Here the user gave us a raw string.
1855            $outputString = $webData;
1856        }
1857        # Check for trace messages.
1858        if ($Destination eq "QUEUE") {
1859            # We have trace messages, so we want to put them at the end of the body. This
1860            # is either at the end of the whole string or at the beginning of the BODY
1861            # end-tag.
1862            my $pos = length $outputString;
1863            if ($outputString =~ m#</body>#gi) {
1864                $pos = (pos $outputString) - 7;
1865            }
1866            substr $outputString, $pos, 0, QTrace('Html');
1867        }
1868        # Write the output string.
1869        print $outputString;
1870    }
1871    
1872  1;  1;

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.36

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3