[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.49, Wed Jun 14 00:54:59 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);      @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;
29        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 18  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 36  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, 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
70  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.
71  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 59  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
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 90  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 110  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 370  Line 965 
965          my ($message) = @_;          my ($message) = @_;
966          # Get the timestamp.          # Get the timestamp.
967          my $timeStamp = Now();          my $timeStamp = Now();
968          # Format the message.      # Format the message. Note we strip off any line terminators at the end.
969          my $formatted = "$timeStamp $message";      my $formatted = "$timeStamp <$LastCategory>: " . Strip($message);
970          # Process according to the destination.          # Process according to the destination.
971          if ($Destination eq "TEXT") {          if ($Destination eq "TEXT") {
972                  # Write the message to the standard output.                  # Write the message to the standard output.
# Line 391  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 436  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 445  Line 1048 
1048                                  $category = $package;                                  $category = $package;
1049                          }                          }
1050                  }                  }
1051                  # Use the package and tracelevel to compute the result.          # Save the category name.
1052                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$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.
1056            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 528  Line 1140 
1140          return ($optionTable, @retVal);          return ($optionTable, @retVal);
1141  }  }
1142    
1143    =head3 Escape
1144    
1145    C<< my $codedString = Tracer::Escape($realString); >>
1146    
1147    Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1148    replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1149    result is to reverse the effect of L</UnEscape>.
1150    
1151    =over 4
1152    
1153    =item realString
1154    
1155    String to escape.
1156    
1157    =item RETURN
1158    
1159    Escaped equivalent of the real string.
1160    
1161    =back
1162    
1163    =cut
1164    
1165    sub Escape {
1166        # Get the parameter.
1167        my ($realString) = @_;
1168        # Initialize the return variable.
1169        my $retVal = "";
1170        # Loop through the parameter string, looking for sequences to escape.
1171        while (length $realString > 0) {
1172            # Look for the first sequence to escape.
1173            if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1174                # 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.
1176                $retVal .= $1;
1177                # Strip the processed section off the real string.
1178                $realString = substr $realString, (length $2) + (length $1);
1179                # Get the matched character.
1180                my $char = $2;
1181                # 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;
1186                }
1187            } else {
1188                # Here there are no more escape sequences. The rest of the string is
1189                # transferred unmodified.
1190                $retVal .= $realString;
1191                $realString = "";
1192            }
1193        }
1194        # Return the result.
1195        return $retVal;
1196    }
1197    
1198  =head3 UnEscape  =head3 UnEscape
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 555  Line 1223 
1223          my ($codedString) = @_;          my ($codedString) = @_;
1224          # Initialize the return variable.          # Initialize the return variable.
1225          my $retVal = "";          my $retVal = "";
1226        # Only proceed if the incoming string is nonempty.
1227        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 576  Line 1250 
1250                          $codedString = "";                          $codedString = "";
1251                  }                  }
1252          }          }
1253        }
1254          # Return the result.          # Return the result.
1255          return $retVal;          return $retVal;
1256  }  }
# Line 677  Line 1352 
1352    
1353  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1354    
1355  Return the entire contents of a file.      or
1356    
1357    C<< my $fileContents = Tracer::GetFile($fileName); >>
1358    
1359    Return the entire contents of a file. In list context, line-ends are removed and
1360    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1361    
1362  =over 4  =over 4
1363    
# Line 688  Line 1368 
1368  =item RETURN  =item RETURN
1369    
1370  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.
1371  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
1372    the file, an empty list will be returned.
1373    
1374  =back  =back
1375    
# Line 703  Line 1384 
1384          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1385          if (!$ok) {          if (!$ok) {
1386                  # 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.
1387                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1388          } else {          } else {
1389                  # Read the whole file into the return variable, stripping off an terminator          # Read the whole file into the return variable, stripping off any terminator
1390          # characters.          # characters.
1391          my $lineCount = 0;          my $lineCount = 0;
1392                  while (my $line = <INPUTFILE>) {                  while (my $line = <INPUTFILE>) {
1393              $lineCount++;              $lineCount++;
1394              $line =~ s/(\r|\n)+$//g;              $line = Strip($line);
1395                          push @retVal, $line;                          push @retVal, $line;
1396                  }                  }
1397                  # Close it.                  # Close it.
1398                  close INPUTFILE;                  close INPUTFILE;
1399          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(0);  
1400          }          }
1401          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1402      if (wantarray) {      if (wantarray) {
# Line 747  Line 1427 
1427          my ($format) = @_;          my ($format) = @_;
1428          # Create the return variable.          # Create the return variable.
1429          my $retVal = "";          my $retVal = "";
1430        # Only proceed if there is an actual queue.
1431        if (@Queue) {
1432          # Process according to the format.          # Process according to the format.
1433          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1434                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 762  Line 1444 
1444          }          }
1445          # Clear the queue.          # Clear the queue.
1446          @Queue = ();          @Queue = ();
1447        }
1448          # Return the formatted list.          # Return the formatted list.
1449          return $retVal;          return $retVal;
1450  }  }
# Line 770  Line 1453 
1453    
1454  C<< Confess($message); >>  C<< Confess($message); >>
1455    
1456  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  
1457  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.
1458  So, for example  So, for example
1459    
# Line 793  Line 1475 
1475          # Get the parameters.          # Get the parameters.
1476          my ($message) = @_;          my ($message) = @_;
1477          # Trace the call stack.          # Trace the call stack.
1478          Cluck($message) if T(1);      Cluck($message);
1479          # Abort the program.          # Abort the program.
1480          croak(">>> $message");          croak(">>> $message");
1481  }  }
# Line 803  Line 1485 
1485  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1486    
1487  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
1488  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.
1489  So, for example  So, for example
1490    
1491  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 958  Line 1640 
1640      }      }
1641  }  }
1642    
1643    =head3 DebugMode
1644    
1645    C<< if (Tracer::DebugMode) { ...code... } >>
1646    
1647    Return TRUE if debug mode has been turned on, else output an error
1648    page and return FALSE.
1649    
1650    Certain CGI scripts are too dangerous to exist in the production
1651    environment. This method provides a simple way to prevent them
1652    from working unless they are explicitly turned on by creating a password
1653    cookie via the B<SetPassword> script.  If debugging mode
1654    is not turned on, an error web page will be output directing the
1655    user to enter in the correct password.
1656    
1657    =cut
1658    
1659    sub DebugMode {
1660        # Declare the return variable.
1661        my $retVal = 0;
1662        # Check the debug configuration.
1663        my $password = CGI::cookie("DebugMode");
1664        my $encrypted = Digest::MD5::md5_hex($password);
1665        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1666            $retVal = 1;
1667        } else {
1668            # Here debug mode is off, so we generate an error page.
1669            my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");
1670            print $pageString;
1671        }
1672        # Return the determination indicator.
1673        return $retVal;
1674    }
1675    
1676    =head3 Strip
1677    
1678    C<< my $string = Tracer::Strip($line); >>
1679    
1680    Strip all line terminators off a string. This is necessary when dealing with files
1681    that may have been transferred back and forth several times among different
1682    operating environments.
1683    
1684    =over 4
1685    
1686    =item line
1687    
1688    Line of text to be stripped.
1689    
1690    =item RETURN
1691    
1692    The same line of text with all the line-ending characters chopped from the end.
1693    
1694    =back
1695    
1696    =cut
1697    
1698    sub Strip {
1699        # Get a copy of the parameter string.
1700        my ($string) = @_;
1701        my $retVal = (defined $string ? $string : "");
1702        # Strip the line terminator characters.
1703        $retVal =~ s/(\r|\n)+$//g;
1704        # Return the result.
1705        return $retVal;
1706    }
1707    
1708    =head3 Pad
1709    
1710    C<< my $paddedString = Tracer::Pad($string, $len, $left, $padChar); >>
1711    
1712    Pad a string to a specified length. The pad character will be a
1713    space, and the padding will be on the right side unless specified
1714    in the third parameter.
1715    
1716    =over 4
1717    
1718    =item string
1719    
1720    String to be padded.
1721    
1722    =item len
1723    
1724    Desired length of the padded string.
1725    
1726    =item left (optional)
1727    
1728    TRUE if the string is to be left-padded; otherwise it will be padded on the right.
1729    
1730    =item padChar (optional)
1731    
1732    Character to use for padding. The default is a space.
1733    
1734    =item RETURN
1735    
1736    Returns a copy of the original string with the pad character added to the
1737    specified end so that it achieves the desired length.
1738    
1739    =back
1740    
1741    =cut
1742    
1743    sub Pad {
1744        # Get the parameters.
1745        my ($string, $len, $left, $padChar) = @_;
1746        # Compute the padding character.
1747        if (! defined $padChar) {
1748            $padChar = " ";
1749        }
1750        # Compute the number of spaces needed.
1751        my $needed = $len - length $string;
1752        # Copy the string into the return variable.
1753        my $retVal = $string;
1754        # Only proceed if padding is needed.
1755        if ($needed > 0) {
1756            # Create the pad string.
1757            my $pad = $padChar x $needed;
1758            # Affix it to the return value.
1759            if ($left) {
1760                $retVal = $pad . $retVal;
1761            } else {
1762                $retVal .= $pad;
1763            }
1764        }
1765        # Return the result.
1766        return $retVal;
1767    }
1768    
1769    =head3 EOF
1770    
1771    This is a constant that is lexically greater than any useful string.
1772    
1773    =cut
1774    
1775    sub EOF {
1776        return "\xFF\xFF\xFF\xFF\xFF";
1777    }
1778    
1779    =head3 TICK
1780    
1781    C<< my @results = TICK($commandString); >>
1782    
1783    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1784    dot-slash (C<./> will be removed. So, for example, if you were doing
1785    
1786        `./protein.cgi`
1787    
1788    from inside a CGI script, it would work fine in Unix, but would issue an error message
1789    in Windows complaining that C<'.'> is not a valid command. If instead you code
1790    
1791        TICK("./protein.cgi")
1792    
1793    it will work correctly in both environments.
1794    
1795    =over 4
1796    
1797    =item commandString
1798    
1799    The command string to pass to the system.
1800    
1801    =item RETURN
1802    
1803    Returns the standard output from the specified command, as a list.
1804    
1805    =back
1806    
1807    =cut
1808    #: Return Type @;
1809    sub TICK {
1810        # Get the parameters.
1811        my ($commandString) = @_;
1812        # Chop off the dot-slash if this is Windows.
1813        if ($FIG_Config::win_mode) {
1814            $commandString =~ s!^\./!!;
1815        }
1816        # Activate the command and return the result.
1817        return `$commandString`;
1818    }
1819    
1820    =head3 ScriptSetup
1821    
1822    C<< my ($query, $varHash) = ScriptSetup(); >>
1823    
1824    Perform standard tracing and debugging setup for scripts. The value returned is
1825    the CGI object followed by a pre-built variable hash.
1826    
1827    The C<Trace> query parameter is used to determine whether or not tracing is active and
1828    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1829    the C<CGI> trace module will trace parameter and environment information. Parameters are
1830    traced at level 3 and environment variables at level 4. At the end of the script, the
1831    client should call L</ScriptFinish> to output the web page.
1832    
1833    =cut
1834    
1835    sub ScriptSetup {
1836        # Get the CGI query object.
1837        my $query = CGI->new();
1838        # Check for tracing. Set it up if the user asked for it.
1839        if ($query->param('Trace')) {
1840            # Set up tracing to be queued for display at the bottom of the web page.
1841            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1842            # Trace the parameter and environment data.
1843            if (T(CGI => 3)) {
1844                # Here we want to trace the parameter data.
1845                my @names = $query->param;
1846                for my $parmName (sort @names) {
1847                    # Note we skip "Trace", which is for our use only.
1848                    if ($parmName ne 'Trace') {
1849                        my @values = $query->param($parmName);
1850                        Trace("CGI: $parmName = " . join(", ", @values));
1851                    }
1852                }
1853            }
1854            if (T(CGI => 4)) {
1855                # Here we want the environment data too.
1856                for my $envName (sort keys %ENV) {
1857                    Trace("ENV: $envName = $ENV{$envName}");
1858                }
1859            }
1860        } else {
1861            # Here tracing is to be turned off. All we allow is errors traced into the
1862            # error log.
1863            TSetup("0", "WARN");
1864        }
1865        # Create the variable hash.
1866        my $varHash = { DebugData => '' };
1867        # If we're in DEBUG mode, set up the debug mode data for forms.
1868        if (Tracer::DebugMode) {
1869            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1870        }
1871        # Return the query object and variable hash.
1872        return ($query, $varHash);
1873    }
1874    
1875    =head3 ScriptFinish
1876    
1877    C<< ScriptFinish($webData, $varHash); >>
1878    
1879    Output a web page at the end of a script. Either the string to be output or the
1880    name of a template file can be specified. If the second parameter is omitted,
1881    it is assumed we have a string to be output; otherwise, it is assumed we have the
1882    name of a template file. The template should have the variable C<DebugData>
1883    specified in any form that invokes a standard script. If debugging mode is turned
1884    on, a form field will be put in that allows the user to enter tracing data.
1885    Trace messages will be placed immediately before the terminal C<BODY> tag in
1886    the output, formatted as a list.
1887    
1888    A typical standard script would loook like the following.
1889    
1890        BEGIN {
1891            # Print the HTML header.
1892            print "CONTENT-TYPE: text/html\n\n";
1893        }
1894        use Tracer;
1895        use CGI;
1896        use FIG;
1897        # ... more uses ...
1898    
1899        my ($query, $varHash) = ScriptSetup();
1900        eval {
1901            # ... get data from $query, put it in $varHash ...
1902        };
1903        if ($@) {
1904            Trace("Script Error: $@") if T(0);
1905        }
1906        ScriptFinish("Html/MyTemplate.html", $varHash);
1907    
1908    The idea here is that even if the script fails, you'll see trace messages and
1909    useful output.
1910    
1911    =over 4
1912    
1913    =item webData
1914    
1915    A string containing either the full web page to be written to the output or the
1916    name of a template file from which the page is to be constructed. If the name
1917    of a template file is specified, then the second parameter must be present;
1918    otherwise, it must be absent.
1919    
1920    =item varHash (optional)
1921    
1922    If specified, then a reference to a hash mapping variable names for a template
1923    to their values. The template file will be read into memory, and variable markers
1924    will be replaced by data in this hash reference.
1925    
1926    =back
1927    
1928    =cut
1929    
1930    sub ScriptFinish {
1931        # Get the parameters.
1932        my ($webData, $varHash) = @_;
1933        # Check for a template file situation.
1934        my $outputString;
1935        if (defined $varHash) {
1936            # Here we have a template file. We need to apply the variables to the template.
1937            $outputString = PageBuilder::Build("<$webData", $varHash, "Html");
1938        } else {
1939            # Here the user gave us a raw string.
1940            $outputString = $webData;
1941        }
1942        # Check for trace messages.
1943        if ($Destination eq "QUEUE") {
1944            # We have trace messages, so we want to put them at the end of the body. This
1945            # is either at the end of the whole string or at the beginning of the BODY
1946            # end-tag.
1947            my $pos = length $outputString;
1948            if ($outputString =~ m#</body>#gi) {
1949                $pos = (pos $outputString) - 7;
1950            }
1951            substr $outputString, $pos, 0, QTrace('Html');
1952        }
1953        # Write the output string.
1954        print $outputString;
1955    }
1956    
1957    =head3 Insure
1958    
1959    C<< Insure($dirName); >>
1960    
1961    Insure a directory is present.
1962    
1963    =over 4
1964    
1965    =item dirName
1966    
1967    Name of the directory to check. If it does not exist, it will be created.
1968    
1969    =back
1970    
1971    =cut
1972    
1973    sub Insure {
1974        my ($dirName) = @_;
1975        if (! -d $dirName) {
1976            Trace("Creating $dirName directory.") if T(2);
1977            eval { mkpath $dirName; };
1978            if ($@) {
1979                Confess("Error creating $dirName: $@");
1980            }
1981        }
1982    }
1983    
1984    =head3 ChDir
1985    
1986    C<< ChDir($dirName); >>
1987    
1988    Change to the specified directory.
1989    
1990    =over 4
1991    
1992    =item dirName
1993    
1994    Name of the directory to which we want to change.
1995    
1996    =back
1997    
1998    =cut
1999    
2000    sub ChDir {
2001        my ($dirName) = @_;
2002        if (! -d $dirName) {
2003            Confess("Cannot change to directory $dirName: no such directory.");
2004        } else {
2005            Trace("Changing to directory $dirName.") if T(4);
2006            my $okFlag = chdir $dirName;
2007            if (! $okFlag) {
2008                Confess("Error switching to directory $dirName.");
2009            }
2010        }
2011    }
2012    
2013    =head3 SetPermissions
2014    
2015    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2016    
2017    Set the permissions for a directory and all the files and folders inside it.
2018    In addition, the group ownership will be changed to the specified value.
2019    
2020    This method is more vulnerable than most to permission and compatability
2021    problems, so it does internal error recovery.
2022    
2023    =over 4
2024    
2025    =item dirName
2026    
2027    Name of the directory to process.
2028    
2029    =item group
2030    
2031    Name of the group to be assigned.
2032    
2033    =item mask
2034    
2035    Permission mask. Bits that are C<1> in this mask will be ORed into the
2036    permission bits of any file or directory that does not already have them
2037    set to 1.
2038    
2039    =item otherMasks
2040    
2041    Map of search patterns to permission masks. If a directory name matches
2042    one of the patterns, that directory and all its members and subdirectories
2043    will be assigned the new pattern. For example, the following would
2044    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2045    
2046        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2047    
2048    The list is ordered, so the following would use 0777 for C<tmp1> and
2049    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2050    
2051        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2052                                                       '^tmp' => 0666);
2053    
2054    Note that the pattern matches are all case-insensitive, and only directory
2055    names are matched, not file names.
2056    
2057    =back
2058    
2059    =cut
2060    
2061    sub SetPermissions {
2062        # Get the parameters.
2063        my ($dirName, $group, $mask, @otherMasks) = @_;
2064        # Set up for error recovery.
2065        eval {
2066            # Switch to the specified directory.
2067            ChDir($dirName);
2068            # Get the group ID.
2069            my $gid = getgrnam($group);
2070            Trace("Fixing permissions for directory $dirName using group $group($gid).") if T(2);
2071            my $fixCount = 0;
2072            my $lookCount = 0;
2073            # @dirs will be a stack of directories to be processed.
2074            my @dirs = (getcwd());
2075            while (scalar(@dirs) > 0) {
2076                # Get the current directory.
2077                my $dir = pop @dirs;
2078                # Check for a match to one of the specified directory names. To do
2079                # that, we need to pull the individual part of the name off of the
2080                # whole path.
2081                my $simpleName = $dir;
2082                if ($dir =~ m!/(.+)$!) {
2083                    $simpleName = $1;
2084                }
2085                # Search for a match.
2086                my $match = 0;
2087                my $i;
2088                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2089                    my $pattern = $otherMasks[$i];
2090                    if ($simpleName =~ /$pattern/i) {
2091                        $match = 1;
2092                    }
2093                }
2094                # Check for a match.
2095                if ($match && $otherMasks[$i+1] != $mask) {
2096                    # This directory matches one of the incoming patterns, and it's
2097                    # a different mask, so we process it recursively with that mask.
2098                    SetPermissions($dir, $group, $otherMasks[$i+1], @otherMasks);
2099                } else {
2100                    # Here we can process normally. Get all of the non-hidden members.
2101                    my @submems = OpenDir($dir, 1);
2102                    for my $submem (@submems) {
2103                        # Get the full name.
2104                        my $thisMem = "$dir/$submem";
2105                        Trace("Checking member $thisMem.") if T(4);
2106                        $lookCount++;
2107                        if ($lookCount % 1000 == 0) {
2108                            Trace("$lookCount members examined. Current is $thisMem.") if T(3);
2109                        }
2110                        # Fix the group.
2111                        chown -1, $gid, $thisMem;
2112                        # Insure this member is not a symlink.
2113                        if (! -l $thisMem) {
2114                            # Get its info.
2115                            my $fileInfo = stat $thisMem;
2116                            # Only proceed if we got the info. Otherwise, it's a hard link
2117                            # and we want to skip it anyway.
2118                            if ($fileInfo) {
2119                                my $fileMode = $fileInfo->mode;
2120                                if (($fileMode & $mask) == 0) {
2121                                    # Fix this member.
2122                                    $fileMode |= $mask;
2123                                    chmod $fileMode, $thisMem;
2124                                    $fixCount++;
2125                                }
2126                                # If it's a subdirectory, stack it.
2127                                if (-d $thisMem) {
2128                                    push @dirs, $thisMem;
2129                                }
2130                            }
2131                        }
2132                    }
2133                }
2134            }
2135            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2136        };
2137        # Check for an error.
2138        if ($@) {
2139            Confess("SetPermissions error: $@");
2140        }
2141    }
2142    
2143  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3