[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.1, Tue Jan 18 20:33:38 2005 UTC revision 1.39, Fri Feb 24 19:45:29 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 Assert);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup ScriptSetup ScriptFinish Insure);
23          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
24          use strict;          use strict;
25          use Carp qw(longmess croak);          use Carp qw(longmess croak);
26          use CGI;          use CGI;
27        use FIG_Config;
28        use PageBuilder;
29        use Digest::MD5;
30        use File::Basename;
31        use File::Path;
32    
33  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
34    
# Line 18  Line 40 
40  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
41  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
42  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
43  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
44  appear. To generate a trace message, use the following syntax.  appear. To generate a trace message, use the following syntax.
45    
46  C<< Trace($message) if T(errors => 4); >>  C<< Trace($message) if T(errors => 4); >>
47    
48  This statement will produce a trace message if the trace level is 4 or more and the C<errors>  This statement will produce a trace message if the trace level is 4 or more and the C<errors>
49  category is active. Note that the special category C<root> is always active, so  category is active. Note that the special category C<main> is always active, so
50    
51  C<< Trace($message) if T(root => 4); >>  C<< Trace($message) if T(main => 4); >>
52    
53  will trace if the trace level is 4 or more.  will trace if the trace level is 4 or more.
54    
# Line 36  Line 58 
58    
59  C<< Trace($message) if T(2); >>  C<< Trace($message) if T(2); >>
60    
61  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
62  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
63  specified as a space-delimited string. Thus  specified as a space-delimited string. Thus
64    
65  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
66    
67  sets the trace level to 3, activated the C<errors>, C<Sprout>, and C<ERDB> categories, and  sets the trace level to 3, activates the C<errors>, C<Sprout>, and C<ERDB> categories, and
68  specifies that messages should be output as HTML paragraphs. The idea is to make it easier to  specifies that messages should be output as HTML paragraphs.
69  input tracing configuration on a web form.  
70    To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
71    level 3 and writes the output to the standard error output. This sort of thing might be
72    useful in a CGI environment.
73    
74    C<< TSetup('3 *', 'WARN'); >>
75    
76  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
77  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 52  Line 79 
79  the page output, they can be gathered together and displayed at the end of the page. This makes  the page output, they can be gathered together and displayed at the end of the page. This makes
80  it easier to debug page formatting problems.  it easier to debug page formatting problems.
81    
82    Finally, you can specify that all trace messages be emitted as warnings.
83    
84  The flexibility of tracing makes it superior to simple use of directives like C<die> and C<warn>.  The flexibility of tracing makes it superior to simple use of directives like C<die> and C<warn>.
85  Tracer calls can be left in the code with minimal overhead and then turned on only when needed.  Tracer calls can be left in the code with minimal overhead and then turned on only when needed.
86  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
87  being used out in the field.  being used out in the field.
88    
89    There is no hard and fast rule on how to use trace levels. The following is therefore only
90    a suggestion.
91    
92    =over 4
93    
94    =item Error 0
95    
96    Message indicates an error that may lead to incorrect results or that has stopped the
97    application entirely.
98    
99    =item Warning 1
100    
101    Message indicates something that is unexpected but that probably did not interfere
102    with program execution.
103    
104    =item Notice 2
105    
106    Message indicates the beginning or end of a major task.
107    
108    =item Information 3
109    
110    Message indicates a subtask. In the FIG system, a subtask generally relates to a single
111    genome. This would be a big loop that is not expected to execute more than 500 times or so.
112    
113    =item Detail 4
114    
115    Message indicates a low-level loop iteration.
116    
117    =back
118    
119  =cut  =cut
120    
121  # Declare the configuration variables.  # Declare the configuration variables.
122    
123  my $Destination = "NONE";       # Description of where to send the trace output.  my $Destination = "NONE";       # Description of where to send the trace output.
124  my %Categories = ( root => 1 );  my $TeeFlag = 0;            # TRUE if output is going to a file and to the
125                                # standard output
126    my %Categories = ( main => 1 );
127                                                          # hash of active category names                                                          # hash of active category names
128  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
129                                                          # messages                                                          # messages
130  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
131    my $LastCategory = "main";  # name of the last category interrogated
132    my $SetupCount = 0;         # number of times TSetup called
133    my $AllTrace = 0;           # TRUE if we are tracing all categories.
134    
135  =head2 Public Methods  =head2 Public Methods
136    
# Line 88  Line 152 
152    
153  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
154  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
155  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 ">"
156  the trace messages to a file, you can specify XX special destinations. C<HTML> will  symbol with a C<+> to echo output to a file AND to the standard output. In addition to
157    sending the trace messages to a file, you can specify a special destination. C<HTML> will
158  cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>  cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
159  will cause tracing to the standard output as ordinary text. C<QUEUE> will cause trace messages  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace
160  to be stored in a queue for later retrieval by the L</QTrace> method. C<NONE> will cause  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace
161  tracing to be suppressed.  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
162    cause trace messages to be emitted as warnings using the B<warn> directive.  C<NONE> will
163    cause tracing to be suppressed.
164    
165  =back  =back
166    
# Line 106  Line 173 
173          my @categoryData = split /\s+/, $categoryList;          my @categoryData = split /\s+/, $categoryList;
174          # Extract the trace level.          # Extract the trace level.
175          $TraceLevel = shift @categoryData;          $TraceLevel = shift @categoryData;
176          # Build the category hash.      # Presume category-based tracing until we learn otherwise.
177        $AllTrace = 0;
178        # Build the category hash. Note that if we find a "*", we turn on non-category
179        # tracing. We must also clear away any pre-existing data.
180        %Categories = ( main => 1 );
181          for my $category (@categoryData) {          for my $category (@categoryData) {
182                  $Categories{$category} = 1;          if ($category eq '*') {
183                $AllTrace = 1;
184            } else {
185                $Categories{lc $category} = 1;
186            }
187          }          }
188          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
189          # 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
190          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
191        if ($target =~ m/^\+?>>?/) {
192            if ($target =~ m/^\+/) {
193                $TeeFlag = 1;
194                $target = substr($target, 1);
195            }
196          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
197                  open TRACEFILE, $target;                  open TRACEFILE, $target;
198                  print TRACEFILE Now() . " Tracing initialized.\n";                  print TRACEFILE Now() . " Tracing initialized.\n";
199                  close TRACEFILE;                  close TRACEFILE;
200                  $Destination = ">$target";                  $Destination = ">$target";
201          } else {          } else {
202                $Destination = $target;
203            }
204        } else {
205                  $Destination = uc($target);                  $Destination = uc($target);
206          }          }
207        # Increment the setup counter.
208        $SetupCount++;
209    }
210    
211    =head3 StandardSetup
212    
213    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
214    
215    This method performs standard command-line parsing and tracing setup. The return
216    values are a hash of the command-line options and a list of the positional
217    parameters. Tracing is automatically set up and the command-line options are
218    validated.
219    
220    This is a complex method that does a lot of grunt work. The parameters can
221    be more easily understood, however, once they are examined individually.
222    
223    The I<categories> parameter is the most obtuse. It is a reference to a list of
224    special-purpose tracing categories. Most tracing categories are PERL package
225    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
226    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
227    
228        ["Sprout", "SproutLoad", "ERDB"]
229    
230    This would cause trace messages in the specified three packages to appear in
231    the output. There are threer special tracing categories that are automatically
232    handled by this method. In other words, if you used L</TSetup> you would need
233    to include these categories manually, but if you use this method they are turned
234    on automatically.
235    
236    =over 4
237    
238    =item FIG
239    
240    Turns on trace messages inside the B<FIG> package.
241    
242    =item SQL
243    
244    Traces SQL commands and activity.
245    
246    =item Tracer
247    
248    Traces error messages and call stacks.
249    
250    =back
251    
252    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
253    The trace level is specified using the C<-trace> command-line option. For example,
254    the following command line for C<TransactFeatures> turns on SQL tracing and runs
255    all tracing at level 3.
256    
257        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
258    
259    Standard tracing is output to the standard output and echoed to the file
260    C<trace>I<$$>C<.log> in the FIG temporary directory, where I<$$> is the
261    process ID. You can also specify the C<user> parameter to put a user ID
262    instead of a process ID in the trace file name. So, for example
263    
264    The default trace level is 2. To get all messages, specify a trace level of 4.
265    For a genome-by-genome update, use 3.
266    
267        TransactFeatures -trace=3 -sql -user=Bruce register ../xacts IDs.tbl
268    
269    would send the trace output to C<traceBruce.log> in the temporary directory.
270    
271    The I<options> parameter is a reference to a hash containing the command-line
272    options, their default values, and an explanation of what they mean. Command-line
273    options may be in the form of switches or keywords. In the case of a switch, the
274    option value is 1 if it is specified and 0 if it is not specified. In the case
275    of a keyword, the value is separated from the option name by an equal sign. You
276    can see this last in the command-line example above.
277    
278    An example at this point would help. Consider, for example, the command-line utility
279    C<TransactFeatures>. It accepts a list of positional parameters plus the options
280    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
281    the following code.
282    
283        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
284                            { safe => [0, "use database transactions"],
285                              noAlias => [0, "do not expect aliases in CHANGE transactions"],
286                              start => [' ', "start with this genome"],
287                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
288                            "command transactionDirectory IDfile",
289                          @ARGV);
290    
291    
292    The call to C<ParseCommand> specifies the default values for the options and
293    stores the actual options in a hash that is returned as C<$options>. The
294    positional parameters are returned in C<@parameters>.
295    
296    The following is a sample command line for C<TransactFeatures>.
297    
298        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
299    
300    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
301    parameters, and would find themselves in I<@parameters> after executing the
302    above code fragment. The tracing would be set to level 2, and the categories
303    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
304    and C<DocUtils> was included because it came in within the first parameter
305    to this method. The I<$options> hash would be
306    
307        { trace => 2, sql => 0, safe => 0,
308          noAlias => 1, start => ' ', tblFiles => 0 }
309    
310    Use of C<StandardSetup> in this way provides a simple way of performing
311    standard tracing setup and command-line parsing. Note that the caller is
312    not even aware of the command-line switches C<-trace> and C<-sql>, which
313    are used by this method to control the tracing. If additional tracing features
314    need to be added in the future, they can be processed by this method without
315    upsetting the command-line utilities.
316    
317    Finally, if the special option C<-h> is specified, the option names will
318    be traced at level 0 and the program will exit without processing.
319    This provides a limited help capability. For example, if the user enters
320    
321        TransactFeatures -h
322    
323    he would see the following output.
324    
325        TransactFeatures [options] command transactionDirectory IDfile
326            -trace    tracing level (default 2)
327            -sql      trace SQL commands
328            -safe     use database transactions
329            -noAlias  do not expect aliases in CHANGE transactions
330            -start    start with this genome
331            -tblFiles output TBL files containing the corrected IDs
332    
333    The parameters to this method are as follows.
334    
335    =over 4
336    
337    =item categories
338    
339    Reference to a list of tracing category names. These should be names of
340    packages whose internal workings will need to be debugged to get the
341    command working.
342    
343    =item options
344    
345    Reference to a hash containing the legal options for the current command mapped
346    to their default values and descriptions. The user can override the defaults
347    by specifying the options as command-line switches prefixed by a hyphen.
348    Tracing-related options may be added to this hash. If the C<-h> option is
349    specified on the command line, the option descriptions will be used to
350    explain the options.
351    
352    =item parmHelp
353    
354    A string that vaguely describes the positional parameters. This is used
355    if the user specifies the C<-h> option.
356    
357    =item ARGV
358    
359    List of command line parameters, including the option switches, which must
360    precede the positional parameters and be prefixed by a hyphen.
361    
362    =item RETURN
363    
364    Returns a list. The first element of the list is the reference to a hash that
365    maps the command-line option switches to their values. These will either be the
366    default values or overrides specified on the command line. The remaining
367    elements of the list are the position parameters, in order.
368    
369    =back
370    
371    =cut
372    
373    sub StandardSetup {
374        # Get the parameters.
375        my ($categories, $options, $parmHelp, @argv) = @_;
376        # Add the tracing options.
377        $options->{trace} = [2, "tracing level"];
378        $options->{sql} = [0, "turn on SQL tracing"];
379        $options->{h} = [0, "display command-line options"];
380        $options->{user} = [$$, "trace log file name suffix"];
381        # Create a parsing hash from the options hash. The parsing hash
382        # contains the default values rather than the default value
383        # and the description. While we're at it, we'll memorize the
384        # length of the longest option name.
385        my $longestName = 0;
386        my %parseOptions = ();
387        for my $key (keys %{$options}) {
388            if (length $key > $longestName) {
389                $longestName = length $key;
390            }
391            $parseOptions{$key} = $options->{$key}->[0];
392        }
393        # Parse the command line.
394        my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
395        # Now we want to set up tracing. First, we need to know if SQL is to
396        # be traced.
397        my @cats = @{$categories};
398        if ($retOptions->{sql}) {
399            push @cats, "SQL";
400        }
401        # Add the default categories.
402        push @cats, "Tracer", "FIG";
403        # Next, we create the category string by prefixing the trace level
404        # and joining the categories.
405        my $cats = join(" ", $parseOptions{trace}, @cats);
406        # Now set up the tracing.
407        my $suffix = $retOptions->{user};
408        TSetup($cats, "+>$FIG_Config::temp/trace$suffix.log");
409        # Check for the "h" option. If it is specified, dump the command-line
410        # options and exit the program.
411        if ($retOptions->{h}) {
412            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
413            Trace("$1 [options] $parmHelp") if T(0);
414            for my $key (sort keys %{$options}) {
415                my $name = Pad($key, $longestName, 0, ' ');
416                my $desc = $options->{$key}->[1];
417                if ($options->{$key}->[0]) {
418                    $desc .= " (default " . $options->{$key}->[0] . ")";
419                }
420                Trace("  $name $desc") if T(0);
421            }
422            exit(0);
423        }
424        # Return the parsed parameters.
425        return ($retOptions, @retParameters);
426    }
427    
428    =head3 Setups
429    
430    C<< my $count = Tracer::Setups(); >>
431    
432    Return the number of times L</TSetup> has been called.
433    
434    This method allows for the creation of conditional tracing setups where, for example, we
435    may want to set up tracing if nobody else has done it before us.
436    
437    =cut
438    
439    sub Setups {
440        return $SetupCount;
441    }
442    
443    =head3 Open
444    
445    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
446    
447    Open a file.
448    
449    The I<$fileSpec> is essentially the second argument of the PERL C<open>
450    function. The mode is specified using Unix-like shell information. So, for
451    example,
452    
453        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
454    
455    would open for output appended to the specified file, and
456    
457        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
458    
459    would open a pipe that sorts the records written and removes duplicates. Note
460    the use of file handle syntax in the Open call. To use anonymous file handles,
461    code as follows.
462    
463        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
464    
465    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
466    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
467    failed open will throw an exception and the third parameter will be used to construct
468    an error message. If the parameter is omitted, a standard message is constructed
469    using the file spec.
470    
471        Could not open "/usr/spool/news/twitlog"
472    
473    Note that the mode characters are automatically cleaned from the file name.
474    The actual error message from the file system will be captured and appended to the
475    message in any case.
476    
477        Could not open "/usr/spool/news/twitlog": file not found.
478    
479    In some versions of PERL the only error message we get is a number, which
480    corresponds to the C++ C<errno> value.
481    
482        Could not open "/usr/spool/news/twitlog": 6.
483    
484    =over 4
485    
486    =item fileHandle
487    
488    File handle. If this parameter is C<undef>, a file handle will be generated
489    and returned as the value of this method.
490    
491    =item fileSpec
492    
493    File name and mode, as per the PERL C<open> function.
494    
495    =item message (optional)
496    
497    Error message to use if the open fails. If omitted, a standard error message
498    will be generated. In either case, the error information from the file system
499    is appended to the message. To specify a conditional open that does not throw
500    an error if it fails, use C<0>.
501    
502    =item RETURN
503    
504    Returns the name of the file handle assigned to the file, or C<undef> if the
505    open failed.
506    
507    =back
508    
509    =cut
510    
511    sub Open {
512        # Get the parameters.
513        my ($fileHandle, $fileSpec, $message) = @_;
514        # Attempt to open the file.
515        my $rv = open $fileHandle, $fileSpec;
516        # If the open failed, generate an error message.
517        if (! $rv) {
518            # Save the system error message.
519            my $sysMessage = $!;
520            # See if we need a default message.
521            if (!$message) {
522                # Clean any obvious mode characters and leading spaces from the
523                # filename.
524                my ($fileName) = FindNamePart($fileSpec);
525                $message = "Could not open \"$fileName\"";
526            }
527            # Terminate with an error using the supplied message and the
528            # error message from the file system.
529            Confess("$message: $!");
530        }
531        # Return the file handle.
532        return $fileHandle;
533    }
534    
535    =head3 FindNamePart
536    
537    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
538    
539    Extract the portion of a file specification that contains the file name.
540    
541    A file specification is the string passed to an C<open> call. It specifies the file
542    mode and name. In a truly complex situation, it can specify a pipe sequence. This
543    method assumes that the file name is whatever follows the first angle bracket
544    sequence.  So, for example, in the following strings the file name is
545    C</usr/fig/myfile.txt>.
546    
547        >>/usr/fig/myfile.txt
548        </usr/fig/myfile.txt
549        | sort -u > /usr/fig/myfile.txt
550    
551    If the method cannot find a file name using its normal methods, it will return the
552    whole incoming string.
553    
554    =over 4
555    
556    =item fileSpec
557    
558    File specification string from which the file name is to be extracted.
559    
560    =item RETURN
561    
562    Returns a three-element list. The first element contains the file name portion of
563    the specified string, or the whole string if a file name cannot be found via normal
564    methods. The second element contains the start position of the file name portion and
565    the third element contains the length.
566    
567    =back
568    
569    =cut
570    #: Return Type $;
571    sub FindNamePart {
572        # Get the parameters.
573        my ($fileSpec) = @_;
574        # Default to the whole input string.
575        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
576        # Parse out the file name if we can.
577        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
578            $retVal = $2;
579            $len = length $retVal;
580            $pos = (length $fileSpec) - (length $3) - $len;
581        }
582        # Return the result.
583        return ($retVal, $pos, $len);
584    }
585    
586    =head3 OpenDir
587    
588    C<< my @files = OpenDir($dirName, $filtered, $flag); >>
589    
590    Open a directory and return all the file names. This function essentially performs
591    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
592    set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
593    or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
594    filtered out of the return list. If the directory does not open and I<$flag> is not
595    set, an exception is thrown. So, for example,
596    
597        my @files = OpenDir("/Volumes/fig/contigs", 1);
598    
599    is effectively the same as
600    
601        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
602        my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
603    
604    Similarly, the following code
605    
606        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
607    
608    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
609    automatically returns an empty list if the directory fails to open.
610    
611    =over 4
612    
613    =item dirName
614    
615    Name of the directory to open.
616    
617    =item filtered
618    
619    TRUE if files whose names begin with a period (C<.>) should be automatically removed
620    from the list, else FALSE.
621    
622    =item flag
623    
624    TRUE if a failure to open is okay, else FALSE
625    
626    =back
627    
628    =cut
629    #: Return Type @;
630    sub OpenDir {
631        # Get the parameters.
632        my ($dirName, $filtered, $flag) = @_;
633        # Declare the return variable.
634        my @retVal = ();
635        # Open the directory.
636        if (opendir(my $dirHandle, $dirName)) {
637            # The directory opened successfully. Get the appropriate list according to the
638            # strictures of the filter parameter.
639            if ($filtered) {
640                @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
641            } else {
642                @retVal = readdir $dirHandle;
643            }
644        } elsif (! $flag) {
645            # Here the directory would not open and it's considered an error.
646            Confess("Could not open directory $dirName.");
647        }
648        # Return the result.
649        return @retVal;
650    }
651    
652    =head3 SetLevel
653    
654    C<< Tracer::SetLevel($newLevel); >>
655    
656    Modify the trace level. A higher trace level will cause more messages to appear.
657    
658    =over 4
659    
660    =item newLevel
661    
662    Proposed new trace level.
663    
664    =back
665    
666    =cut
667    
668    sub SetLevel {
669        $TraceLevel = $_[0];
670  }  }
671    
672  =head3 Now  =head3 Now
# Line 168  Line 714 
714          open STDERR, '>', $fileName;          open STDERR, '>', $fileName;
715  }  }
716    
717    =head3 ReadOptions
718    
719    C<< my %options = Tracer::ReadOptions($fileName); >>
720    
721    Read a set of options from a file. Each option is encoded in a line of text that has the
722    format
723    
724    I<optionName>C<=>I<optionValue>C<; >I<comment>
725    
726    The option name must consist entirely of letters, digits, and the punctuation characters
727    C<.> and C<_>, and is case sensitive. Blank lines and lines in which the first nonblank
728    character is a semi-colon will be ignored. The return hash will map each option name to
729    the corresponding option value.
730    
731    =over 4
732    
733    =item fileName
734    
735    Name of the file containing the option data.
736    
737    =item RETURN
738    
739    Returns a hash mapping the option names specified in the file to their corresponding option
740    value.
741    
742    =back
743    
744    =cut
745    
746    sub ReadOptions {
747        # Get the parameters.
748        my ($fileName) = @_;
749        # Open the file.
750        (open CONFIGFILE, "<$fileName") || Confess("Could not open option file $fileName.");
751        # Count the number of records read.
752        my ($records, $comments) = 0;
753        # Create the return hash.
754        my %retVal = ();
755        # Loop through the file, accumulating key-value pairs.
756        while (my $line = <CONFIGFILE>) {
757            # Denote we've read a line.
758            $records++;
759            # Determine the line type.
760            if ($line =~ /^\s*[\n\r]/) {
761                # A blank line is a comment.
762                $comments++;
763            } elsif ($line =~ /^\s*([A-Za-z0-9_\.]+)=([^;]*);/) {
764                # Here we have an option assignment.
765                retVal{$1} = $2;
766            } elsif ($line =~ /^\s*;/) {
767                # Here we have a text comment.
768                $comments++;
769            } else {
770                # Here we have an invalid line.
771                Trace("Invalid option statement in record $records.") if T(0);
772            }
773        }
774        # Return the hash created.
775        return %retVal;
776    }
777    
778  =head3 GetOptions  =head3 GetOptions
779    
780  C<< Tracer::GetOptions(\%defaults, \%options); >>  C<< Tracer::GetOptions(\%defaults, \%options); >>
# Line 285  Line 892 
892          my ($message) = @_;          my ($message) = @_;
893          # Get the timestamp.          # Get the timestamp.
894          my $timeStamp = Now();          my $timeStamp = Now();
895        # Format the message. Note we strip off any line terminators at the end.
896        my $formatted = "$timeStamp <$LastCategory>: " . Strip($message);
897          # Process according to the destination.          # Process according to the destination.
898          if ($Destination eq "TEXT") {          if ($Destination eq "TEXT") {
899                  # Write the message to the standard output.                  # Write the message to the standard output.
900                  print "$timeStamp $message\n";          print "$formatted\n";
901        } elsif ($Destination eq "ERROR") {
902            # Write the message to the error output.
903            print STDERR "$formatted\n";
904          } elsif ($Destination eq "QUEUE") {          } elsif ($Destination eq "QUEUE") {
905                  # Push the message into the queue.                  # Push the message into the queue.
906                  push @Queue, "$timeStamp $message";          push @Queue, "$formatted";
907          } elsif ($Destination eq "HTML") {          } elsif ($Destination eq "HTML") {
908                  # Convert the message to HTML and write it to the standard output.                  # Convert the message to HTML and write it to the standard output.
909                  my $escapedMessage = CGI::escapeHTML($message);                  my $escapedMessage = CGI::escapeHTML($message);
910                  print "<p>$timeStamp $message</p>\n";          print "<p>$formatted</p>\n";
911        } elsif ($Destination eq "WARN") {
912           # Emit the message as a warning.
913           warn $message;
914          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
915                  # Write the trace message to an output file.                  # Write the trace message to an output file.
916                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
917                  print TRACING "$timeStamp $message\n";          print TRACING "$formatted\n";
918                  close TRACING;                  close TRACING;
919            # If the Tee flag is on, echo it to the standard output.
920            if ($TeeFlag) {
921                print "$formatted\n";
922            }
923          }          }
924  }  }
925    
# Line 343  Line 962 
962                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
963                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
964                          # 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.
965                # The calling package is normally the first parameter. If it is
966                # omitted, the first parameter will be the tracelevel. So, the
967                # first thing we do is shift the so-called category into the
968                # $traceLevel variable where it belongs.
969                          $traceLevel = $category;                          $traceLevel = $category;
970                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
971                          # If there is no calling package, we default to "root".              # If there is no calling package, we default to "main".
972                          if (!$package) {                          if (!$package) {
973                                  $category = "root";                  $category = "main";
974                          } else {                          } else {
975                                  $category = $package;                                  $category = $package;
976                          }                          }
977                  }                  }
978                  # Use the package and tracelevel to compute the result.          # Save the category name.
979                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          $LastCategory = $category;
980            # Convert it to lower case before we hash it.
981            $category = lc $category;
982            # Use the category and tracelevel to compute the result.
983            if (ref $traceLevel) {
984                Confess("Bad trace level.");
985            } elsif (ref $TraceLevel) {
986                Confess("Bad trace config.");
987            }
988            $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
989          }          }
990          # Return the computed result.          # Return the computed result.
991          return $retVal;          return $retVal;
# Line 435  Line 1067 
1067          return ($optionTable, @retVal);          return ($optionTable, @retVal);
1068  }  }
1069    
1070    =head3 Escape
1071    
1072    C<< my $codedString = Tracer::Escape($realString); >>
1073    
1074    Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1075    replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1076    result is to reverse the effect of L</UnEscape>.
1077    
1078    =over 4
1079    
1080    =item realString
1081    
1082    String to escape.
1083    
1084    =item RETURN
1085    
1086    Escaped equivalent of the real string.
1087    
1088    =back
1089    
1090    =cut
1091    
1092    sub Escape {
1093        # Get the parameter.
1094        my ($realString) = @_;
1095        # Initialize the return variable.
1096        my $retVal = "";
1097        # Loop through the parameter string, looking for sequences to escape.
1098        while (length $realString > 0) {
1099            # Look for the first sequence to escape.
1100            if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1101                # Here we found it. The text preceding the sequence is in $1. The sequence
1102                # itself is in $2. First, move the clear text to the return variable.
1103                $retVal .= $1;
1104                # Strip the processed section off the real string.
1105                $realString = substr $realString, (length $2) + (length $1);
1106                # Get the matched character.
1107                my $char = $2;
1108                # If we have a CR, we are done.
1109                if ($char ne "\r") {
1110                    # It's not a CR, so encode the escape sequence.
1111                    $char =~ tr/\t\n/tn/;
1112                    $retVal .= "\\" . $char;
1113                }
1114            } else {
1115                # Here there are no more escape sequences. The rest of the string is
1116                # transferred unmodified.
1117                $retVal .= $realString;
1118                $realString = "";
1119            }
1120        }
1121        # Return the result.
1122        return $retVal;
1123    }
1124    
1125  =head3 UnEscape  =head3 UnEscape
1126    
1127  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1128    
1129  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
1130  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
1131    be deleted.
1132    
1133  =over 4  =over 4
1134    
# Line 462  Line 1150 
1150          my ($codedString) = @_;          my ($codedString) = @_;
1151          # Initialize the return variable.          # Initialize the return variable.
1152          my $retVal = "";          my $retVal = "";
1153        # Only proceed if the incoming string is nonempty.
1154        if (defined $codedString) {
1155          # 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
1156          # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1157          # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1158          while (length $codedString > 0) {          while (length $codedString > 0) {
1159                  # Look for the first escape sequence.                  # Look for the first escape sequence.
1160                  if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1161                          # 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
1162                          # 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.
1163                          $retVal .= $1;                          $retVal .= $1;
1164                          $codedString = substr $codedString, (2 + length $1);                          $codedString = substr $codedString, (2 + length $1);
1165                          # Decode the escape sequence.                  # Get the escape value.
1166                          my $char = $2;                          my $char = $2;
1167                          $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1168                    if ($char ne 'r') {
1169                        # Here it's not an 'r', so we convert it.
1170                        $char =~ tr/\\tn/\\\t\n/;
1171                          $retVal .= $char;                          $retVal .= $char;
1172                    }
1173                  } else {                  } else {
1174                          # 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
1175                          # transferred unmodified.                          # transferred unmodified.
# Line 483  Line 1177 
1177                          $codedString = "";                          $codedString = "";
1178                  }                  }
1179          }          }
1180        }
1181          # Return the result.          # Return the result.
1182          return $retVal;          return $retVal;
1183  }  }
# Line 582  Line 1277 
1277    
1278  =head3 GetFile  =head3 GetFile
1279    
1280    C<< my @fileContents = Tracer::GetFile($fileName); >>
1281    
1282        or
1283    
1284  C<< my $fileContents = Tracer::GetFile($fileName); >>  C<< my $fileContents = Tracer::GetFile($fileName); >>
1285    
1286  Return the entire contents of a file.  Return the entire contents of a file. In list context, line-ends are removed and
1287    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1288    
1289  =over 4  =over 4
1290    
# Line 594  Line 1294 
1294    
1295  =item RETURN  =item RETURN
1296    
1297  Returns the entire file as a single string. If an error occurs, will return  In a list context, returns the entire file as a list with the line terminators removed.
1298  an empty string.  In a scalar context, returns the entire file as a string. If an error occurs opening
1299    the file, an empty list will be returned.
1300    
1301  =back  =back
1302    
# Line 605  Line 1306 
1306          # Get the parameters.          # Get the parameters.
1307          my ($fileName) = @_;          my ($fileName) = @_;
1308          # Declare the return variable.          # Declare the return variable.
1309          my $retVal = "";      my @retVal = ();
1310          # Open the file for input.          # Open the file for input.
1311          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1312          if (!$ok) {          if (!$ok) {
1313                  # If we had an error, trace it. We will automatically return a null string.          # If we had an error, trace it. We will automatically return a null value.
1314                  Trace(0, "Could not open \"$fileName\" for input.");          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1315          } else {          } else {
1316                  # Read the whole file into the return variable.          # Read the whole file into the return variable, stripping off any terminator
1317                  while (<INPUTFILE>) {          # characters.
1318                          $retVal .= $_;          my $lineCount = 0;
1319            while (my $line = <INPUTFILE>) {
1320                $lineCount++;
1321                $line = Strip($line);
1322                push @retVal, $line;
1323                  }                  }
1324                  # Close it.                  # Close it.
1325                  close INPUTFILE;                  close INPUTFILE;
1326            my $actualLines = @retVal;
1327        }
1328        # Return the file's contents in the desired format.
1329        if (wantarray) {
1330            return @retVal;
1331        } else {
1332            return join "\n", @retVal;
1333          }          }
         # Return the file's contents.  
         return $retVal;  
1334  }  }
1335    
1336  =head3 QTrace  =head3 QTrace
# Line 644  Line 1354 
1354          my ($format) = @_;          my ($format) = @_;
1355          # Create the return variable.          # Create the return variable.
1356          my $retVal = "";          my $retVal = "";
1357        # Only proceed if there is an actual queue.
1358        if (@Queue) {
1359          # Process according to the format.          # Process according to the format.
1360          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1361                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 659  Line 1371 
1371          }          }
1372          # Clear the queue.          # Clear the queue.
1373          @Queue = ();          @Queue = ();
1374        }
1375          # Return the formatted list.          # Return the formatted list.
1376          return $retVal;          return $retVal;
1377  }  }
# Line 667  Line 1380 
1380    
1381  C<< Confess($message); >>  C<< Confess($message); >>
1382    
1383  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
1384  trace will only appear if the trace level for this package is 1 or more. When used with  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.
1385  the OR operator, this method can function as a debugging assert. So, for example  So, for example
1386    
1387  C<< ($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
1388    
1389  Will abort the program with a stack trace if the value of C<$recNum> is negative.  Will abort the program with a stack trace if the value of C<$recNum> is negative.
1390    
# Line 689  Line 1402 
1402          # Get the parameters.          # Get the parameters.
1403          my ($message) = @_;          my ($message) = @_;
1404          # Trace the call stack.          # Trace the call stack.
1405          Cluck($message) if T(1);      Cluck($message);
1406          # Abort the program.          # Abort the program.
1407          die $message;      croak(">>> $message");
1408    }
1409    
1410    =head3 Assert
1411    
1412    C<< Assert($condition1, $condition2, ... $conditionN); >>
1413    
1414    Return TRUE if all the conditions are true. This method can be used in conjunction with
1415    the OR operator and the L</Confess> method as a debugging assert.
1416    So, for example
1417    
1418    C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
1419    
1420    Will abort the program with a stack trace if the value of C<$recNum> is negative.
1421    
1422    =cut
1423    sub Assert {
1424        my $retVal = 1;
1425        LOOP: for my $condition (@_) {
1426            if (! $condition) {
1427                $retVal = 0;
1428                last LOOP;
1429            }
1430        }
1431        return $retVal;
1432  }  }
1433    
1434  =head3 Cluck  =head3 Cluck
# Line 718  Line 1455 
1455  sub Cluck {  sub Cluck {
1456          # Get the parameters.          # Get the parameters.
1457          my ($message) = @_;          my ($message) = @_;
1458        # Trace what's happening.
1459        Trace("Stack trace for event: $message");
1460          my $confession = longmess($message);          my $confession = longmess($message);
1461          # Convert the confession to a series of trace messages.      # Convert the confession to a series of trace messages. Note we skip any
1462        # messages relating to calls into Tracer.
1463          for my $line (split /\s*\n/, $confession) {          for my $line (split /\s*\n/, $confession) {
1464                  Trace($line);          Trace($line) if ($line !~ /Tracer\.pm/);
1465        }
1466    }
1467    
1468    =head3 Min
1469    
1470    C<< my $min = Min($value1, $value2, ... $valueN); >>
1471    
1472    Return the minimum argument. The arguments are treated as numbers.
1473    
1474    =over 4
1475    
1476    =item $value1, $value2, ... $valueN
1477    
1478    List of numbers to compare.
1479    
1480    =item RETURN
1481    
1482    Returns the lowest number in the list.
1483    
1484    =back
1485    
1486    =cut
1487    
1488    sub Min {
1489        # Get the parameters. Note that we prime the return value with the first parameter.
1490        my ($retVal, @values) = @_;
1491        # Loop through the remaining parameters, looking for the lowest.
1492        for my $value (@values) {
1493            if ($value < $retVal) {
1494                $retVal = $value;
1495          }          }
1496  }  }
1497        # Return the minimum found.
1498        return $retVal;
1499    }
1500    
1501    =head3 Max
1502    
1503    C<< my $max = Max($value1, $value2, ... $valueN); >>
1504    
1505    Return the maximum argument. The arguments are treated as numbers.
1506    
1507    =over 4
1508    
1509    =item $value1, $value2, ... $valueN
1510    
1511    List of numbers to compare.
1512    
1513    =item RETURN
1514    
1515    Returns the highest number in the list.
1516    
1517    =back
1518    
1519    =cut
1520    
1521    sub Max {
1522        # Get the parameters. Note that we prime the return value with the first parameter.
1523        my ($retVal, @values) = @_;
1524        # Loop through the remaining parameters, looking for the highest.
1525        for my $value (@values) {
1526            if ($value > $retVal) {
1527                $retVal = $value;
1528            }
1529        }
1530        # Return the maximum found.
1531        return $retVal;
1532    }
1533    
1534    =head3 AddToListMap
1535    
1536    C<< Tracer::AddToListMap(\%hash, $key, $value); >>
1537    
1538    Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list
1539    is created for the key. Otherwise, the new value is pushed onto the list.
1540    
1541    =over 4
1542    
1543    =item hash
1544    
1545    Reference to the target hash.
1546    
1547    =item key
1548    
1549    Key for which the value is to be added.
1550    
1551    =item value
1552    
1553    Value to add to the key's value list.
1554    
1555    =back
1556    
1557    =cut
1558    
1559    sub AddToListMap {
1560        # Get the parameters.
1561        my ($hash, $key, $value) = @_;
1562        # Process according to whether or not the key already has a value.
1563        if (! exists $hash->{$key}) {
1564            $hash->{$key} = [$value];
1565        } else {
1566            push @{$hash->{$key}}, $value;
1567        }
1568    }
1569    
1570    =head3 DebugMode
1571    
1572    C<< if (Tracer::DebugMode) { ...code... } >>
1573    
1574    Return TRUE if debug mode has been turned on, else output an error
1575    page and return FALSE.
1576    
1577    Certain CGI scripts are too dangerous to exist in the production
1578    environment. This method provides a simple way to prevent them
1579    from working unless they are explicitly turned on by creating a password
1580    cookie via the B<SetPassword> script.  If debugging mode
1581    is not turned on, an error web page will be output directing the
1582    user to enter in the correct password.
1583    
1584    =cut
1585    
1586    sub DebugMode {
1587        # Declare the return variable.
1588        my $retVal = 0;
1589        # Check the debug configuration.
1590        my $password = CGI::cookie("DebugMode");
1591        my $encrypted = Digest::MD5::md5_hex($password);
1592        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1593            $retVal = 1;
1594        } else {
1595            # Here debug mode is off, so we generate an error page.
1596            my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");
1597            print $pageString;
1598        }
1599        # Return the determination indicator.
1600        return $retVal;
1601    }
1602    
1603    =head3 Strip
1604    
1605    C<< my $string = Tracer::Strip($line); >>
1606    
1607    Strip all line terminators off a string. This is necessary when dealing with files
1608    that may have been transferred back and forth several times among different
1609    operating environments.
1610    
1611    =over 4
1612    
1613    =item line
1614    
1615    Line of text to be stripped.
1616    
1617    =item RETURN
1618    
1619    The same line of text with all the line-ending characters chopped from the end.
1620    
1621    =back
1622    
1623    =cut
1624    
1625    sub Strip {
1626        # Get a copy of the parameter string.
1627        my ($string) = @_;
1628        my $retVal = (defined $string ? $string : "");
1629        # Strip the line terminator characters.
1630        $retVal =~ s/(\r|\n)+$//g;
1631        # Return the result.
1632        return $retVal;
1633    }
1634    
1635    =head3 Pad
1636    
1637    C<< my $paddedString = Tracer::Pad($string, $len, $left, $padChar); >>
1638    
1639    Pad a string to a specified length. The pad character will be a
1640    space, and the padding will be on the right side unless specified
1641    in the third parameter.
1642    
1643    =over 4
1644    
1645    =item string
1646    
1647    String to be padded.
1648    
1649    =item len
1650    
1651    Desired length of the padded string.
1652    
1653    =item left (optional)
1654    
1655    TRUE if the string is to be left-padded; otherwise it will be padded on the right.
1656    
1657    =item padChar (optional)
1658    
1659    Character to use for padding. The default is a space.
1660    
1661    =item RETURN
1662    
1663    Returns a copy of the original string with the pad character added to the
1664    specified end so that it achieves the desired length.
1665    
1666    =back
1667    
1668    =cut
1669    
1670    sub Pad {
1671        # Get the parameters.
1672        my ($string, $len, $left, $padChar) = @_;
1673        # Compute the padding character.
1674        if (! defined $padChar) {
1675            $padChar = " ";
1676        }
1677        # Compute the number of spaces needed.
1678        my $needed = $len - length $string;
1679        # Copy the string into the return variable.
1680        my $retVal = $string;
1681        # Only proceed if padding is needed.
1682        if ($needed > 0) {
1683            # Create the pad string.
1684            my $pad = $padChar x $needed;
1685            # Affix it to the return value.
1686            if ($left) {
1687                $retVal = $pad . $retVal;
1688            } else {
1689                $retVal .= $pad;
1690            }
1691        }
1692        # Return the result.
1693        return $retVal;
1694    }
1695    
1696    =head3 EOF
1697    
1698    This is a constant that is lexically greater than any useful string.
1699    
1700    =cut
1701    
1702    sub EOF {
1703        return "\xFF\xFF\xFF\xFF\xFF";
1704    }
1705    
1706    =head3 TICK
1707    
1708    C<< my @results = TICK($commandString); >>
1709    
1710    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1711    dot-slash (C<./> will be removed. So, for example, if you were doing
1712    
1713        `./protein.cgi`
1714    
1715    from inside a CGI script, it would work fine in Unix, but would issue an error message
1716    in Windows complaining that C<'.'> is not a valid command. If instead you code
1717    
1718        TICK("./protein.cgi")
1719    
1720    it will work correctly in both environments.
1721    
1722    =over 4
1723    
1724    =item commandString
1725    
1726    The command string to pass to the system.
1727    
1728    =item RETURN
1729    
1730    Returns the standard output from the specified command, as a list.
1731    
1732    =back
1733    
1734    =cut
1735    #: Return Type @;
1736    sub TICK {
1737        # Get the parameters.
1738        my ($commandString) = @_;
1739        # Chop off the dot-slash if this is Windows.
1740        if ($FIG_Config::win_mode) {
1741            $commandString =~ s!^\./!!;
1742        }
1743        # Activate the command and return the result.
1744        return `$commandString`;
1745    }
1746    
1747    =head3 ScriptSetup
1748    
1749    C<< my ($query, $varHash) = ScriptSetup(); >>
1750    
1751    Perform standard tracing and debugging setup for scripts. The value returned is
1752    the CGI object followed by a pre-built variable hash.
1753    
1754    The C<Trace> query parameter is used to determine whether or not tracing is active and
1755    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1756    the C<CGI> trace module will trace parameter and environment information. Parameters are
1757    traced at level 3 and environment variables at level 4. At the end of the script, the
1758    client should call L</ScriptFinish> to output the web page.
1759    
1760    =cut
1761    
1762    sub ScriptSetup {
1763        # Get the CGI query object.
1764        my $query = CGI->new();
1765        # Check for tracing. Set it up if the user asked for it.
1766        if ($query->param('Trace')) {
1767            # Set up tracing to be queued for display at the bottom of the web page.
1768            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1769            # Trace the parameter and environment data.
1770            if (T(CGI => 3)) {
1771                # Here we want to trace the parameter data.
1772                my @names = $query->param;
1773                for my $parmName (sort @names) {
1774                    # Note we skip "Trace", which is for our use only.
1775                    if ($parmName ne 'Trace') {
1776                        my @values = $query->param($parmName);
1777                        Trace("CGI: $parmName = " . join(", ", @values));
1778                    }
1779                }
1780            }
1781            if (T(CGI => 4)) {
1782                # Here we want the environment data too.
1783                for my $envName (sort keys %ENV) {
1784                    Trace("ENV: $envName = $ENV{$envName}");
1785                }
1786            }
1787        } else {
1788            # Here tracing is to be turned off. All we allow is errors traced into the
1789            # error log.
1790            TSetup("0", "WARN");
1791        }
1792        # Create the variable hash.
1793        my $varHash = { DebugData => '' };
1794        # If we're in DEBUG mode, set up the debug mode data for forms.
1795        if (Tracer::DebugMode) {
1796            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1797        }
1798        # Return the query object and variable hash.
1799        return ($query, $varHash);
1800    }
1801    
1802    =head3 ScriptFinish
1803    
1804    C<< ScriptFinish($webData, $varHash); >>
1805    
1806    Output a web page at the end of a script. Either the string to be output or the
1807    name of a template file can be specified. If the second parameter is omitted,
1808    it is assumed we have a string to be output; otherwise, it is assumed we have the
1809    name of a template file. The template should have the variable C<DebugData>
1810    specified in any form that invokes a standard script. If debugging mode is turned
1811    on, a form field will be put in that allows the user to enter tracing data.
1812    Trace messages will be placed immediately before the terminal C<BODY> tag in
1813    the output, formatted as a list.
1814    
1815    A typical standard script would loook like the following.
1816    
1817        BEGIN {
1818            # Print the HTML header.
1819            print "CONTENT-TYPE: text/html\n\n";
1820        }
1821        use Tracer;
1822        use CGI;
1823        use FIG;
1824        # ... more uses ...
1825    
1826        my ($query, $varHash) = ScriptSetup();
1827        eval {
1828            # ... get data from $query, put it in $varHash ...
1829        };
1830        if ($@) {
1831            Trace("Script Error: $@") if T(0);
1832        }
1833        ScriptFinish("Html/MyTemplate.html", $varHash);
1834    
1835    The idea here is that even if the script fails, you'll see trace messages and
1836    useful output.
1837    
1838    =over 4
1839    
1840    =item webData
1841    
1842    A string containing either the full web page to be written to the output or the
1843    name of a template file from which the page is to be constructed. If the name
1844    of a template file is specified, then the second parameter must be present;
1845    otherwise, it must be absent.
1846    
1847    =item varHash (optional)
1848    
1849    If specified, then a reference to a hash mapping variable names for a template
1850    to their values. The template file will be read into memory, and variable markers
1851    will be replaced by data in this hash reference.
1852    
1853    =back
1854    
1855    =cut
1856    
1857    sub ScriptFinish {
1858        # Get the parameters.
1859        my ($webData, $varHash) = @_;
1860        # Check for a template file situation.
1861        my $outputString;
1862        if (defined $varHash) {
1863            # Here we have a template file. We need to apply the variables to the template.
1864            $outputString = PageBuilder::Build("<$webData", $varHash, "Html");
1865        } else {
1866            # Here the user gave us a raw string.
1867            $outputString = $webData;
1868        }
1869        # Check for trace messages.
1870        if ($Destination eq "QUEUE") {
1871            # We have trace messages, so we want to put them at the end of the body. This
1872            # is either at the end of the whole string or at the beginning of the BODY
1873            # end-tag.
1874            my $pos = length $outputString;
1875            if ($outputString =~ m#</body>#gi) {
1876                $pos = (pos $outputString) - 7;
1877            }
1878            substr $outputString, $pos, 0, QTrace('Html');
1879        }
1880        # Write the output string.
1881        print $outputString;
1882    }
1883    
1884    =head3 Insure
1885    
1886    C<< Insure($dirName); >>
1887    
1888    Insure a directory is present.
1889    
1890    =over 4
1891    
1892    =item dirName
1893    
1894    Name of the directory to check. If it does not exist, it will be created.
1895    
1896    =back
1897    
1898    =cut
1899    
1900    sub Insure {
1901        my ($dirName) = @_;
1902        if (! -d $dirName) {
1903            Trace("Creating $dirName directory.") if T(2);
1904            mkpath $dirName;
1905        }
1906    }
1907    
1908  1;  1;

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.39

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3