[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.32, Thu Jan 5 22:26:54 2006 UTC
# Line 1  Line 1 
1    #
2    # Copyright (c) 2003-2006 University of Chicago and Fellowship
3    # for Interpretations of Genomes. All Rights Reserved.
4    #
5    # This file is part of the SEED Toolkit.
6    #
7    # The SEED Toolkit is free software. You can redistribute
8    # it and/or modify it under the terms of the SEED Toolkit
9    # Public License.
10    #
11    # You should have received a copy of the SEED Toolkit Public License
12    # along with this program; if not write to the University of Chicago
13    # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14    # Genomes at veronika@thefig.info or download a copy from
15    # http://www.theseed.org/LICENSE.TXT.
16    #
17    
18  package Tracer;  package Tracer;
19    
20          require Exporter;          require Exporter;
21          @ISA = ('Exporter');          @ISA = ('Exporter');
22          @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup);
23          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape 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.
178          for my $category (@categoryData) {          for my $category (@categoryData) {
179                  $Categories{$category} = 1;          if ($category eq '*') {
180                $AllTrace = 1;
181            } else {
182                $Categories{lc $category} = 1;
183            }
184          }          }
185          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
186          # 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
187          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
188        if ($target =~ m/^\+?>>?/) {
189            if ($target =~ m/^\+/) {
190                $TeeFlag = 1;
191                $target = substr($target, 1);
192            }
193          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
194                  open TRACEFILE, $target;                  open TRACEFILE, $target;
195                  print TRACEFILE Now() . " Tracing initialized.\n";                  print TRACEFILE Now() . " Tracing initialized.\n";
196                  close TRACEFILE;                  close TRACEFILE;
197                  $Destination = ">$target";                  $Destination = ">$target";
198          } else {          } else {
199                $Destination = $target;
200            }
201        } else {
202                  $Destination = uc($target);                  $Destination = uc($target);
203          }          }
204        # Increment the setup counter.
205        $SetupCount++;
206    }
207    
208    =head3 StandardSetup
209    
210    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, @ARGV); >>
211    
212    This method performs standard command-line parsing and tracing setup. The return
213    values are a hash of the command-line options and a list of the positional
214    parameters. Tracing is automatically set up and the command-line options are
215    validated.
216    
217    This is a complex method that does a lot of grunt work. The parameters can
218    be more easily understood, however, once they are examined individually.
219    
220    The I<categories> parameter is the most obtuse. It is a reference to a list of
221    special-purpose tracing categories. Most tracing categories are PERL package
222    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
223    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
224    
225        ["Sprout", "SproutLoad", "ERDB"]
226    
227    This would cause trace messages in the specified three packages to appear in
228    the output. There are threer special tracing categories that are automatically
229    handled by this method. In other words, if you used L</TSetup> you would need
230    to include these categories manually, but if you use this method they are turned
231    on automatically.
232    
233    =over 4
234    
235    =item FIG
236    
237    Turns on trace messages inside the B<FIG> package.
238    
239    =item SQL
240    
241    Traces SQL commands and activity.
242    
243    =item Tracer
244    
245    Traces error messages and call stacks.
246    
247    =back
248    
249    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
250    The trace level is specified using the C<-trace> command-line option. For example,
251    the following command line for C<TransactFeatures> turns on SQL tracing and runs
252    all tracing at level 3.
253    
254        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
255    
256    Standard tracing is output to the standard output and echoed to the file
257    C<trace.log> in the FIG temporary directory.
258    
259    The default trace level is 3. This dumps out all SQL commands if SQL tracing
260    is turned on and tends to produce one flurry of messages per genome. To get all
261    messages, specify a trace level of 4. For generally quiet output, use 2.
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                                                          { trace => 3, sql => 0,
276                                                            safe => 0, noAlias => 0,
277                                                            start => ' ', tblFiles => 0},
278                                                        @ARGV);
279    
280    
281    The call to C<ParseCommand> specifies the default values for the options and
282    stores the actual options in a hash that is returned as C<$options>. The
283    positional parameters are returned in C<@parameters>.
284    
285    The following is a sample command line for C<TransactFeatures>.
286    
287        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
288    
289    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
290    parameters, and would find themselves in I<@parameters> after executing the
291    above code fragment. The tracing would be set to level 2, and the categories
292    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
293    and C<DocUtils> was included because it came in within the first parameter
294    to this method. The I<$options> hash would be
295    
296        { trace => 2, sql => 0, safe => 0,
297          noAlias => 1, start => ' ', tblFiles => 0 }
298    
299    Use of C<StandardSetup> in this way provides a simple way of performing
300    standard tracing setup and command-line parsing. Note that the caller is
301    not even aware of the command-line switches C<-trace> and C<-sql>, which
302    are used by this method to control the tracing. If additional tracing features
303    need to be added in the future, they can be processed by this method without
304    upsetting the command-line utilities.
305    
306    The parameters to this method are as follows.
307    
308    =over 4
309    
310    =item categories
311    
312    Reference to a list of tracing category names. These should be names of
313    packages whose internal workings will need to be debugged to get the
314    command working.
315    
316    =item options
317    
318    Reference to a hash containing the legal options for the current command mapped
319    to their default values. The use can override the defaults by specifying the
320    options as command-line switches prefixed by a hyphen. Tracing-related options
321    may be added to this hash.
322    
323    =item ARGV
324    
325    List of command line parameters, including the option switches, which must
326    precede the positional parameters and be prefixed by a hyphen.
327    
328    =item RETURN
329    
330    Returns a list. The first element of the list is the reference to a hash that
331    maps the command-line option switches to their values. These will either be the
332    default values or overrides specified on the command line. The remaining
333    elements of the list are the position parameters, in order.
334    
335    =back
336    
337    =cut
338    
339    sub StandardSetup {
340        # Get the parameters.
341        my ($categories, $options, @argv) = @_;
342        # Add the tracing options.
343        $options->{trace} = 3;
344        $options->{sql} = 0;
345        # Parse the command line.
346        my ($retOptions, @retParameters) = ParseCommand($options, @argv);
347        # Now we want to set up tracing. First, we need to know if SQL is to
348        # be traced.
349        my @cats = @{$categories};
350        if ($retOptions->{sql}) {
351            push @cats, "SQL";
352        }
353        # Add the default categories.
354        push @cats, "Tracer", "FIG";
355        # Next, we create the category string by prefixing the trace level
356        # and joining the categories.
357        my $cats = join(" ", $options->{trace}, @cats);
358        # Now set up the tracing.
359        TSetup($cats, "+>$FIG_Config::temp/trace.log");
360        # Return the parsed parameters.
361        return ($retOptions, @retParameters);
362    }
363    
364    =head3 Setups
365    
366    C<< my $count = Tracer::Setups(); >>
367    
368    Return the number of times L</TSetup> has been called.
369    
370    This method allows for the creation of conditional tracing setups where, for example, we
371    may want to set up tracing if nobody else has done it before us.
372    
373    =cut
374    
375    sub Setups {
376        return $SetupCount;
377    }
378    
379    =head3 Open
380    
381    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
382    
383    Open a file.
384    
385    The I<$fileSpec> is essentially the second argument of the PERL C<open>
386    function. The mode is specified using Unix-like shell information. So, for
387    example,
388    
389        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
390    
391    would open for output appended to the specified file, and
392    
393        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
394    
395    would open a pipe that sorts the records written and removes duplicates. Note
396    the use of file handle syntax in the Open call. To use anonymous file handles,
397    code as follows.
398    
399        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
400    
401    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
402    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
403    failed open will throw an exception and the third parameter will be used to construct
404    an error message. If the parameter is omitted, a standard message is constructed
405    using the file spec.
406    
407        Could not open "/usr/spool/news/twitlog"
408    
409    Note that the mode characters are automatically cleaned from the file name.
410    The actual error message from the file system will be captured and appended to the
411    message in any case.
412    
413        Could not open "/usr/spool/news/twitlog": file not found.
414    
415    In some versions of PERL the only error message we get is a number, which
416    corresponds to the C++ C<errno> value.
417    
418        Could not open "/usr/spool/news/twitlog": 6.
419    
420    =over 4
421    
422    =item fileHandle
423    
424    File handle. If this parameter is C<undef>, a file handle will be generated
425    and returned as the value of this method.
426    
427    =item fileSpec
428    
429    File name and mode, as per the PERL C<open> function.
430    
431    =item message (optional)
432    
433    Error message to use if the open fails. If omitted, a standard error message
434    will be generated. In either case, the error information from the file system
435    is appended to the message. To specify a conditional open that does not throw
436    an error if it fails, use C<0>.
437    
438    =item RETURN
439    
440    Returns the name of the file handle assigned to the file, or C<undef> if the
441    open failed.
442    
443    =back
444    
445    =cut
446    
447    sub Open {
448        # Get the parameters.
449        my ($fileHandle, $fileSpec, $message) = @_;
450        # Attempt to open the file.
451        my $rv = open $fileHandle, $fileSpec;
452        # If the open failed, generate an error message.
453        if (! $rv) {
454            # Save the system error message.
455            my $sysMessage = $!;
456            # See if we need a default message.
457            if (!$message) {
458                # Clean any obvious mode characters and leading spaces from the
459                # filename.
460                my ($fileName) = FindNamePart($fileSpec);
461                $message = "Could not open \"$fileName\"";
462            }
463            # Terminate with an error using the supplied message and the
464            # error message from the file system.
465            Confess("$message: $!");
466        }
467        # Return the file handle.
468        return $fileHandle;
469    }
470    
471    =head3 FindNamePart
472    
473    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
474    
475    Extract the portion of a file specification that contains the file name.
476    
477    A file specification is the string passed to an C<open> call. It specifies the file
478    mode and name. In a truly complex situation, it can specify a pipe sequence. This
479    method assumes that the file name is whatever follows the first angle bracket
480    sequence.  So, for example, in the following strings the file name is
481    C</usr/fig/myfile.txt>.
482    
483        >>/usr/fig/myfile.txt
484        </usr/fig/myfile.txt
485        | sort -u > /usr/fig/myfile.txt
486    
487    If the method cannot find a file name using its normal methods, it will return the
488    whole incoming string.
489    
490    =over 4
491    
492    =item fileSpec
493    
494    File specification string from which the file name is to be extracted.
495    
496    =item RETURN
497    
498    Returns a three-element list. The first element contains the file name portion of
499    the specified string, or the whole string if a file name cannot be found via normal
500    methods. The second element contains the start position of the file name portion and
501    the third element contains the length.
502    
503    =back
504    
505    =cut
506    #: Return Type $;
507    sub FindNamePart {
508        # Get the parameters.
509        my ($fileSpec) = @_;
510        # Default to the whole input string.
511        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
512        # Parse out the file name if we can.
513        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
514            $retVal = $2;
515            $len = length $retVal;
516            $pos = (length $fileSpec) - (length $3) - $len;
517        }
518        # Return the result.
519        return ($retVal, $pos, $len);
520    }
521    
522    =head3 OpenDir
523    
524    C<< my @files = OpenDir($dirName, $filtered, $flag); >>
525    
526    Open a directory and return all the file names. This function essentially performs
527    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
528    set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
529    or pound sign (C<#>) will be filtered out of the return list. If the directory
530    does not open and I<$flag> is not set, an exception is thrown. So,
531    for example,
532    
533        my @files = OpenDir("/Volumes/fig/contigs", 1);
534    
535    is effectively the same as
536    
537        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
538        my @files = grep { $_ !~ /^[\.\$\#]/ } readdir(TMP);
539    
540    Similarly, the following code
541    
542        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
543    
544    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
545    automatically returns an empty list if the directory fails to open.
546    
547    =over 4
548    
549    =item dirName
550    
551    Name of the directory to open.
552    
553    =item filtered
554    
555    TRUE if files whose names begin with a period (C<.>) should be automatically removed
556    from the list, else FALSE.
557    
558    =item flag
559    
560    TRUE if a failure to open is okay, else FALSE
561    
562    =back
563    
564    =cut
565    #: Return Type @;
566    sub OpenDir {
567        # Get the parameters.
568        my ($dirName, $filtered, $flag) = @_;
569        # Declare the return variable.
570        my @retVal = ();
571        # Open the directory.
572        if (opendir(my $dirHandle, $dirName)) {
573            # The directory opened successfully. Get the appropriate list according to the
574            # strictures of the filter parameter.
575            if ($filtered) {
576                @retVal = grep { $_ !~ /^[\.\$\#]/ } readdir $dirHandle;
577            } else {
578                @retVal = readdir $dirHandle;
579            }
580        } elsif (! $flag) {
581            # Here the directory would not open and it's considered an error.
582            Confess("Could not open directory $dirName.");
583        }
584        # Return the result.
585        return @retVal;
586  }  }
587    
588  =head3 SetLevel  =head3 SetLevel
# Line 394  Line 849 
849         warn $message;         warn $message;
850          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
851                  # Write the trace message to an output file.                  # Write the trace message to an output file.
852                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
853                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
854                  close TRACING;                  close TRACING;
855            # If the Tee flag is on, echo it to the standard output.
856            if ($TeeFlag) {
857                print "$formatted\n";
858            }
859          }          }
860  }  }
861    
# Line 439  Line 898 
898                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
899                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
900                          # 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.
901                # The calling package is normally the first parameter. If it is
902                # omitted, the first parameter will be the tracelevel. So, the
903                # first thing we do is shift the so-called category into the
904                # $traceLevel variable where it belongs.
905                          $traceLevel = $category;                          $traceLevel = $category;
906                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
907              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 450  Line 913 
913                  }                  }
914          # Save the category name.          # Save the category name.
915          $LastCategory = $category;          $LastCategory = $category;
916            # Convert it to lower case before we hash it.
917            $category = lc $category;
918                  # Use the category and tracelevel to compute the result.                  # Use the category and tracelevel to compute the result.
919                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
920      }      }
921          # Return the computed result.          # Return the computed result.
922      return $retVal;      return $retVal;
# Line 537  Line 1002 
1002    
1003  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1004    
1005  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
1006  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
1007  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1008    
1009  =over 4  =over 4
1010    
# Line 563  Line 1028 
1028          # Loop through the parameter string, looking for sequences to escape.          # Loop through the parameter string, looking for sequences to escape.
1029          while (length $realString > 0) {          while (length $realString > 0) {
1030                  # Look for the first sequence to escape.                  # Look for the first sequence to escape.
1031                  if ($realString =~ /^(.*?)([ \n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1032                          # 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
1033                          # 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.
1034                          $retVal .= $1;                          $retVal .= $1;
1035                          $realString = substr $realString, (length $2 + length $1);              # Strip the processed section off the real string.
1036                          # Encode the escape sequence.              $realString = substr $realString, (length $2) + (length $1);
1037                # Get the matched character.
1038                          my $char = $2;                          my $char = $2;
1039                          $char =~ tr/ \t\n/btn/;              # If we have a CR, we are done.
1040                if ($char ne "\r") {
1041                    # It's not a CR, so encode the escape sequence.
1042                    $char =~ tr/\t\n/tn/;
1043                          $retVal .= "\\" . $char;                          $retVal .= "\\" . $char;
1044                }
1045                  } else {                  } else {
1046                          # 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
1047                          # transferred unmodified.                          # transferred unmodified.
# Line 587  Line 1057 
1057    
1058  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1059    
1060  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
1061  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
1062    be deleted.
1063    
1064  =over 4  =over 4
1065    
# Line 613  Line 1084 
1084          # Only proceed if the incoming string is nonempty.          # Only proceed if the incoming string is nonempty.
1085          if (defined $codedString) {          if (defined $codedString) {
1086                  # 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
1087                  # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1088                  # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1089                  while (length $codedString > 0) {                  while (length $codedString > 0) {
1090                          # Look for the first escape sequence.                          # Look for the first escape sequence.
1091                          if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|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                                  $codedString = substr $codedString, (2 + length $1);                                  $codedString = substr $codedString, (2 + length $1);
1096                                  # Decode the escape sequence.                  # Get the escape value.
1097                                  my $char = $2;                                  my $char = $2;
1098                                  $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1099                    if ($char ne 'r') {
1100                        # Here it's not an 'r', so we convert it.
1101                        $char =~ tr/\\tn/\\\t\n/;
1102                                  $retVal .= $char;                                  $retVal .= $char;
1103                    }
1104                          } else {                          } else {
1105                                  # 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
1106                                  # transferred unmodified.                                  # transferred unmodified.
# Line 761  Line 1236 
1236          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1237          if (!$ok) {          if (!$ok) {
1238                  # 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.
1239                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1240          } else {          } else {
1241                  # Read the whole file into the return variable, stripping off any terminator                  # Read the whole file into the return variable, stripping off any terminator
1242          # characters.          # characters.
# Line 774  Line 1249 
1249                  # Close it.                  # Close it.
1250                  close INPUTFILE;                  close INPUTFILE;
1251          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(3);  
1252          }          }
1253          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1254      if (wantarray) {      if (wantarray) {
# Line 805  Line 1279 
1279          my ($format) = @_;          my ($format) = @_;
1280          # Create the return variable.          # Create the return variable.
1281          my $retVal = "";          my $retVal = "";
1282        # Only proceed if there is an actual queue.
1283        if (@Queue) {
1284          # Process according to the format.          # Process according to the format.
1285          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1286                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 820  Line 1296 
1296          }          }
1297          # Clear the queue.          # Clear the queue.
1298          @Queue = ();          @Queue = ();
1299        }
1300          # Return the formatted list.          # Return the formatted list.
1301          return $retVal;          return $retVal;
1302  }  }
# Line 828  Line 1305 
1305    
1306  C<< Confess($message); >>  C<< Confess($message); >>
1307    
1308  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  
1309  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.
1310  So, for example  So, for example
1311    
# Line 851  Line 1327 
1327          # Get the parameters.          # Get the parameters.
1328          my ($message) = @_;          my ($message) = @_;
1329          # Trace the call stack.          # Trace the call stack.
1330          Cluck($message) if T(1);      Cluck($message);
1331          # Abort the program.          # Abort the program.
1332          croak(">>> $message");          croak(">>> $message");
1333  }  }
# Line 861  Line 1337 
1337  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1338    
1339  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
1340  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.
1341  So, for example  So, for example
1342    
1343  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1020  Line 1496 
1496    
1497  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1498    
1499  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
1500  an error page and return FALSE.  page and return FALSE.
1501    
1502  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1503  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1504  from working unless they are explicitly turned on in the configuration  from working unless they are explicitly turned on by creating a password
1505  file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1506  is not turned on, an error web page will be output.  is not turned on, an error web page will be output directing the
1507    user to enter in the correct password.
1508    
1509  =cut  =cut
1510    
1511  sub DebugMode {  sub DebugMode {
1512          # Declare the return variable.          # Declare the return variable.
1513          my $retVal;      my $retVal = 0;
1514          # Check the debug configuration.          # Check the debug configuration.
1515          if ($FIG_Config::debug_mode) {      my $password = CGI::cookie("DebugMode");
1516        my $encrypted = Digest::MD5::md5_hex($password);
1517        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1518                  $retVal = 1;                  $retVal = 1;
1519          } else {          } else {
1520                  # 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 1550 
1550  sub Strip {  sub Strip {
1551          # Get a copy of the parameter string.          # Get a copy of the parameter string.
1552          my ($string) = @_;          my ($string) = @_;
1553          my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1554      # Strip the line terminator characters.      # Strip the line terminator characters.
1555      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1556          # Return the result.          # Return the result.
# Line 1102  Line 1581 
1581    
1582  =item padChar (optional)  =item padChar (optional)
1583    
1584    Character to use for padding. The default is a space.
1585    
1586  =item RETURN  =item RETURN
1587    
1588  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
1589  that it achieves the desired length.  specified end so that it achieves the desired length.
1590    
1591  =back  =back
1592    
# Line 1137  Line 1618 
1618          return $retVal;          return $retVal;
1619  }  }
1620    
1621    =head3 EOF
1622    
1623    This is a constant that is lexically greater than any useful string.
1624    
1625    =cut
1626    
1627    sub EOF {
1628        return "\xFF\xFF\xFF\xFF\xFF";
1629    }
1630    
1631    =head3 TICK
1632    
1633    C<< my @results = TICK($commandString); >>
1634    
1635    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1636    dot-slash (C<./> will be removed. So, for example, if you were doing
1637    
1638        `./protein.cgi`
1639    
1640    from inside a CGI script, it would work fine in Unix, but would issue an error message
1641    in Windows complaining that C<'.'> is not a valid command. If instead you code
1642    
1643        TICK("./protein.cgi")
1644    
1645    it will work correctly in both environments.
1646    
1647    =over 4
1648    
1649    =item commandString
1650    
1651    The command string to pass to the system.
1652    
1653    =item RETURN
1654    
1655    Returns the standard output from the specified command, as a list.
1656    
1657    =back
1658    
1659    =cut
1660    #: Return Type @;
1661    sub TICK {
1662        # Get the parameters.
1663        my ($commandString) = @_;
1664        # Chop off the dot-slash if this is Windows.
1665        if ($FIG_Config::win_mode) {
1666            $commandString =~ s!^\./!!;
1667        }
1668        # Activate the command and return the result.
1669        return `$commandString`;
1670    }
1671    
1672  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3