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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3