[Bio] / FigKernelPackages / Tracer.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/Tracer.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6, Mon Mar 7 02:01:51 2005 UTC revision 1.40, Wed Mar 15 21:55:08 2006 UTC
# Line 1  Line 1 
1    #
2    # Copyright (c) 2003-2006 University of Chicago and Fellowship
3    # for Interpretations of Genomes. All Rights Reserved.
4    #
5    # This file is part of the SEED Toolkit.
6    #
7    # The SEED Toolkit is free software. You can redistribute
8    # it and/or modify it under the terms of the SEED Toolkit
9    # Public License.
10    #
11    # You should have received a copy of the SEED Toolkit Public License
12    # along with this program; if not write to the University of Chicago
13    # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14    # Genomes at veronika@thefig.info or download a copy from
15    # http://www.theseed.org/LICENSE.TXT.
16    #
17    
18  package Tracer;  package Tracer;
19    
20          require Exporter;          require Exporter;
21          @ISA = ('Exporter');          @ISA = ('Exporter');
22          @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup ScriptSetup ScriptFinish 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); >>
# 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 59  Line 86 
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 $TeeFlag = 0;            # TRUE if output is going to a file and to the
125                                # standard output
126  my %Categories = ( main => 1 );  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 90  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 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
157  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
158    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<ERROR> will cause trace  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace
160  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
161  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
# Line 110  Line 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        # Verify that we can open a file in the temporary directory.
407        my $traceMode = "TEXT";
408        my $suffix = $retOptions->{user};
409        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
410        if (open TESTTRACE, ">$traceFileName") {
411            $traceMode = "+>$traceFileName";
412            close TESTTRACE;
413        }
414        # Now set up the tracing.
415        TSetup($cats, $traceMode);
416        # Check for the "h" option. If it is specified, dump the command-line
417        # options and exit the program.
418        if ($retOptions->{h}) {
419            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
420            Trace("$1 [options] $parmHelp") if T(0);
421            for my $key (sort keys %{$options}) {
422                my $name = Pad($key, $longestName, 0, ' ');
423                my $desc = $options->{$key}->[1];
424                if ($options->{$key}->[0]) {
425                    $desc .= " (default " . $options->{$key}->[0] . ")";
426                }
427                Trace("  $name $desc") if T(0);
428            }
429            exit(0);
430        }
431        # Return the parsed parameters.
432        return ($retOptions, @retParameters);
433    }
434    
435    =head3 Setups
436    
437    C<< my $count = Tracer::Setups(); >>
438    
439    Return the number of times L</TSetup> has been called.
440    
441    This method allows for the creation of conditional tracing setups where, for example, we
442    may want to set up tracing if nobody else has done it before us.
443    
444    =cut
445    
446    sub Setups {
447        return $SetupCount;
448    }
449    
450    =head3 Open
451    
452    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
453    
454    Open a file.
455    
456    The I<$fileSpec> is essentially the second argument of the PERL C<open>
457    function. The mode is specified using Unix-like shell information. So, for
458    example,
459    
460        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
461    
462    would open for output appended to the specified file, and
463    
464        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
465    
466    would open a pipe that sorts the records written and removes duplicates. Note
467    the use of file handle syntax in the Open call. To use anonymous file handles,
468    code as follows.
469    
470        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
471    
472    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
473    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
474    failed open will throw an exception and the third parameter will be used to construct
475    an error message. If the parameter is omitted, a standard message is constructed
476    using the file spec.
477    
478        Could not open "/usr/spool/news/twitlog"
479    
480    Note that the mode characters are automatically cleaned from the file name.
481    The actual error message from the file system will be captured and appended to the
482    message in any case.
483    
484        Could not open "/usr/spool/news/twitlog": file not found.
485    
486    In some versions of PERL the only error message we get is a number, which
487    corresponds to the C++ C<errno> value.
488    
489        Could not open "/usr/spool/news/twitlog": 6.
490    
491    =over 4
492    
493    =item fileHandle
494    
495    File handle. If this parameter is C<undef>, a file handle will be generated
496    and returned as the value of this method.
497    
498    =item fileSpec
499    
500    File name and mode, as per the PERL C<open> function.
501    
502    =item message (optional)
503    
504    Error message to use if the open fails. If omitted, a standard error message
505    will be generated. In either case, the error information from the file system
506    is appended to the message. To specify a conditional open that does not throw
507    an error if it fails, use C<0>.
508    
509    =item RETURN
510    
511    Returns the name of the file handle assigned to the file, or C<undef> if the
512    open failed.
513    
514    =back
515    
516    =cut
517    
518    sub Open {
519        # Get the parameters.
520        my ($fileHandle, $fileSpec, $message) = @_;
521        # Attempt to open the file.
522        my $rv = open $fileHandle, $fileSpec;
523        # If the open failed, generate an error message.
524        if (! $rv) {
525            # Save the system error message.
526            my $sysMessage = $!;
527            # See if we need a default message.
528            if (!$message) {
529                # Clean any obvious mode characters and leading spaces from the
530                # filename.
531                my ($fileName) = FindNamePart($fileSpec);
532                $message = "Could not open \"$fileName\"";
533            }
534            # Terminate with an error using the supplied message and the
535            # error message from the file system.
536            Confess("$message: $!");
537        }
538        # Return the file handle.
539        return $fileHandle;
540    }
541    
542    =head3 FindNamePart
543    
544    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
545    
546    Extract the portion of a file specification that contains the file name.
547    
548    A file specification is the string passed to an C<open> call. It specifies the file
549    mode and name. In a truly complex situation, it can specify a pipe sequence. This
550    method assumes that the file name is whatever follows the first angle bracket
551    sequence.  So, for example, in the following strings the file name is
552    C</usr/fig/myfile.txt>.
553    
554        >>/usr/fig/myfile.txt
555        </usr/fig/myfile.txt
556        | sort -u > /usr/fig/myfile.txt
557    
558    If the method cannot find a file name using its normal methods, it will return the
559    whole incoming string.
560    
561    =over 4
562    
563    =item fileSpec
564    
565    File specification string from which the file name is to be extracted.
566    
567    =item RETURN
568    
569    Returns a three-element list. The first element contains the file name portion of
570    the specified string, or the whole string if a file name cannot be found via normal
571    methods. The second element contains the start position of the file name portion and
572    the third element contains the length.
573    
574    =back
575    
576    =cut
577    #: Return Type $;
578    sub FindNamePart {
579        # Get the parameters.
580        my ($fileSpec) = @_;
581        # Default to the whole input string.
582        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
583        # Parse out the file name if we can.
584        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
585            $retVal = $2;
586            $len = length $retVal;
587            $pos = (length $fileSpec) - (length $3) - $len;
588        }
589        # Return the result.
590        return ($retVal, $pos, $len);
591    }
592    
593    =head3 OpenDir
594    
595    C<< my @files = OpenDir($dirName, $filtered, $flag); >>
596    
597    Open a directory and return all the file names. This function essentially performs
598    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
599    set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
600    or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
601    filtered out of the return list. If the directory does not open and I<$flag> is not
602    set, an exception is thrown. So, for example,
603    
604        my @files = OpenDir("/Volumes/fig/contigs", 1);
605    
606    is effectively the same as
607    
608        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
609        my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
610    
611    Similarly, the following code
612    
613        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
614    
615    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
616    automatically returns an empty list if the directory fails to open.
617    
618    =over 4
619    
620    =item dirName
621    
622    Name of the directory to open.
623    
624    =item filtered
625    
626    TRUE if files whose names begin with a period (C<.>) should be automatically removed
627    from the list, else FALSE.
628    
629    =item flag
630    
631    TRUE if a failure to open is okay, else FALSE
632    
633    =back
634    
635    =cut
636    #: Return Type @;
637    sub OpenDir {
638        # Get the parameters.
639        my ($dirName, $filtered, $flag) = @_;
640        # Declare the return variable.
641        my @retVal = ();
642        # Open the directory.
643        if (opendir(my $dirHandle, $dirName)) {
644            # The directory opened successfully. Get the appropriate list according to the
645            # strictures of the filter parameter.
646            if ($filtered) {
647                @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
648            } else {
649                @retVal = readdir $dirHandle;
650            }
651        } elsif (! $flag) {
652            # Here the directory would not open and it's considered an error.
653            Confess("Could not open directory $dirName.");
654        }
655        # Return the result.
656        return @retVal;
657  }  }
658    
659  =head3 SetLevel  =head3 SetLevel
# Line 370  Line 899 
899          my ($message) = @_;          my ($message) = @_;
900          # Get the timestamp.          # Get the timestamp.
901          my $timeStamp = Now();          my $timeStamp = Now();
902          # Format the message.      # Format the message. Note we strip off any line terminators at the end.
903          my $formatted = "$timeStamp $message";      my $formatted = "$timeStamp <$LastCategory>: " . Strip($message);
904          # Process according to the destination.          # Process according to the destination.
905          if ($Destination eq "TEXT") {          if ($Destination eq "TEXT") {
906                  # Write the message to the standard output.                  # Write the message to the standard output.
# Line 391  Line 920 
920         warn $message;         warn $message;
921          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
922                  # Write the trace message to an output file.                  # Write the trace message to an output file.
923                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
924                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
925                  close TRACING;                  close TRACING;
926            # If the Tee flag is on, echo it to the standard output.
927            if ($TeeFlag) {
928                print "$formatted\n";
929            }
930          }          }
931  }  }
932    
# Line 436  Line 969 
969                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
970                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
971                          # 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.
972                # The calling package is normally the first parameter. If it is
973                # omitted, the first parameter will be the tracelevel. So, the
974                # first thing we do is shift the so-called category into the
975                # $traceLevel variable where it belongs.
976                          $traceLevel = $category;                          $traceLevel = $category;
977                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
978              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 445  Line 982 
982                                  $category = $package;                                  $category = $package;
983                          }                          }
984                  }                  }
985                  # Use the package and tracelevel to compute the result.          # Save the category name.
986                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          $LastCategory = $category;
987            # Convert it to lower case before we hash it.
988            $category = lc $category;
989            # Use the category and tracelevel to compute the result.
990            if (ref $traceLevel) {
991                Confess("Bad trace level.");
992            } elsif (ref $TraceLevel) {
993                Confess("Bad trace config.");
994            }
995            $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
996      }      }
997          # Return the computed result.          # Return the computed result.
998      return $retVal;      return $retVal;
# Line 528  Line 1074 
1074          return ($optionTable, @retVal);          return ($optionTable, @retVal);
1075  }  }
1076    
1077    =head3 Escape
1078    
1079    C<< my $codedString = Tracer::Escape($realString); >>
1080    
1081    Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1082    replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1083    result is to reverse the effect of L</UnEscape>.
1084    
1085    =over 4
1086    
1087    =item realString
1088    
1089    String to escape.
1090    
1091    =item RETURN
1092    
1093    Escaped equivalent of the real string.
1094    
1095    =back
1096    
1097    =cut
1098    
1099    sub Escape {
1100        # Get the parameter.
1101        my ($realString) = @_;
1102        # Initialize the return variable.
1103        my $retVal = "";
1104        # Loop through the parameter string, looking for sequences to escape.
1105        while (length $realString > 0) {
1106            # Look for the first sequence to escape.
1107            if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1108                # Here we found it. The text preceding the sequence is in $1. The sequence
1109                # itself is in $2. First, move the clear text to the return variable.
1110                $retVal .= $1;
1111                # Strip the processed section off the real string.
1112                $realString = substr $realString, (length $2) + (length $1);
1113                # Get the matched character.
1114                my $char = $2;
1115                # If we have a CR, we are done.
1116                if ($char ne "\r") {
1117                    # It's not a CR, so encode the escape sequence.
1118                    $char =~ tr/\t\n/tn/;
1119                    $retVal .= "\\" . $char;
1120                }
1121            } else {
1122                # Here there are no more escape sequences. The rest of the string is
1123                # transferred unmodified.
1124                $retVal .= $realString;
1125                $realString = "";
1126            }
1127        }
1128        # Return the result.
1129        return $retVal;
1130    }
1131    
1132  =head3 UnEscape  =head3 UnEscape
1133    
1134  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1135    
1136  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
1137  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
1138    be deleted.
1139    
1140  =over 4  =over 4
1141    
# Line 555  Line 1157 
1157          my ($codedString) = @_;          my ($codedString) = @_;
1158          # Initialize the return variable.          # Initialize the return variable.
1159          my $retVal = "";          my $retVal = "";
1160        # Only proceed if the incoming string is nonempty.
1161        if (defined $codedString) {
1162          # 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
1163          # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1164          # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1165          while (length $codedString > 0) {          while (length $codedString > 0) {
1166                  # Look for the first escape sequence.                  # Look for the first escape sequence.
1167                  if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1168                          # 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
1169                          # 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.
1170                          $retVal .= $1;                          $retVal .= $1;
1171                          $codedString = substr $codedString, (2 + length $1);                          $codedString = substr $codedString, (2 + length $1);
1172                          # Decode the escape sequence.                  # Get the escape value.
1173                          my $char = $2;                          my $char = $2;
1174                          $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1175                    if ($char ne 'r') {
1176                        # Here it's not an 'r', so we convert it.
1177                        $char =~ tr/\\tn/\\\t\n/;
1178                          $retVal .= $char;                          $retVal .= $char;
1179                    }
1180                  } else {                  } else {
1181                          # 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
1182                          # transferred unmodified.                          # transferred unmodified.
# Line 576  Line 1184 
1184                          $codedString = "";                          $codedString = "";
1185                  }                  }
1186          }          }
1187        }
1188          # Return the result.          # Return the result.
1189          return $retVal;          return $retVal;
1190  }  }
# Line 677  Line 1286 
1286    
1287  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1288    
1289  Return the entire contents of a file.      or
1290    
1291    C<< my $fileContents = Tracer::GetFile($fileName); >>
1292    
1293    Return the entire contents of a file. In list context, line-ends are removed and
1294    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1295    
1296  =over 4  =over 4
1297    
# Line 688  Line 1302 
1302  =item RETURN  =item RETURN
1303    
1304  In a list context, returns the entire file as a list with the line terminators removed.  In a list context, returns the entire file as a list with the line terminators removed.
1305  In a scalar context, returns the entire file as a string.  In a scalar context, returns the entire file as a string. If an error occurs opening
1306    the file, an empty list will be returned.
1307    
1308  =back  =back
1309    
# Line 703  Line 1318 
1318          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1319          if (!$ok) {          if (!$ok) {
1320                  # 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.
1321                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1322          } else {          } else {
1323                  # Read the whole file into the return variable, stripping off an terminator          # Read the whole file into the return variable, stripping off any terminator
1324          # characters.          # characters.
1325          my $lineCount = 0;          my $lineCount = 0;
1326                  while (my $line = <INPUTFILE>) {                  while (my $line = <INPUTFILE>) {
1327              $lineCount++;              $lineCount++;
1328              $line =~ s/(\r|\n)+$//g;              $line = Strip($line);
1329                          push @retVal, $line;                          push @retVal, $line;
1330                  }                  }
1331                  # Close it.                  # Close it.
1332                  close INPUTFILE;                  close INPUTFILE;
1333          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(0);  
1334          }          }
1335          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1336      if (wantarray) {      if (wantarray) {
# Line 747  Line 1361 
1361          my ($format) = @_;          my ($format) = @_;
1362          # Create the return variable.          # Create the return variable.
1363          my $retVal = "";          my $retVal = "";
1364        # Only proceed if there is an actual queue.
1365        if (@Queue) {
1366          # Process according to the format.          # Process according to the format.
1367          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1368                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 762  Line 1378 
1378          }          }
1379          # Clear the queue.          # Clear the queue.
1380          @Queue = ();          @Queue = ();
1381        }
1382          # Return the formatted list.          # Return the formatted list.
1383          return $retVal;          return $retVal;
1384  }  }
# Line 770  Line 1387 
1387    
1388  C<< Confess($message); >>  C<< Confess($message); >>
1389    
1390  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  
1391  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.
1392  So, for example  So, for example
1393    
# Line 793  Line 1409 
1409          # Get the parameters.          # Get the parameters.
1410          my ($message) = @_;          my ($message) = @_;
1411          # Trace the call stack.          # Trace the call stack.
1412          Cluck($message) if T(1);      Cluck($message);
1413          # Abort the program.          # Abort the program.
1414          croak(">>> $message");          croak(">>> $message");
1415  }  }
# Line 803  Line 1419 
1419  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1420    
1421  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
1422  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.
1423  So, for example  So, for example
1424    
1425  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 958  Line 1574 
1574      }      }
1575  }  }
1576    
1577    =head3 DebugMode
1578    
1579    C<< if (Tracer::DebugMode) { ...code... } >>
1580    
1581    Return TRUE if debug mode has been turned on, else output an error
1582    page and return FALSE.
1583    
1584    Certain CGI scripts are too dangerous to exist in the production
1585    environment. This method provides a simple way to prevent them
1586    from working unless they are explicitly turned on by creating a password
1587    cookie via the B<SetPassword> script.  If debugging mode
1588    is not turned on, an error web page will be output directing the
1589    user to enter in the correct password.
1590    
1591    =cut
1592    
1593    sub DebugMode {
1594        # Declare the return variable.
1595        my $retVal = 0;
1596        # Check the debug configuration.
1597        my $password = CGI::cookie("DebugMode");
1598        my $encrypted = Digest::MD5::md5_hex($password);
1599        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1600            $retVal = 1;
1601        } else {
1602            # Here debug mode is off, so we generate an error page.
1603            my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");
1604            print $pageString;
1605        }
1606        # Return the determination indicator.
1607        return $retVal;
1608    }
1609    
1610    =head3 Strip
1611    
1612    C<< my $string = Tracer::Strip($line); >>
1613    
1614    Strip all line terminators off a string. This is necessary when dealing with files
1615    that may have been transferred back and forth several times among different
1616    operating environments.
1617    
1618    =over 4
1619    
1620    =item line
1621    
1622    Line of text to be stripped.
1623    
1624    =item RETURN
1625    
1626    The same line of text with all the line-ending characters chopped from the end.
1627    
1628    =back
1629    
1630    =cut
1631    
1632    sub Strip {
1633        # Get a copy of the parameter string.
1634        my ($string) = @_;
1635        my $retVal = (defined $string ? $string : "");
1636        # Strip the line terminator characters.
1637        $retVal =~ s/(\r|\n)+$//g;
1638        # Return the result.
1639        return $retVal;
1640    }
1641    
1642    =head3 Pad
1643    
1644    C<< my $paddedString = Tracer::Pad($string, $len, $left, $padChar); >>
1645    
1646    Pad a string to a specified length. The pad character will be a
1647    space, and the padding will be on the right side unless specified
1648    in the third parameter.
1649    
1650    =over 4
1651    
1652    =item string
1653    
1654    String to be padded.
1655    
1656    =item len
1657    
1658    Desired length of the padded string.
1659    
1660    =item left (optional)
1661    
1662    TRUE if the string is to be left-padded; otherwise it will be padded on the right.
1663    
1664    =item padChar (optional)
1665    
1666    Character to use for padding. The default is a space.
1667    
1668    =item RETURN
1669    
1670    Returns a copy of the original string with the pad character added to the
1671    specified end so that it achieves the desired length.
1672    
1673    =back
1674    
1675    =cut
1676    
1677    sub Pad {
1678        # Get the parameters.
1679        my ($string, $len, $left, $padChar) = @_;
1680        # Compute the padding character.
1681        if (! defined $padChar) {
1682            $padChar = " ";
1683        }
1684        # Compute the number of spaces needed.
1685        my $needed = $len - length $string;
1686        # Copy the string into the return variable.
1687        my $retVal = $string;
1688        # Only proceed if padding is needed.
1689        if ($needed > 0) {
1690            # Create the pad string.
1691            my $pad = $padChar x $needed;
1692            # Affix it to the return value.
1693            if ($left) {
1694                $retVal = $pad . $retVal;
1695            } else {
1696                $retVal .= $pad;
1697            }
1698        }
1699        # Return the result.
1700        return $retVal;
1701    }
1702    
1703    =head3 EOF
1704    
1705    This is a constant that is lexically greater than any useful string.
1706    
1707    =cut
1708    
1709    sub EOF {
1710        return "\xFF\xFF\xFF\xFF\xFF";
1711    }
1712    
1713    =head3 TICK
1714    
1715    C<< my @results = TICK($commandString); >>
1716    
1717    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1718    dot-slash (C<./> will be removed. So, for example, if you were doing
1719    
1720        `./protein.cgi`
1721    
1722    from inside a CGI script, it would work fine in Unix, but would issue an error message
1723    in Windows complaining that C<'.'> is not a valid command. If instead you code
1724    
1725        TICK("./protein.cgi")
1726    
1727    it will work correctly in both environments.
1728    
1729    =over 4
1730    
1731    =item commandString
1732    
1733    The command string to pass to the system.
1734    
1735    =item RETURN
1736    
1737    Returns the standard output from the specified command, as a list.
1738    
1739    =back
1740    
1741    =cut
1742    #: Return Type @;
1743    sub TICK {
1744        # Get the parameters.
1745        my ($commandString) = @_;
1746        # Chop off the dot-slash if this is Windows.
1747        if ($FIG_Config::win_mode) {
1748            $commandString =~ s!^\./!!;
1749        }
1750        # Activate the command and return the result.
1751        return `$commandString`;
1752    }
1753    
1754    =head3 ScriptSetup
1755    
1756    C<< my ($query, $varHash) = ScriptSetup(); >>
1757    
1758    Perform standard tracing and debugging setup for scripts. The value returned is
1759    the CGI object followed by a pre-built variable hash.
1760    
1761    The C<Trace> query parameter is used to determine whether or not tracing is active and
1762    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1763    the C<CGI> trace module will trace parameter and environment information. Parameters are
1764    traced at level 3 and environment variables at level 4. At the end of the script, the
1765    client should call L</ScriptFinish> to output the web page.
1766    
1767    =cut
1768    
1769    sub ScriptSetup {
1770        # Get the CGI query object.
1771        my $query = CGI->new();
1772        # Check for tracing. Set it up if the user asked for it.
1773        if ($query->param('Trace')) {
1774            # Set up tracing to be queued for display at the bottom of the web page.
1775            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1776            # Trace the parameter and environment data.
1777            if (T(CGI => 3)) {
1778                # Here we want to trace the parameter data.
1779                my @names = $query->param;
1780                for my $parmName (sort @names) {
1781                    # Note we skip "Trace", which is for our use only.
1782                    if ($parmName ne 'Trace') {
1783                        my @values = $query->param($parmName);
1784                        Trace("CGI: $parmName = " . join(", ", @values));
1785                    }
1786                }
1787            }
1788            if (T(CGI => 4)) {
1789                # Here we want the environment data too.
1790                for my $envName (sort keys %ENV) {
1791                    Trace("ENV: $envName = $ENV{$envName}");
1792                }
1793            }
1794        } else {
1795            # Here tracing is to be turned off. All we allow is errors traced into the
1796            # error log.
1797            TSetup("0", "WARN");
1798        }
1799        # Create the variable hash.
1800        my $varHash = { DebugData => '' };
1801        # If we're in DEBUG mode, set up the debug mode data for forms.
1802        if (Tracer::DebugMode) {
1803            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1804        }
1805        # Return the query object and variable hash.
1806        return ($query, $varHash);
1807    }
1808    
1809    =head3 ScriptFinish
1810    
1811    C<< ScriptFinish($webData, $varHash); >>
1812    
1813    Output a web page at the end of a script. Either the string to be output or the
1814    name of a template file can be specified. If the second parameter is omitted,
1815    it is assumed we have a string to be output; otherwise, it is assumed we have the
1816    name of a template file. The template should have the variable C<DebugData>
1817    specified in any form that invokes a standard script. If debugging mode is turned
1818    on, a form field will be put in that allows the user to enter tracing data.
1819    Trace messages will be placed immediately before the terminal C<BODY> tag in
1820    the output, formatted as a list.
1821    
1822    A typical standard script would loook like the following.
1823    
1824        BEGIN {
1825            # Print the HTML header.
1826            print "CONTENT-TYPE: text/html\n\n";
1827        }
1828        use Tracer;
1829        use CGI;
1830        use FIG;
1831        # ... more uses ...
1832    
1833        my ($query, $varHash) = ScriptSetup();
1834        eval {
1835            # ... get data from $query, put it in $varHash ...
1836        };
1837        if ($@) {
1838            Trace("Script Error: $@") if T(0);
1839        }
1840        ScriptFinish("Html/MyTemplate.html", $varHash);
1841    
1842    The idea here is that even if the script fails, you'll see trace messages and
1843    useful output.
1844    
1845    =over 4
1846    
1847    =item webData
1848    
1849    A string containing either the full web page to be written to the output or the
1850    name of a template file from which the page is to be constructed. If the name
1851    of a template file is specified, then the second parameter must be present;
1852    otherwise, it must be absent.
1853    
1854    =item varHash (optional)
1855    
1856    If specified, then a reference to a hash mapping variable names for a template
1857    to their values. The template file will be read into memory, and variable markers
1858    will be replaced by data in this hash reference.
1859    
1860    =back
1861    
1862    =cut
1863    
1864    sub ScriptFinish {
1865        # Get the parameters.
1866        my ($webData, $varHash) = @_;
1867        # Check for a template file situation.
1868        my $outputString;
1869        if (defined $varHash) {
1870            # Here we have a template file. We need to apply the variables to the template.
1871            $outputString = PageBuilder::Build("<$webData", $varHash, "Html");
1872        } else {
1873            # Here the user gave us a raw string.
1874            $outputString = $webData;
1875        }
1876        # Check for trace messages.
1877        if ($Destination eq "QUEUE") {
1878            # We have trace messages, so we want to put them at the end of the body. This
1879            # is either at the end of the whole string or at the beginning of the BODY
1880            # end-tag.
1881            my $pos = length $outputString;
1882            if ($outputString =~ m#</body>#gi) {
1883                $pos = (pos $outputString) - 7;
1884            }
1885            substr $outputString, $pos, 0, QTrace('Html');
1886        }
1887        # Write the output string.
1888        print $outputString;
1889    }
1890    
1891    =head3 Insure
1892    
1893    C<< Insure($dirName); >>
1894    
1895    Insure a directory is present.
1896    
1897    =over 4
1898    
1899    =item dirName
1900    
1901    Name of the directory to check. If it does not exist, it will be created.
1902    
1903    =back
1904    
1905    =cut
1906    
1907    sub Insure {
1908        my ($dirName) = @_;
1909        if (! -d $dirName) {
1910            Trace("Creating $dirName directory.") if T(2);
1911            mkpath $dirName;
1912        }
1913    }
1914    
1915  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3