[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.35, Wed Jan 11 19:26:45 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    
31  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
32    
# Line 20  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 38  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, 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
66  specifies that messages should be output as HTML paragraphs. The parameters are formatted  specifies that messages should be output as HTML paragraphs.
67  to make it easier to 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 61  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  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 93  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 113  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 2. To get all messages, specify a trace level of 4.
261    For a genome-by-genome update, use 3.
262    
263    The I<options> parameter is a reference to a hash containing the command-line
264    options and their default values. Command-line options may be in the form of switches
265    or keywords. In the case of a switch, the option value is 1 if it is specified and
266    0 if it is not specified. In the case of a keyword, the value is separated from the
267    option name by an equal sign. You can see this last in the command-line example above.
268    
269    An example at this point would help. Consider, for example, the command-line utility
270    C<TransactFeatures>. It accepts a list of positional parameters plus the options
271    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
272    the following code.
273    
274        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
275                                                          { safe => 0, noAlias => 0,
276                                                            start => ' ', tblFiles => 0},
277                                                        @ARGV);
278    
279    
280    The call to C<ParseCommand> specifies the default values for the options and
281    stores the actual options in a hash that is returned as C<$options>. The
282    positional parameters are returned in C<@parameters>.
283    
284    The following is a sample command line for C<TransactFeatures>.
285    
286        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
287    
288    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
289    parameters, and would find themselves in I<@parameters> after executing the
290    above code fragment. The tracing would be set to level 2, and the categories
291    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
292    and C<DocUtils> was included because it came in within the first parameter
293    to this method. The I<$options> hash would be
294    
295        { trace => 2, sql => 0, safe => 0,
296          noAlias => 1, start => ' ', tblFiles => 0 }
297    
298    Use of C<StandardSetup> in this way provides a simple way of performing
299    standard tracing setup and command-line parsing. Note that the caller is
300    not even aware of the command-line switches C<-trace> and C<-sql>, which
301    are used by this method to control the tracing. If additional tracing features
302    need to be added in the future, they can be processed by this method without
303    upsetting the command-line utilities.
304    
305    The parameters to this method are as follows.
306    
307    =over 4
308    
309    =item categories
310    
311    Reference to a list of tracing category names. These should be names of
312    packages whose internal workings will need to be debugged to get the
313    command working.
314    
315    =item options
316    
317    Reference to a hash containing the legal options for the current command mapped
318    to their default values. The use can override the defaults by specifying the
319    options as command-line switches prefixed by a hyphen. Tracing-related options
320    may be added to this hash.
321    
322    =item ARGV
323    
324    List of command line parameters, including the option switches, which must
325    precede the positional parameters and be prefixed by a hyphen.
326    
327    =item RETURN
328    
329    Returns a list. The first element of the list is the reference to a hash that
330    maps the command-line option switches to their values. These will either be the
331    default values or overrides specified on the command line. The remaining
332    elements of the list are the position parameters, in order.
333    
334    =back
335    
336    =cut
337    
338    sub StandardSetup {
339        # Get the parameters.
340        my ($categories, $options, @argv) = @_;
341        # Add the tracing options.
342        $options->{trace} = 2;
343        $options->{sql} = 0;
344        # Parse the command line.
345        my ($retOptions, @retParameters) = ParseCommand($options, @argv);
346        # Now we want to set up tracing. First, we need to know if SQL is to
347        # be traced.
348        my @cats = @{$categories};
349        if ($retOptions->{sql}) {
350            push @cats, "SQL";
351        }
352        # Add the default categories.
353        push @cats, "Tracer", "FIG";
354        # Next, we create the category string by prefixing the trace level
355        # and joining the categories.
356        my $cats = join(" ", $options->{trace}, @cats);
357        # Now set up the tracing.
358        TSetup($cats, "+>$FIG_Config::temp/trace.log");
359        # Return the parsed parameters.
360        return ($retOptions, @retParameters);
361    }
362    
363    =head3 Setups
364    
365    C<< my $count = Tracer::Setups(); >>
366    
367    Return the number of times L</TSetup> has been called.
368    
369    This method allows for the creation of conditional tracing setups where, for example, we
370    may want to set up tracing if nobody else has done it before us.
371    
372    =cut
373    
374    sub Setups {
375        return $SetupCount;
376    }
377    
378    =head3 Open
379    
380    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
381    
382    Open a file.
383    
384    The I<$fileSpec> is essentially the second argument of the PERL C<open>
385    function. The mode is specified using Unix-like shell information. So, for
386    example,
387    
388        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
389    
390    would open for output appended to the specified file, and
391    
392        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
393    
394    would open a pipe that sorts the records written and removes duplicates. Note
395    the use of file handle syntax in the Open call. To use anonymous file handles,
396    code as follows.
397    
398        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
399    
400    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
401    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
402    failed open will throw an exception and the third parameter will be used to construct
403    an error message. If the parameter is omitted, a standard message is constructed
404    using the file spec.
405    
406        Could not open "/usr/spool/news/twitlog"
407    
408    Note that the mode characters are automatically cleaned from the file name.
409    The actual error message from the file system will be captured and appended to the
410    message in any case.
411    
412        Could not open "/usr/spool/news/twitlog": file not found.
413    
414    In some versions of PERL the only error message we get is a number, which
415    corresponds to the C++ C<errno> value.
416    
417        Could not open "/usr/spool/news/twitlog": 6.
418    
419    =over 4
420    
421    =item fileHandle
422    
423    File handle. If this parameter is C<undef>, a file handle will be generated
424    and returned as the value of this method.
425    
426    =item fileSpec
427    
428    File name and mode, as per the PERL C<open> function.
429    
430    =item message (optional)
431    
432    Error message to use if the open fails. If omitted, a standard error message
433    will be generated. In either case, the error information from the file system
434    is appended to the message. To specify a conditional open that does not throw
435    an error if it fails, use C<0>.
436    
437    =item RETURN
438    
439    Returns the name of the file handle assigned to the file, or C<undef> if the
440    open failed.
441    
442    =back
443    
444    =cut
445    
446    sub Open {
447        # Get the parameters.
448        my ($fileHandle, $fileSpec, $message) = @_;
449        # Attempt to open the file.
450        my $rv = open $fileHandle, $fileSpec;
451        # If the open failed, generate an error message.
452        if (! $rv) {
453            # Save the system error message.
454            my $sysMessage = $!;
455            # See if we need a default message.
456            if (!$message) {
457                # Clean any obvious mode characters and leading spaces from the
458                # filename.
459                my ($fileName) = FindNamePart($fileSpec);
460                $message = "Could not open \"$fileName\"";
461            }
462            # Terminate with an error using the supplied message and the
463            # error message from the file system.
464            Confess("$message: $!");
465        }
466        # Return the file handle.
467        return $fileHandle;
468    }
469    
470    =head3 FindNamePart
471    
472    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
473    
474    Extract the portion of a file specification that contains the file name.
475    
476    A file specification is the string passed to an C<open> call. It specifies the file
477    mode and name. In a truly complex situation, it can specify a pipe sequence. This
478    method assumes that the file name is whatever follows the first angle bracket
479    sequence.  So, for example, in the following strings the file name is
480    C</usr/fig/myfile.txt>.
481    
482        >>/usr/fig/myfile.txt
483        </usr/fig/myfile.txt
484        | sort -u > /usr/fig/myfile.txt
485    
486    If the method cannot find a file name using its normal methods, it will return the
487    whole incoming string.
488    
489    =over 4
490    
491    =item fileSpec
492    
493    File specification string from which the file name is to be extracted.
494    
495    =item RETURN
496    
497    Returns a three-element list. The first element contains the file name portion of
498    the specified string, or the whole string if a file name cannot be found via normal
499    methods. The second element contains the start position of the file name portion and
500    the third element contains the length.
501    
502    =back
503    
504    =cut
505    #: Return Type $;
506    sub FindNamePart {
507        # Get the parameters.
508        my ($fileSpec) = @_;
509        # Default to the whole input string.
510        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
511        # Parse out the file name if we can.
512        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
513            $retVal = $2;
514            $len = length $retVal;
515            $pos = (length $fileSpec) - (length $3) - $len;
516        }
517        # Return the result.
518        return ($retVal, $pos, $len);
519    }
520    
521    =head3 OpenDir
522    
523    C<< my @files = OpenDir($dirName, $filtered, $flag); >>
524    
525    Open a directory and return all the file names. This function essentially performs
526    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
527    set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
528    or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
529    filtered out of the return list. If the directory does not open and I<$flag> is not
530    set, an exception is thrown. So, for example,
531    
532        my @files = OpenDir("/Volumes/fig/contigs", 1);
533    
534    is effectively the same as
535    
536        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
537        my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
538    
539    Similarly, the following code
540    
541        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
542    
543    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
544    automatically returns an empty list if the directory fails to open.
545    
546    =over 4
547    
548    =item dirName
549    
550    Name of the directory to open.
551    
552    =item filtered
553    
554    TRUE if files whose names begin with a period (C<.>) should be automatically removed
555    from the list, else FALSE.
556    
557    =item flag
558    
559    TRUE if a failure to open is okay, else FALSE
560    
561    =back
562    
563    =cut
564    #: Return Type @;
565    sub OpenDir {
566        # Get the parameters.
567        my ($dirName, $filtered, $flag) = @_;
568        # Declare the return variable.
569        my @retVal = ();
570        # Open the directory.
571        if (opendir(my $dirHandle, $dirName)) {
572            # The directory opened successfully. Get the appropriate list according to the
573            # strictures of the filter parameter.
574            if ($filtered) {
575                @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
576            } else {
577                @retVal = readdir $dirHandle;
578            }
579        } elsif (! $flag) {
580            # Here the directory would not open and it's considered an error.
581            Confess("Could not open directory $dirName.");
582        }
583        # Return the result.
584        return @retVal;
585  }  }
586    
587  =head3 SetLevel  =head3 SetLevel
# Line 394  Line 848 
848         warn $message;         warn $message;
849          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
850                  # Write the trace message to an output file.                  # Write the trace message to an output file.
851                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
852                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
853                  close TRACING;                  close TRACING;
854            # If the Tee flag is on, echo it to the standard output.
855            if ($TeeFlag) {
856                print "$formatted\n";
857            }
858          }          }
859  }  }
860    
# Line 439  Line 897 
897                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
898                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
899                          # 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.
900                # The calling package is normally the first parameter. If it is
901                # omitted, the first parameter will be the tracelevel. So, the
902                # first thing we do is shift the so-called category into the
903                # $traceLevel variable where it belongs.
904                          $traceLevel = $category;                          $traceLevel = $category;
905                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
906              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 450  Line 912 
912                  }                  }
913          # Save the category name.          # Save the category name.
914          $LastCategory = $category;          $LastCategory = $category;
915            # Convert it to lower case before we hash it.
916            $category = lc $category;
917                  # Use the category and tracelevel to compute the result.                  # Use the category and tracelevel to compute the result.
918                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
919      }      }
920          # Return the computed result.          # Return the computed result.
921      return $retVal;      return $retVal;
# Line 537  Line 1001 
1001    
1002  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1003    
1004  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
1005  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
1006  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1007    
1008  =over 4  =over 4
1009    
# Line 563  Line 1027 
1027          # Loop through the parameter string, looking for sequences to escape.          # Loop through the parameter string, looking for sequences to escape.
1028          while (length $realString > 0) {          while (length $realString > 0) {
1029                  # Look for the first sequence to escape.                  # Look for the first sequence to escape.
1030                  if ($realString =~ /^(.*?)([ \n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1031                          # 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
1032                          # 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.
1033                          $retVal .= $1;                          $retVal .= $1;
1034                          $realString = substr $realString, (length $2 + length $1);              # Strip the processed section off the real string.
1035                          # Encode the escape sequence.              $realString = substr $realString, (length $2) + (length $1);
1036                # Get the matched character.
1037                          my $char = $2;                          my $char = $2;
1038                          $char =~ tr/ \t\n/btn/;              # If we have a CR, we are done.
1039                if ($char ne "\r") {
1040                    # It's not a CR, so encode the escape sequence.
1041                    $char =~ tr/\t\n/tn/;
1042                          $retVal .= "\\" . $char;                          $retVal .= "\\" . $char;
1043                }
1044                  } else {                  } else {
1045                          # 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
1046                          # transferred unmodified.                          # transferred unmodified.
# Line 587  Line 1056 
1056    
1057  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1058    
1059  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
1060  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
1061    be deleted.
1062    
1063  =over 4  =over 4
1064    
# Line 613  Line 1083 
1083          # Only proceed if the incoming string is nonempty.          # Only proceed if the incoming string is nonempty.
1084          if (defined $codedString) {          if (defined $codedString) {
1085                  # 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
1086                  # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1087                  # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1088                  while (length $codedString > 0) {                  while (length $codedString > 0) {
1089                          # Look for the first escape sequence.                          # Look for the first escape sequence.
1090                          if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1091                                  # 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
1092                                  # 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.
1093                                  $retVal .= $1;                                  $retVal .= $1;
1094                                  $codedString = substr $codedString, (2 + length $1);                                  $codedString = substr $codedString, (2 + length $1);
1095                                  # Decode the escape sequence.                  # Get the escape value.
1096                                  my $char = $2;                                  my $char = $2;
1097                                  $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1098                    if ($char ne 'r') {
1099                        # Here it's not an 'r', so we convert it.
1100                        $char =~ tr/\\tn/\\\t\n/;
1101                                  $retVal .= $char;                                  $retVal .= $char;
1102                    }
1103                          } else {                          } else {
1104                                  # 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
1105                                  # transferred unmodified.                                  # transferred unmodified.
# Line 735  Line 1209 
1209    
1210  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1211    
1212  Return the entire contents of a file.      or
1213    
1214    C<< my $fileContents = Tracer::GetFile($fileName); >>
1215    
1216    Return the entire contents of a file. In list context, line-ends are removed and
1217    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1218    
1219  =over 4  =over 4
1220    
# Line 761  Line 1240 
1240          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1241          if (!$ok) {          if (!$ok) {
1242                  # 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.
1243                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1244          } else {          } else {
1245                  # Read the whole file into the return variable, stripping off any terminator                  # Read the whole file into the return variable, stripping off any terminator
1246          # characters.          # characters.
# Line 774  Line 1253 
1253                  # Close it.                  # Close it.
1254                  close INPUTFILE;                  close INPUTFILE;
1255          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(3);  
1256          }          }
1257          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1258      if (wantarray) {      if (wantarray) {
# Line 805  Line 1283 
1283          my ($format) = @_;          my ($format) = @_;
1284          # Create the return variable.          # Create the return variable.
1285          my $retVal = "";          my $retVal = "";
1286        # Only proceed if there is an actual queue.
1287        if (@Queue) {
1288          # Process according to the format.          # Process according to the format.
1289          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1290                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 820  Line 1300 
1300          }          }
1301          # Clear the queue.          # Clear the queue.
1302          @Queue = ();          @Queue = ();
1303        }
1304          # Return the formatted list.          # Return the formatted list.
1305          return $retVal;          return $retVal;
1306  }  }
# Line 828  Line 1309 
1309    
1310  C<< Confess($message); >>  C<< Confess($message); >>
1311    
1312  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  
1313  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.
1314  So, for example  So, for example
1315    
# Line 851  Line 1331 
1331          # Get the parameters.          # Get the parameters.
1332          my ($message) = @_;          my ($message) = @_;
1333          # Trace the call stack.          # Trace the call stack.
1334          Cluck($message) if T(1);      Cluck($message);
1335          # Abort the program.          # Abort the program.
1336          croak(">>> $message");          croak(">>> $message");
1337  }  }
# Line 861  Line 1341 
1341  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1342    
1343  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
1344  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.
1345  So, for example  So, for example
1346    
1347  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1020  Line 1500 
1500    
1501  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1502    
1503  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
1504  an error page and return FALSE.  page and return FALSE.
1505    
1506  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1507  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1508  from working unless they are explicitly turned on in the configuration  from working unless they are explicitly turned on by creating a password
1509  file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1510  is not turned on, an error web page will be output.  is not turned on, an error web page will be output directing the
1511    user to enter in the correct password.
1512    
1513  =cut  =cut
1514    
1515  sub DebugMode {  sub DebugMode {
1516          # Declare the return variable.          # Declare the return variable.
1517          my $retVal;      my $retVal = 0;
1518          # Check the debug configuration.          # Check the debug configuration.
1519          if ($FIG_Config::debug_mode) {      my $password = CGI::cookie("DebugMode");
1520        my $encrypted = Digest::MD5::md5_hex($password);
1521        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1522                  $retVal = 1;                  $retVal = 1;
1523          } else {          } else {
1524                  # 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 1554 
1554  sub Strip {  sub Strip {
1555          # Get a copy of the parameter string.          # Get a copy of the parameter string.
1556          my ($string) = @_;          my ($string) = @_;
1557          my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1558      # Strip the line terminator characters.      # Strip the line terminator characters.
1559      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1560          # Return the result.          # Return the result.
# Line 1102  Line 1585 
1585    
1586  =item padChar (optional)  =item padChar (optional)
1587    
1588    Character to use for padding. The default is a space.
1589    
1590  =item RETURN  =item RETURN
1591    
1592  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
1593  that it achieves the desired length.  specified end so that it achieves the desired length.
1594    
1595  =back  =back
1596    
# Line 1137  Line 1622 
1622          return $retVal;          return $retVal;
1623  }  }
1624    
1625    =head3 EOF
1626    
1627    This is a constant that is lexically greater than any useful string.
1628    
1629    =cut
1630    
1631    sub EOF {
1632        return "\xFF\xFF\xFF\xFF\xFF";
1633    }
1634    
1635    =head3 TICK
1636    
1637    C<< my @results = TICK($commandString); >>
1638    
1639    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1640    dot-slash (C<./> will be removed. So, for example, if you were doing
1641    
1642        `./protein.cgi`
1643    
1644    from inside a CGI script, it would work fine in Unix, but would issue an error message
1645    in Windows complaining that C<'.'> is not a valid command. If instead you code
1646    
1647        TICK("./protein.cgi")
1648    
1649    it will work correctly in both environments.
1650    
1651    =over 4
1652    
1653    =item commandString
1654    
1655    The command string to pass to the system.
1656    
1657    =item RETURN
1658    
1659    Returns the standard output from the specified command, as a list.
1660    
1661    =back
1662    
1663    =cut
1664    #: Return Type @;
1665    sub TICK {
1666        # Get the parameters.
1667        my ($commandString) = @_;
1668        # Chop off the dot-slash if this is Windows.
1669        if ($FIG_Config::win_mode) {
1670            $commandString =~ s!^\./!!;
1671        }
1672        # Activate the command and return the result.
1673        return `$commandString`;
1674    }
1675    
1676    =head3 ScriptSetup
1677    
1678    C<< my ($query, $varHash) = ScriptSetup(); >>
1679    
1680    Perform standard tracing and debugging setup for scripts. The value returned is
1681    the CGI object followed by a pre-built variable hash.
1682    
1683    The C<Trace> query parameter is used to determine whether or not tracing is active and
1684    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1685    the C<CGI> trace module will trace parameter and environment information. Parameters are
1686    traced at level 3 and environment variables at level 4. At the end of the script, the
1687    client should call L</ScriptFinish> to output the web page.
1688    
1689    =cut
1690    
1691    sub ScriptSetup {
1692        # Get the CGI query object.
1693        my $query = CGI->new();
1694        # Check for tracing. Set it up if the user asked for it.
1695        if ($query->param('Trace')) {
1696            # Set up tracing to be queued for display at the bottom of the web page.
1697            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1698            # Trace the parameter and environment data.
1699            if (T(CGI => 3)) {
1700                # Here we want to trace the parameter data.
1701                my @names = $query->param;
1702                for my $parmName (sort @names) {
1703                    # Note we skip "Trace", which is for our use only.
1704                    if ($parmName ne 'Trace') {
1705                        my @values = $query->param($parmName);
1706                        Trace("CGI: $parmName = " . join(", ", @values));
1707                    }
1708                }
1709            }
1710            if (T(CGI => 4)) {
1711                # Here we want the environment data too.
1712                for my $envName (sort keys %ENV) {
1713                    Trace("ENV: $envName = $ENV{$envName}");
1714                }
1715            }
1716        } else {
1717            # Here tracing is to be turned off. All we allow is errors traced into the
1718            # error log.
1719            TSetup("0", "WARN");
1720        }
1721        # Create the variable hash.
1722        my $varHash = { DebugData => '' };
1723        # If we're in DEBUG mode, set up the debug mode data for forms.
1724        if (Tracer::DebugMode) {
1725            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1726        }
1727        # Return the query object and variable hash.
1728        return ($query, $varHash);
1729    }
1730    
1731    =head3 ScriptFinish
1732    
1733    C<< ScriptFinish($webData, $varHash); >>
1734    
1735    Output a web page at the end of a script. Either the string to be output or the
1736    name of a template file can be specified. If the second parameter is omitted,
1737    it is assumed we have a string to be output; otherwise, it is assumed we have the
1738    name of a template file. The template should have the variable C<DebugData>
1739    specified in any form that invokes a standard script. If debugging mode is turned
1740    on, a form field will be put in that allows the user to enter tracing data.
1741    Trace messages will be placed immediately before the terminal C<BODY> tag in
1742    the output, formatted as a list.
1743    
1744    A typical standard script would loook like the following.
1745    
1746        BEGIN {
1747            # Print the HTML header.
1748            print "CONTENT-TYPE: text/html\n\n";
1749        }
1750        use Tracer;
1751        use CGI;
1752        use FIG;
1753        # ... more uses ...
1754    
1755        my ($query, $varHash) = ScriptSetup();
1756        eval {
1757            # ... get data from $query, put it in $varHash ...
1758        };
1759        if ($@) {
1760            Trace("Script Error: $@") if T(0);
1761        }
1762        ScriptFinish("Html/MyTemplate.html", $varHash);
1763    
1764    The idea here is that even if the script fails, you'll see trace messages and
1765    useful output.
1766    
1767    =over 4
1768    
1769    =item webData
1770    
1771    A string containing either the full web page to be written to the output or the
1772    name of a template file from which the page is to be constructed. If the name
1773    of a template file is specified, then the second parameter must be present;
1774    otherwise, it must be absent.
1775    
1776    =item varHash (optional)
1777    
1778    If specified, then a reference to a hash mapping variable names for a template
1779    to their values. The template file will be read into memory, and variable markers
1780    will be replaced by data in this hash reference.
1781    
1782    =cut
1783    
1784    sub ScriptFinish {
1785        # Get the parameters.
1786        my ($webData, $varHash) = @_;
1787        # Check for a template file situation.
1788        my $outputString;
1789        if (defined $varHash) {
1790            # Here we have a template file. We need to apply the variables to the template.
1791            $outputString = PageBuilder::Build("<$webData", $varHash, "Html");
1792        } else {
1793            # Here the user gave us a raw string.
1794            $outputString = $webData;
1795        }
1796        # Check for trace messages.
1797        if ($Destination eq "QUEUE") {
1798            # We have trace messages, so we want to put them at the end of the body. This
1799            # is either at the end of the whole string or at the beginning of the BODY
1800            # end-tag.
1801            my $pos = length $outputString;
1802            if ($outputString =~ m#</body>#gi) {
1803                $pos = (pos $outputString) - 7;
1804            }
1805            substr $outputString, $pos, 0, QTrace('Html');
1806        }
1807        # Write the output string.
1808        print $outputString;
1809    }
1810    
1811  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3