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

Diff of /FigKernelPackages/Tracer.pm

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

revision 1.9, Wed May 4 03:05:12 2005 UTC revision 1.58, Thu Jun 29 19:02:48 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 ChDir);
23          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
24          use strict;          use strict;
25          use Carp qw(longmess croak);          use Carp qw(longmess croak);
26          use CGI;          use CGI;
27        use Cwd;
28          use FIG_Config;          use FIG_Config;
29      use PageBuilder;      use PageBuilder;
30        use Digest::MD5;
31        use File::Basename;
32        use File::Path;
33        use File::stat;
34    
35  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
36    
# Line 20  Line 42 
42  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
43  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
44  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
45  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
46  appear. To generate a trace message, use the following syntax.  appear. To generate a trace message, use the following syntax.
47    
48  C<< Trace($message) if T(errors => 4); >>  C<< Trace($message) if T(errors => 4); >>
# Line 38  Line 60 
60    
61  C<< Trace($message) if T(2); >>  C<< Trace($message) if T(2); >>
62    
63  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
64  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
65  specified as a space-delimited string. Thus  specified as a space-delimited string. Thus
66    
67  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
68    
69  sets the trace level to 3, activates the C<errors>, C<Sprout>, and C<ERDB> categories, and  sets the trace level to 3, activates the C<errors>, C<Sprout>, and C<ERDB> categories, and
70  specifies that messages should be output as HTML paragraphs. The parameters are formatted  specifies that messages should be output as HTML paragraphs.
71  to make it easier to input tracing configuration on a web form.  
72    To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
73    level 3 and writes the output to the standard error output. This sort of thing might be
74    useful in a CGI environment.
75    
76    C<< TSetup('3 *', 'WARN'); >>
77    
78  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
79  be queued. The messages can then be retrieved by calling the L</QTrace> method. This approach  be queued. The messages can then be retrieved by calling the L</QTrace> method. This approach
# Line 61  Line 88 
88  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
89  being used out in the field.  being used out in the field.
90    
91    There is no hard and fast rule on how to use trace levels. The following is therefore only
92    a suggestion.
93    
94    =over 4
95    
96    =item Error 0
97    
98    Message indicates an error that may lead to incorrect results or that has stopped the
99    application entirely.
100    
101    =item Warning 1
102    
103    Message indicates something that is unexpected but that probably did not interfere
104    with program execution.
105    
106    =item Notice 2
107    
108    Message indicates the beginning or end of a major task.
109    
110    =item Information 3
111    
112    Message indicates a subtask. In the FIG system, a subtask generally relates to a single
113    genome. This would be a big loop that is not expected to execute more than 500 times or so.
114    
115    =item Detail 4
116    
117    Message indicates a low-level loop iteration.
118    
119    =back
120    
121  =cut  =cut
122    
123  # Declare the configuration variables.  # Declare the configuration variables.
124    
125  my $Destination = "NONE";       # Description of where to send the trace output.  my $Destination = "NONE";       # Description of where to send the trace output.
126    my $TeeFlag = 0;            # TRUE if output is going to a file and to the
127                                # standard output
128  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
129                                                          # hash of active category names                                                          # hash of active category names
130  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
131                                                          # messages                                                          # messages
132  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
133  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
134    my $SetupCount = 0;         # number of times TSetup called
135    my $AllTrace = 0;           # TRUE if we are tracing all categories.
136    
137  =head2 Public Methods  =head2 Public Methods
138    
# Line 93  Line 154 
154    
155  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
156  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
157  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 ">"
158  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
159  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
160    cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
161  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
162  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
163  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
# Line 113  Line 175 
175          my @categoryData = split /\s+/, $categoryList;          my @categoryData = split /\s+/, $categoryList;
176          # Extract the trace level.          # Extract the trace level.
177          $TraceLevel = shift @categoryData;          $TraceLevel = shift @categoryData;
178          # Build the category hash.      # Presume category-based tracing until we learn otherwise.
179        $AllTrace = 0;
180        # Build the category hash. Note that if we find a "*", we turn on non-category
181        # tracing. We must also clear away any pre-existing data.
182        %Categories = ( main => 1 );
183          for my $category (@categoryData) {          for my $category (@categoryData) {
184                  $Categories{$category} = 1;          if ($category eq '*') {
185                $AllTrace = 1;
186            } else {
187                $Categories{lc $category} = 1;
188            }
189          }          }
190          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
191          # 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
192          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
193        if ($target =~ m/^\+?>>?/) {
194            if ($target =~ m/^\+/) {
195                $TeeFlag = 1;
196                $target = substr($target, 1);
197            }
198          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
199                  open TRACEFILE, $target;                  open TRACEFILE, $target;
200                  print TRACEFILE Now() . " Tracing initialized.\n";                  print TRACEFILE Now() . " Tracing initialized.\n";
201                  close TRACEFILE;                  close TRACEFILE;
202                  $Destination = ">$target";                  $Destination = ">$target";
203          } else {          } else {
204                $Destination = $target;
205            }
206        } else {
207                  $Destination = uc($target);                  $Destination = uc($target);
208          }          }
209        # Increment the setup counter.
210        $SetupCount++;
211    }
212    
213    =head3 StandardSetup
214    
215    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
216    
217    This method performs standard command-line parsing and tracing setup. The return
218    values are a hash of the command-line options and a list of the positional
219    parameters. Tracing is automatically set up and the command-line options are
220    validated.
221    
222    This is a complex method that does a lot of grunt work. The parameters can
223    be more easily understood, however, once they are examined individually.
224    
225    The I<categories> parameter is the most obtuse. It is a reference to a list of
226    special-purpose tracing categories. Most tracing categories are PERL package
227    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
228    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
229    
230        ["Sprout", "SproutLoad", "ERDB"]
231    
232    This would cause trace messages in the specified three packages to appear in
233    the output. There are threer special tracing categories that are automatically
234    handled by this method. In other words, if you used L</TSetup> you would need
235    to include these categories manually, but if you use this method they are turned
236    on automatically.
237    
238    =over 4
239    
240    =item FIG
241    
242    Turns on trace messages inside the B<FIG> package.
243    
244    =item SQL
245    
246    Traces SQL commands and activity.
247    
248    =item Tracer
249    
250    Traces error messages and call stacks.
251    
252    =back
253    
254    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
255    The trace level is specified using the C<-trace> command-line option. For example,
256    the following command line for C<TransactFeatures> turns on SQL tracing and runs
257    all tracing at level 3.
258    
259        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
260    
261    Standard tracing is output to the standard output and echoed to the file
262    C<trace>I<$$>C<.log> in the FIG temporary directory, where I<$$> is the
263    process ID. You can also specify the C<user> parameter to put a user ID
264    instead of a process ID in the trace file name. So, for example
265    
266    The default trace level is 2. To get all messages, specify a trace level of 4.
267    For a genome-by-genome update, use 3.
268    
269        TransactFeatures -trace=3 -sql -user=Bruce register ../xacts IDs.tbl
270    
271    would send the trace output to C<traceBruce.log> in the temporary directory.
272    
273    The I<options> parameter is a reference to a hash containing the command-line
274    options, their default values, and an explanation of what they mean. Command-line
275    options may be in the form of switches or keywords. In the case of a switch, the
276    option value is 1 if it is specified and 0 if it is not specified. In the case
277    of a keyword, the value is separated from the option name by an equal sign. You
278    can see this last in the command-line example above.
279    
280    You can specify a different default trace level by setting C<$options->{trace}>
281    prior to calling this method.
282    
283    An example at this point would help. Consider, for example, the command-line utility
284    C<TransactFeatures>. It accepts a list of positional parameters plus the options
285    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
286    the following code.
287    
288        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
289                            { safe => [0, "use database transactions"],
290                              noAlias => [0, "do not expect aliases in CHANGE transactions"],
291                              start => [' ', "start with this genome"],
292                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
293                            "command transactionDirectory IDfile",
294                          @ARGV);
295    
296    
297    The call to C<ParseCommand> specifies the default values for the options and
298    stores the actual options in a hash that is returned as C<$options>. The
299    positional parameters are returned in C<@parameters>.
300    
301    The following is a sample command line for C<TransactFeatures>.
302    
303        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
304    
305    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
306    parameters, and would find themselves in I<@parameters> after executing the
307    above code fragment. The tracing would be set to level 2, and the categories
308    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
309    and C<DocUtils> was included because it came in within the first parameter
310    to this method. The I<$options> hash would be
311    
312        { trace => 2, sql => 0, safe => 0,
313          noAlias => 1, start => ' ', tblFiles => 0 }
314    
315    Use of C<StandardSetup> in this way provides a simple way of performing
316    standard tracing setup and command-line parsing. Note that the caller is
317    not even aware of the command-line switches C<-trace> and C<-sql>, which
318    are used by this method to control the tracing. If additional tracing features
319    need to be added in the future, they can be processed by this method without
320    upsetting the command-line utilities.
321    
322    If the C<background> option is specified on the command line, then the
323    standard and error outputs will be directed to files in the temporary
324    directory, using the same suffix as the trace file. So, if the command
325    line specified
326    
327        -user=Bruce -background
328    
329    then the trace output would go to C<traceBruce.log>, the standard output to
330    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
331    simplify starting a command in the background.
332    
333    Finally, if the special option C<-h> is specified, the option names will
334    be traced at level 0 and the program will exit without processing.
335    This provides a limited help capability. For example, if the user enters
336    
337        TransactFeatures -h
338    
339    he would see the following output.
340    
341        TransactFeatures [options] command transactionDirectory IDfile
342            -trace    tracing level (default 2)
343            -sql      trace SQL commands
344            -safe     use database transactions
345            -noAlias  do not expect aliases in CHANGE transactions
346            -start    start with this genome
347            -tblFiles output TBL files containing the corrected IDs
348    
349    The caller has the option of modifying the tracing scheme by placing a value
350    for C<trace> in the incoming options hash. The default value can be overridden,
351    or the tracing to the standard output can be turned off by suffixing a minus
352    sign to the trace level. So, for example,
353    
354        { trace => [0, "tracing level (default 0)"],
355           ...
356    
357    would set the default trace level to 0 instead of 2, while
358    
359        { trace => ["2-", "tracing level (default 2)"],
360           ...
361    
362    would leave the default at 2, but trace only to the log file, not to the
363    standard output.
364    
365    The parameters to this method are as follows.
366    
367    =over 4
368    
369    =item categories
370    
371    Reference to a list of tracing category names. These should be names of
372    packages whose internal workings will need to be debugged to get the
373    command working.
374    
375    =item options
376    
377    Reference to a hash containing the legal options for the current command mapped
378    to their default values and descriptions. The user can override the defaults
379    by specifying the options as command-line switches prefixed by a hyphen.
380    Tracing-related options may be added to this hash. If the C<-h> option is
381    specified on the command line, the option descriptions will be used to
382    explain the options. To turn off tracing to the standard output, add a
383    minus sign to the value for C<trace> (see above).
384    
385    =item parmHelp
386    
387    A string that vaguely describes the positional parameters. This is used
388    if the user specifies the C<-h> option.
389    
390    =item argv
391    
392    List of command line parameters, including the option switches, which must
393    precede the positional parameters and be prefixed by a hyphen.
394    
395    =item RETURN
396    
397    Returns a list. The first element of the list is the reference to a hash that
398    maps the command-line option switches to their values. These will either be the
399    default values or overrides specified on the command line. The remaining
400    elements of the list are the position parameters, in order.
401    
402    =back
403    
404    =cut
405    
406    sub StandardSetup {
407        # Get the parameters.
408        my ($categories, $options, $parmHelp, @argv) = @_;
409        # Add the tracing options.
410        if (! exists $options->{trace}) {
411            $options->{trace} = [2, "tracing level"];
412        }
413        $options->{sql} = [0, "turn on SQL tracing"];
414        $options->{h} = [0, "display command-line options"];
415        $options->{user} = [$$, "trace log file name suffix"];
416        $options->{background} = [0, "spool standard and error output"];
417        # Create a parsing hash from the options hash. The parsing hash
418        # contains the default values rather than the default value
419        # and the description. While we're at it, we'll memorize the
420        # length of the longest option name.
421        my $longestName = 0;
422        my %parseOptions = ();
423        for my $key (keys %{$options}) {
424            if (length $key > $longestName) {
425                $longestName = length $key;
426            }
427            $parseOptions{$key} = $options->{$key}->[0];
428        }
429        # Parse the command line.
430        my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
431        # Get the logfile suffix.
432        my $suffix = $retOptions->{user};
433        # Check for background mode.
434        if ($retOptions->{background}) {
435            my $outFileName = "$FIG_Config::temp/out$suffix.log";
436            my $errFileName = "$FIG_Config::temp/err$suffix.log";
437            open STDOUT, ">$outFileName";
438            open STDERR, ">$errFileName";
439        }
440        # Now we want to set up tracing. First, we need to know if SQL is to
441        # be traced.
442        my @cats = @{$categories};
443        if ($retOptions->{sql}) {
444            push @cats, "SQL";
445        }
446        # Add the default categories.
447        push @cats, "Tracer", "FIG";
448        # Next, we create the category string by joining the categories.
449        my $cats = join(" ", @cats);
450        # Check to determine whether or not the caller wants to turn off tracing
451        # to the standard output.
452        my $traceLevel = $retOptions->{trace};
453        my $textOKFlag = 1;
454        if ($traceLevel =~ /^(.)-/) {
455            $traceLevel = $1;
456            $textOKFlag = 0;
457        }
458        # Now we set up the trace mode.
459        my $traceMode;
460        # Verify that we can open a file in the FIG temporary directory.
461        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
462        if (open TESTTRACE, ">$traceFileName") {
463            # Here we can trace to a file.
464            $traceMode = ">$traceFileName";
465            if ($textOKFlag) {
466                # Echo to standard output if the text-OK flag is set.
467                $traceMode = "+$traceMode";
468            }
469            # Close the test file.
470            close TESTTRACE;
471        } else {
472            # Here we can't trace to a file. We trace to the standard output if it's
473            # okay, and the error log otherwise.
474            if ($textOKFlag) {
475                $traceMode = "TEXT";
476            } else {
477                $traceMode = "WARN";
478            }
479        }
480        # Now set up the tracing.
481        TSetup("$traceLevel $cats", $traceMode);
482        # Check for the "h" option. If it is specified, dump the command-line
483        # options and exit the program.
484        if ($retOptions->{h}) {
485            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
486            Trace("$1 [options] $parmHelp") if T(0);
487            for my $key (sort keys %{$options}) {
488                my $name = Pad($key, $longestName, 0, ' ');
489                my $desc = $options->{$key}->[1];
490                if ($options->{$key}->[0]) {
491                    $desc .= " (default " . $options->{$key}->[0] . ")";
492                }
493                Trace("  $name $desc") if T(0);
494            }
495            exit(0);
496        }
497        # Return the parsed parameters.
498        return ($retOptions, @retParameters);
499    }
500    
501    =head3 Setups
502    
503    C<< my $count = Tracer::Setups(); >>
504    
505    Return the number of times L</TSetup> has been called.
506    
507    This method allows for the creation of conditional tracing setups where, for example, we
508    may want to set up tracing if nobody else has done it before us.
509    
510    =cut
511    
512    sub Setups {
513        return $SetupCount;
514    }
515    
516    =head3 Open
517    
518    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
519    
520    Open a file.
521    
522    The I<$fileSpec> is essentially the second argument of the PERL C<open>
523    function. The mode is specified using Unix-like shell information. So, for
524    example,
525    
526        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
527    
528    would open for output appended to the specified file, and
529    
530        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
531    
532    would open a pipe that sorts the records written and removes duplicates. Note
533    the use of file handle syntax in the Open call. To use anonymous file handles,
534    code as follows.
535    
536        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
537    
538    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
539    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
540    failed open will throw an exception and the third parameter will be used to construct
541    an error message. If the parameter is omitted, a standard message is constructed
542    using the file spec.
543    
544        Could not open "/usr/spool/news/twitlog"
545    
546    Note that the mode characters are automatically cleaned from the file name.
547    The actual error message from the file system will be captured and appended to the
548    message in any case.
549    
550        Could not open "/usr/spool/news/twitlog": file not found.
551    
552    In some versions of PERL the only error message we get is a number, which
553    corresponds to the C++ C<errno> value.
554    
555        Could not open "/usr/spool/news/twitlog": 6.
556    
557    =over 4
558    
559    =item fileHandle
560    
561    File handle. If this parameter is C<undef>, a file handle will be generated
562    and returned as the value of this method.
563    
564    =item fileSpec
565    
566    File name and mode, as per the PERL C<open> function.
567    
568    =item message (optional)
569    
570    Error message to use if the open fails. If omitted, a standard error message
571    will be generated. In either case, the error information from the file system
572    is appended to the message. To specify a conditional open that does not throw
573    an error if it fails, use C<0>.
574    
575    =item RETURN
576    
577    Returns the name of the file handle assigned to the file, or C<undef> if the
578    open failed.
579    
580    =back
581    
582    =cut
583    
584    sub Open {
585        # Get the parameters.
586        my ($fileHandle, $fileSpec, $message) = @_;
587        # Attempt to open the file.
588        my $rv = open $fileHandle, $fileSpec;
589        # If the open failed, generate an error message.
590        if (! $rv) {
591            # Save the system error message.
592            my $sysMessage = $!;
593            # See if we need a default message.
594            if (!$message) {
595                # Clean any obvious mode characters and leading spaces from the
596                # filename.
597                my ($fileName) = FindNamePart($fileSpec);
598                $message = "Could not open \"$fileName\"";
599            }
600            # Terminate with an error using the supplied message and the
601            # error message from the file system.
602            Confess("$message: $!");
603        }
604        # Return the file handle.
605        return $fileHandle;
606    }
607    
608    =head3 FindNamePart
609    
610    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
611    
612    Extract the portion of a file specification that contains the file name.
613    
614    A file specification is the string passed to an C<open> call. It specifies the file
615    mode and name. In a truly complex situation, it can specify a pipe sequence. This
616    method assumes that the file name is whatever follows the first angle bracket
617    sequence.  So, for example, in the following strings the file name is
618    C</usr/fig/myfile.txt>.
619    
620        >>/usr/fig/myfile.txt
621        </usr/fig/myfile.txt
622        | sort -u > /usr/fig/myfile.txt
623    
624    If the method cannot find a file name using its normal methods, it will return the
625    whole incoming string.
626    
627    =over 4
628    
629    =item fileSpec
630    
631    File specification string from which the file name is to be extracted.
632    
633    =item RETURN
634    
635    Returns a three-element list. The first element contains the file name portion of
636    the specified string, or the whole string if a file name cannot be found via normal
637    methods. The second element contains the start position of the file name portion and
638    the third element contains the length.
639    
640    =back
641    
642    =cut
643    #: Return Type $;
644    sub FindNamePart {
645        # Get the parameters.
646        my ($fileSpec) = @_;
647        # Default to the whole input string.
648        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
649        # Parse out the file name if we can.
650        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
651            $retVal = $2;
652            $len = length $retVal;
653            $pos = (length $fileSpec) - (length $3) - $len;
654        }
655        # Return the result.
656        return ($retVal, $pos, $len);
657    }
658    
659    =head3 OpenDir
660    
661    C<< my @files = OpenDir($dirName, $filtered, $flag); >>
662    
663    Open a directory and return all the file names. This function essentially performs
664    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
665    set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
666    or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
667    filtered out of the return list. If the directory does not open and I<$flag> is not
668    set, an exception is thrown. So, for example,
669    
670        my @files = OpenDir("/Volumes/fig/contigs", 1);
671    
672    is effectively the same as
673    
674        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
675        my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
676    
677    Similarly, the following code
678    
679        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
680    
681    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
682    automatically returns an empty list if the directory fails to open.
683    
684    =over 4
685    
686    =item dirName
687    
688    Name of the directory to open.
689    
690    =item filtered
691    
692    TRUE if files whose names begin with a period (C<.>) should be automatically removed
693    from the list, else FALSE.
694    
695    =item flag
696    
697    TRUE if a failure to open is okay, else FALSE
698    
699    =back
700    
701    =cut
702    #: Return Type @;
703    sub OpenDir {
704        # Get the parameters.
705        my ($dirName, $filtered, $flag) = @_;
706        # Declare the return variable.
707        my @retVal = ();
708        # Open the directory.
709        if (opendir(my $dirHandle, $dirName)) {
710            # The directory opened successfully. Get the appropriate list according to the
711            # strictures of the filter parameter.
712            if ($filtered) {
713                @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
714            } else {
715                @retVal = readdir $dirHandle;
716            }
717        } elsif (! $flag) {
718            # Here the directory would not open and it's considered an error.
719            Confess("Could not open directory $dirName.");
720        }
721        # Return the result.
722        return @retVal;
723  }  }
724    
725  =head3 SetLevel  =head3 SetLevel
# Line 394  Line 986 
986         warn $message;         warn $message;
987          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
988                  # Write the trace message to an output file.                  # Write the trace message to an output file.
989                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
990                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
991                  close TRACING;                  close TRACING;
992            # If the Tee flag is on, echo it to the standard output.
993            if ($TeeFlag) {
994                print "$formatted\n";
995            }
996          }          }
997  }  }
998    
# Line 439  Line 1035 
1035                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
1036                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
1037                          # 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.
1038                # The calling package is normally the first parameter. If it is
1039                # omitted, the first parameter will be the tracelevel. So, the
1040                # first thing we do is shift the so-called category into the
1041                # $traceLevel variable where it belongs.
1042                          $traceLevel = $category;                          $traceLevel = $category;
1043                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
1044              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 450  Line 1050 
1050                  }                  }
1051          # Save the category name.          # Save the category name.
1052          $LastCategory = $category;          $LastCategory = $category;
1053            # Convert it to lower case before we hash it.
1054            $category = lc $category;
1055                  # Use the category and tracelevel to compute the result.                  # Use the category and tracelevel to compute the result.
1056                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          if (ref $traceLevel) {
1057                Confess("Bad trace level.");
1058            } elsif (ref $TraceLevel) {
1059                Confess("Bad trace config.");
1060            }
1061            $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
1062      }      }
1063          # Return the computed result.          # Return the computed result.
1064      return $retVal;      return $retVal;
# Line 537  Line 1144 
1144    
1145  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1146    
1147  Escape a string for use in a command length. Spaces will be replaced by C<\b>,  Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1148  tabs replaced by C<\t>, new-lines replaced by C<\n>, and backslashes will be  replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1149  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1150    
1151  =over 4  =over 4
1152    
# Line 563  Line 1170 
1170          # Loop through the parameter string, looking for sequences to escape.          # Loop through the parameter string, looking for sequences to escape.
1171          while (length $realString > 0) {          while (length $realString > 0) {
1172                  # Look for the first sequence to escape.                  # Look for the first sequence to escape.
1173                  if ($realString =~ /^(.*?)([ \n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1174                          # 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
1175                          # 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.
1176                          $retVal .= $1;                          $retVal .= $1;
1177                          $realString = substr $realString, (length $2 + length $1);              # Strip the processed section off the real string.
1178                          # Encode the escape sequence.              $realString = substr $realString, (length $2) + (length $1);
1179                # Get the matched character.
1180                          my $char = $2;                          my $char = $2;
1181                          $char =~ tr/ \t\n/btn/;              # If we have a CR, we are done.
1182                if ($char ne "\r") {
1183                    # It's not a CR, so encode the escape sequence.
1184                    $char =~ tr/\t\n/tn/;
1185                          $retVal .= "\\" . $char;                          $retVal .= "\\" . $char;
1186                }
1187                  } else {                  } else {
1188                          # 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
1189                          # transferred unmodified.                          # transferred unmodified.
# Line 587  Line 1199 
1199    
1200  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1201    
1202  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
1203  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
1204    be deleted.
1205    
1206  =over 4  =over 4
1207    
# Line 613  Line 1226 
1226          # Only proceed if the incoming string is nonempty.          # Only proceed if the incoming string is nonempty.
1227          if (defined $codedString) {          if (defined $codedString) {
1228                  # 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
1229                  # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1230                  # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1231                  while (length $codedString > 0) {                  while (length $codedString > 0) {
1232                          # Look for the first escape sequence.                          # Look for the first escape sequence.
1233                          if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1234                                  # 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
1235                                  # 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.
1236                                  $retVal .= $1;                                  $retVal .= $1;
1237                                  $codedString = substr $codedString, (2 + length $1);                                  $codedString = substr $codedString, (2 + length $1);
1238                                  # Decode the escape sequence.                  # Get the escape value.
1239                                  my $char = $2;                                  my $char = $2;
1240                                  $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1241                    if ($char ne 'r') {
1242                        # Here it's not an 'r', so we convert it.
1243                        $char =~ tr/\\tn/\\\t\n/;
1244                                  $retVal .= $char;                                  $retVal .= $char;
1245                    }
1246                          } else {                          } else {
1247                                  # 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
1248                                  # transferred unmodified.                                  # transferred unmodified.
# Line 731  Line 1348 
1348          return @inputList;          return @inputList;
1349  }  }
1350    
1351    =head3 Percent
1352    
1353    C<< my $percent = Tracer::Percent($number, $base); >>
1354    
1355    Returns the percent of the base represented by the given number. If the base
1356    is zero, returns zero.
1357    
1358    =over 4
1359    
1360    =item number
1361    
1362    Percent numerator.
1363    
1364    =item base
1365    
1366    Percent base.
1367    
1368    =item RETURN
1369    
1370    Returns the percentage of the base represented by the numerator.
1371    
1372    =back
1373    
1374    =cut
1375    
1376    sub Percent {
1377        # Get the parameters.
1378        my ($number, $base) = @_;
1379        # Declare the return variable.
1380        my $retVal = 0;
1381        # Compute the percent.
1382        if ($base != 0) {
1383            $retVal = $number * 100 / $base;
1384        }
1385        # Return the result.
1386        return $retVal;
1387    }
1388    
1389  =head3 GetFile  =head3 GetFile
1390    
1391  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1392    
1393  Return the entire contents of a file.      or
1394    
1395    C<< my $fileContents = Tracer::GetFile($fileName); >>
1396    
1397    Return the entire contents of a file. In list context, line-ends are removed and
1398    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1399    
1400  =over 4  =over 4
1401    
# Line 746  Line 1406 
1406  =item RETURN  =item RETURN
1407    
1408  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.
1409  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
1410    the file, an empty list will be returned.
1411    
1412  =back  =back
1413    
# Line 761  Line 1422 
1422          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1423          if (!$ok) {          if (!$ok) {
1424                  # 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.
1425                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1426          } else {          } else {
1427                  # Read the whole file into the return variable, stripping off any terminator                  # Read the whole file into the return variable, stripping off any terminator
1428          # characters.          # characters.
# Line 774  Line 1435 
1435                  # Close it.                  # Close it.
1436                  close INPUTFILE;                  close INPUTFILE;
1437          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(3);  
1438          }          }
1439          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1440      if (wantarray) {      if (wantarray) {
# Line 805  Line 1465 
1465          my ($format) = @_;          my ($format) = @_;
1466          # Create the return variable.          # Create the return variable.
1467          my $retVal = "";          my $retVal = "";
1468        # Only proceed if there is an actual queue.
1469        if (@Queue) {
1470          # Process according to the format.          # Process according to the format.
1471          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1472                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 820  Line 1482 
1482          }          }
1483          # Clear the queue.          # Clear the queue.
1484          @Queue = ();          @Queue = ();
1485        }
1486          # Return the formatted list.          # Return the formatted list.
1487          return $retVal;          return $retVal;
1488  }  }
# Line 828  Line 1491 
1491    
1492  C<< Confess($message); >>  C<< Confess($message); >>
1493    
1494  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  
1495  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.
1496  So, for example  So, for example
1497    
# Line 851  Line 1513 
1513          # Get the parameters.          # Get the parameters.
1514          my ($message) = @_;          my ($message) = @_;
1515          # Trace the call stack.          # Trace the call stack.
1516          Cluck($message) if T(1);      Cluck($message);
1517          # Abort the program.          # Abort the program.
1518          croak(">>> $message");          croak(">>> $message");
1519  }  }
# Line 861  Line 1523 
1523  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1524    
1525  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
1526  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.
1527  So, for example  So, for example
1528    
1529  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 982  Line 1644 
1644    
1645  =head3 AddToListMap  =head3 AddToListMap
1646    
1647  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1648    
1649  Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list  Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list
1650  is created for the key. Otherwise, the new value is pushed onto the list.  is created for the key. Otherwise, the new value is pushed onto the list.
# Line 997  Line 1659 
1659    
1660  Key for which the value is to be added.  Key for which the value is to be added.
1661    
1662  =item value  =item value1, value2, ... valueN
1663    
1664  Value to add to the key's value list.  List of values to add to the key's value list.
1665    
1666  =back  =back
1667    
# Line 1007  Line 1669 
1669    
1670  sub AddToListMap {  sub AddToListMap {
1671      # Get the parameters.      # Get the parameters.
1672      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1673      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1674      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1675          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1676      } else {      } else {
1677          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1678      }      }
1679  }  }
1680    
# Line 1020  Line 1682 
1682    
1683  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1684    
1685  Return TRUE if debug mode has been turned on in FIG_Config, else output  Return TRUE if debug mode has been turned on, else output an error
1686  an error page and return FALSE.  page and return FALSE.
1687    
1688  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1689  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1690  from working unless they are explicitly turned on in the configuration  from working unless they are explicitly turned on by creating a password
1691  file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1692  is not turned on, an error web page will be output.  is not turned on, an error web page will be output directing the
1693    user to enter in the correct password.
1694    
1695  =cut  =cut
1696    
1697  sub DebugMode {  sub DebugMode {
1698          # Declare the return variable.          # Declare the return variable.
1699          my $retVal;      my $retVal = 0;
1700          # Check the debug configuration.          # Check the debug configuration.
1701          if ($FIG_Config::debug_mode) {      my $password = CGI::cookie("DebugMode");
1702        my $encrypted = Digest::MD5::md5_hex($password);
1703        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1704                  $retVal = 1;                  $retVal = 1;
1705          } else {          } else {
1706                  # Here debug mode is off, so we generate an error page.                  # Here debug mode is off, so we generate an error page.
# Line 1071  Line 1736 
1736  sub Strip {  sub Strip {
1737          # Get a copy of the parameter string.          # Get a copy of the parameter string.
1738          my ($string) = @_;          my ($string) = @_;
1739          my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1740      # Strip the line terminator characters.      # Strip the line terminator characters.
1741      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1742          # Return the result.          # Return the result.
# Line 1102  Line 1767 
1767    
1768  =item padChar (optional)  =item padChar (optional)
1769    
1770    Character to use for padding. The default is a space.
1771    
1772  =item RETURN  =item RETURN
1773    
1774  Returns a copy of the original string with the spaces added to the specified end so  Returns a copy of the original string with the pad character added to the
1775  that it achieves the desired length.  specified end so that it achieves the desired length.
1776    
1777  =back  =back
1778    
# Line 1137  Line 1804 
1804          return $retVal;          return $retVal;
1805  }  }
1806    
1807    =head3 EOF
1808    
1809    This is a constant that is lexically greater than any useful string.
1810    
1811    =cut
1812    
1813    sub EOF {
1814        return "\xFF\xFF\xFF\xFF\xFF";
1815    }
1816    
1817    =head3 TICK
1818    
1819    C<< my @results = TICK($commandString); >>
1820    
1821    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1822    dot-slash (C<./> will be removed. So, for example, if you were doing
1823    
1824        `./protein.cgi`
1825    
1826    from inside a CGI script, it would work fine in Unix, but would issue an error message
1827    in Windows complaining that C<'.'> is not a valid command. If instead you code
1828    
1829        TICK("./protein.cgi")
1830    
1831    it will work correctly in both environments.
1832    
1833    =over 4
1834    
1835    =item commandString
1836    
1837    The command string to pass to the system.
1838    
1839    =item RETURN
1840    
1841    Returns the standard output from the specified command, as a list.
1842    
1843    =back
1844    
1845    =cut
1846    #: Return Type @;
1847    sub TICK {
1848        # Get the parameters.
1849        my ($commandString) = @_;
1850        # Chop off the dot-slash if this is Windows.
1851        if ($FIG_Config::win_mode) {
1852            $commandString =~ s!^\./!!;
1853        }
1854        # Activate the command and return the result.
1855        return `$commandString`;
1856    }
1857    
1858    =head3 ScriptSetup
1859    
1860    C<< my ($query, $varHash) = ScriptSetup(); >>
1861    
1862    Perform standard tracing and debugging setup for scripts. The value returned is
1863    the CGI object followed by a pre-built variable hash.
1864    
1865    The C<Trace> query parameter is used to determine whether or not tracing is active and
1866    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1867    the C<CGI> trace module will trace parameter and environment information. Parameters are
1868    traced at level 3 and environment variables at level 4. At the end of the script, the
1869    client should call L</ScriptFinish> to output the web page.
1870    
1871    =cut
1872    
1873    sub ScriptSetup {
1874        # Get the CGI query object.
1875        my $query = CGI->new();
1876        # Check for tracing. Set it up if the user asked for it.
1877        if ($query->param('Trace')) {
1878            # Set up tracing to be queued for display at the bottom of the web page.
1879            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1880            # Trace the parameter and environment data.
1881            if (T(CGI => 3)) {
1882                # Here we want to trace the parameter data.
1883                my @names = $query->param;
1884                for my $parmName (sort @names) {
1885                    # Note we skip "Trace", which is for our use only.
1886                    if ($parmName ne 'Trace') {
1887                        my @values = $query->param($parmName);
1888                        Trace("CGI: $parmName = " . join(", ", @values));
1889                    }
1890                }
1891            }
1892            if (T(CGI => 4)) {
1893                # Here we want the environment data too.
1894                for my $envName (sort keys %ENV) {
1895                    Trace("ENV: $envName = $ENV{$envName}");
1896                }
1897            }
1898        } else {
1899            # Here tracing is to be turned off. All we allow is errors traced into the
1900            # error log.
1901            TSetup("0", "WARN");
1902        }
1903        # Create the variable hash.
1904        my $varHash = { DebugData => '' };
1905        # If we're in DEBUG mode, set up the debug mode data for forms.
1906        if (Tracer::DebugMode) {
1907            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1908        }
1909        # Return the query object and variable hash.
1910        return ($query, $varHash);
1911    }
1912    
1913    =head3 ScriptFinish
1914    
1915    C<< ScriptFinish($webData, $varHash); >>
1916    
1917    Output a web page at the end of a script. Either the string to be output or the
1918    name of a template file can be specified. If the second parameter is omitted,
1919    it is assumed we have a string to be output; otherwise, it is assumed we have the
1920    name of a template file. The template should have the variable C<DebugData>
1921    specified in any form that invokes a standard script. If debugging mode is turned
1922    on, a form field will be put in that allows the user to enter tracing data.
1923    Trace messages will be placed immediately before the terminal C<BODY> tag in
1924    the output, formatted as a list.
1925    
1926    A typical standard script would loook like the following.
1927    
1928        BEGIN {
1929            # Print the HTML header.
1930            print "CONTENT-TYPE: text/html\n\n";
1931        }
1932        use Tracer;
1933        use CGI;
1934        use FIG;
1935        # ... more uses ...
1936    
1937        my ($query, $varHash) = ScriptSetup();
1938        eval {
1939            # ... get data from $query, put it in $varHash ...
1940        };
1941        if ($@) {
1942            Trace("Script Error: $@") if T(0);
1943        }
1944        ScriptFinish("Html/MyTemplate.html", $varHash);
1945    
1946    The idea here is that even if the script fails, you'll see trace messages and
1947    useful output.
1948    
1949    =over 4
1950    
1951    =item webData
1952    
1953    A string containing either the full web page to be written to the output or the
1954    name of a template file from which the page is to be constructed. If the name
1955    of a template file is specified, then the second parameter must be present;
1956    otherwise, it must be absent.
1957    
1958    =item varHash (optional)
1959    
1960    If specified, then a reference to a hash mapping variable names for a template
1961    to their values. The template file will be read into memory, and variable markers
1962    will be replaced by data in this hash reference.
1963    
1964    =back
1965    
1966    =cut
1967    
1968    sub ScriptFinish {
1969        # Get the parameters.
1970        my ($webData, $varHash) = @_;
1971        # Check for a template file situation.
1972        my $outputString;
1973        if (defined $varHash) {
1974            # Here we have a template file. We need to apply the variables to the template.
1975            $outputString = PageBuilder::Build("<$webData", $varHash, "Html");
1976        } else {
1977            # Here the user gave us a raw string.
1978            $outputString = $webData;
1979        }
1980        # Check for trace messages.
1981        if ($Destination eq "QUEUE") {
1982            # We have trace messages, so we want to put them at the end of the body. This
1983            # is either at the end of the whole string or at the beginning of the BODY
1984            # end-tag.
1985            my $pos = length $outputString;
1986            if ($outputString =~ m#</body>#gi) {
1987                $pos = (pos $outputString) - 7;
1988            }
1989            substr $outputString, $pos, 0, QTrace('Html');
1990        }
1991        # Write the output string.
1992        print $outputString;
1993    }
1994    
1995    =head3 Insure
1996    
1997    C<< Insure($dirName); >>
1998    
1999    Insure a directory is present.
2000    
2001    =over 4
2002    
2003    =item dirName
2004    
2005    Name of the directory to check. If it does not exist, it will be created.
2006    
2007    =back
2008    
2009    =cut
2010    
2011    sub Insure {
2012        my ($dirName) = @_;
2013        if (! -d $dirName) {
2014            Trace("Creating $dirName directory.") if T(2);
2015            eval { mkpath $dirName; };
2016            if ($@) {
2017                Confess("Error creating $dirName: $@");
2018            }
2019        }
2020    }
2021    
2022    =head3 ChDir
2023    
2024    C<< ChDir($dirName); >>
2025    
2026    Change to the specified directory.
2027    
2028    =over 4
2029    
2030    =item dirName
2031    
2032    Name of the directory to which we want to change.
2033    
2034    =back
2035    
2036    =cut
2037    
2038    sub ChDir {
2039        my ($dirName) = @_;
2040        if (! -d $dirName) {
2041            Confess("Cannot change to directory $dirName: no such directory.");
2042        } else {
2043            Trace("Changing to directory $dirName.") if T(4);
2044            my $okFlag = chdir $dirName;
2045            if (! $okFlag) {
2046                Confess("Error switching to directory $dirName.");
2047            }
2048        }
2049    }
2050    
2051    =head3 CommaFormat
2052    
2053    C<< my $formatted = Tracer::CommaFormat($number); >>
2054    
2055    Insert commas into a number.
2056    
2057    =over 4
2058    
2059    =item number
2060    
2061    A sequence of digits.
2062    
2063    =item RETURN
2064    
2065    Returns the same digits with commas strategically inserted.
2066    
2067    =back
2068    
2069    =cut
2070    
2071    sub CommaFormat {
2072        # Get the parameters.
2073        my ($number) = @_;
2074        # Pad the length up to a multiple of three.
2075        my $padded = "$number";
2076        $padded = " " . $padded while length($padded) % 3 != 0;
2077        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2078        # cause the delimiters to be included in the output stream. The
2079        # GREP removes the empty strings in between the delimiters.
2080        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2081        # Clean out the spaces.
2082        $retVal =~ s/ //g;
2083        # Return the result.
2084        return $retVal;
2085    }
2086    =head3 SetPermissions
2087    
2088    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2089    
2090    Set the permissions for a directory and all the files and folders inside it.
2091    In addition, the group ownership will be changed to the specified value.
2092    
2093    This method is more vulnerable than most to permission and compatability
2094    problems, so it does internal error recovery.
2095    
2096    =over 4
2097    
2098    =item dirName
2099    
2100    Name of the directory to process.
2101    
2102    =item group
2103    
2104    Name of the group to be assigned.
2105    
2106    =item mask
2107    
2108    Permission mask. Bits that are C<1> in this mask will be ORed into the
2109    permission bits of any file or directory that does not already have them
2110    set to 1.
2111    
2112    =item otherMasks
2113    
2114    Map of search patterns to permission masks. If a directory name matches
2115    one of the patterns, that directory and all its members and subdirectories
2116    will be assigned the new pattern. For example, the following would
2117    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2118    
2119        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2120    
2121    The list is ordered, so the following would use 0777 for C<tmp1> and
2122    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2123    
2124        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2125                                                       '^tmp' => 0666);
2126    
2127    Note that the pattern matches are all case-insensitive, and only directory
2128    names are matched, not file names.
2129    
2130    =back
2131    
2132    =cut
2133    
2134    sub SetPermissions {
2135        # Get the parameters.
2136        my ($dirName, $group, $mask, @otherMasks) = @_;
2137        # Set up for error recovery.
2138        eval {
2139            # Switch to the specified directory.
2140            ChDir($dirName);
2141            # Get the group ID.
2142            my $gid = getgrnam($group);
2143            # Get the mask for tracing.
2144            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2145            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2146            my $fixCount = 0;
2147            my $lookCount = 0;
2148            # @dirs will be a stack of directories to be processed.
2149            my @dirs = (getcwd());
2150            while (scalar(@dirs) > 0) {
2151                # Get the current directory.
2152                my $dir = pop @dirs;
2153                # Check for a match to one of the specified directory names. To do
2154                # that, we need to pull the individual part of the name off of the
2155                # whole path.
2156                my $simpleName = $dir;
2157                if ($dir =~ m!/([^/]+)$!) {
2158                    $simpleName = $1;
2159                }
2160                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2161                # Search for a match.
2162                my $match = 0;
2163                my $i;
2164                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2165                    my $pattern = $otherMasks[$i];
2166                    if ($simpleName =~ /$pattern/i) {
2167                        $match = 1;
2168                    }
2169                }
2170                # Check for a match. Note we use $i-1 because the loop added 2
2171                # before terminating due to the match.
2172                if ($match && $otherMasks[$i-1] != $mask) {
2173                    # This directory matches one of the incoming patterns, and it's
2174                    # a different mask, so we process it recursively with that mask.
2175                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2176                } else {
2177                    # Here we can process normally. Get all of the non-hidden members.
2178                    my @submems = OpenDir($dir, 1);
2179                    for my $submem (@submems) {
2180                        # Get the full name.
2181                        my $thisMem = "$dir/$submem";
2182                        Trace("Checking member $thisMem.") if T(4);
2183                        $lookCount++;
2184                        if ($lookCount % 1000 == 0) {
2185                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2186                        }
2187                        # Fix the group.
2188                        chown -1, $gid, $thisMem;
2189                        # Insure this member is not a symlink.
2190                        if (! -l $thisMem) {
2191                            # Get its info.
2192                            my $fileInfo = stat $thisMem;
2193                            # Only proceed if we got the info. Otherwise, it's a hard link
2194                            # and we want to skip it anyway.
2195                            if ($fileInfo) {
2196                                my $fileMode = $fileInfo->mode;
2197                                if (($fileMode & $mask) != $mask) {
2198                                    # Fix this member.
2199                                    $fileMode |= $mask;
2200                                    chmod $fileMode, $thisMem;
2201                                    $fixCount++;
2202                                }
2203                                # If it's a subdirectory, stack it.
2204                                if (-d $thisMem) {
2205                                    push @dirs, $thisMem;
2206                                }
2207                            }
2208                        }
2209                    }
2210                }
2211            }
2212            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2213        };
2214        # Check for an error.
2215        if ($@) {
2216            Confess("SetPermissions error: $@");
2217        }
2218    }
2219    
2220  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3