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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3