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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3