[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.71, Mon Oct 2 06:34:57 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 EmergencyIP ScriptSetup ScriptFinish Insure ChDir Emergency);
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        use URI::Escape;
37    
38  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
39    
# Line 18  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 36  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, 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
73  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.
74  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 59  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    The format of trace messages is important because some utilities analyze trace files.
125    The time stamp is between square brackets, the module name between angle brackets,
126    a colon (C<:>), and the message text after that. If the square brackets or angle
127    brackets are missing, then the trace management utilities assume that they
128    are encountering a set of pre-formatted lines.
129    
130  =cut  =cut
131    
132  # Declare the configuration variables.  # Declare the configuration variables.
133    
134  my $Destination = "NONE";       # Description of where to send the trace output.  my $Destination = "NONE";       # Description of where to send the trace output.
135    my $TeeFlag = 0;            # TRUE if output is going to a file and to the
136                                # standard output
137  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
138                                                          # hash of active category names                                                          # hash of active category names
139  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
140                                                          # messages                                                          # messages
141  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
142    my $LastCategory = "main";  # name of the last category interrogated
143    my $SetupCount = 0;         # number of times TSetup called
144    my $AllTrace = 0;           # TRUE if we are tracing all categories.
145    
146  =head2 Public Methods  =head2 Public Methods
147    
# Line 90  Line 163 
163    
164  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
165  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
166  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 ">"
167  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
168  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
169    cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
170  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
171  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
172  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 184 
184          my @categoryData = split /\s+/, $categoryList;          my @categoryData = split /\s+/, $categoryList;
185          # Extract the trace level.          # Extract the trace level.
186          $TraceLevel = shift @categoryData;          $TraceLevel = shift @categoryData;
187          # Build the category hash.      # Presume category-based tracing until we learn otherwise.
188        $AllTrace = 0;
189        # Build the category hash. Note that if we find a "*", we turn on non-category
190        # tracing. We must also clear away any pre-existing data.
191        %Categories = ( main => 1 );
192          for my $category (@categoryData) {          for my $category (@categoryData) {
193                  $Categories{$category} = 1;          if ($category eq '*') {
194                $AllTrace = 1;
195            } else {
196                $Categories{lc $category} = 1;
197            }
198          }          }
199          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
200          # 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
201          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
202        if ($target =~ m/^\+?>>?/) {
203            if ($target =~ m/^\+/) {
204                $TeeFlag = 1;
205                $target = substr($target, 1);
206            }
207          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
208                  open TRACEFILE, $target;                  open TRACEFILE, $target;
209                  print TRACEFILE Now() . " Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";
210                  close TRACEFILE;                  close TRACEFILE;
211                  $Destination = ">$target";                  $Destination = ">$target";
212          } else {          } else {
213                $Destination = $target;
214            }
215        } else {
216                  $Destination = uc($target);                  $Destination = uc($target);
217          }          }
218        # Increment the setup counter.
219        $SetupCount++;
220    }
221    
222    =head3 StandardSetup
223    
224    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
225    
226    This method performs standard command-line parsing and tracing setup. The return
227    values are a hash of the command-line options and a list of the positional
228    parameters. Tracing is automatically set up and the command-line options are
229    validated.
230    
231    This is a complex method that does a lot of grunt work. The parameters can
232    be more easily understood, however, once they are examined individually.
233    
234    The I<categories> parameter is the most obtuse. It is a reference to a list of
235    special-purpose tracing categories. Most tracing categories are PERL package
236    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
237    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
238    
239        ["Sprout", "SproutLoad", "ERDB"]
240    
241    This would cause trace messages in the specified three packages to appear in
242    the output. There are two special tracing categories that are automatically
243    handled by this method. In other words, if you used L</TSetup> you would need
244    to include these categories manually, but if you use this method they are turned
245    on automatically.
246    
247    =over 4
248    
249    =item SQL
250    
251    Traces SQL commands and activity.
252    
253    =item Tracer
254    
255    Traces error messages and call stacks.
256    
257    =back
258    
259    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
260    The trace level is specified using the C<-trace> command-line option. For example,
261    the following command line for C<TransactFeatures> turns on SQL tracing and runs
262    all tracing at level 3.
263    
264        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
265    
266    Standard tracing is output to the standard output and echoed to the file
267    C<trace>I<$$>C<.log> in the FIG temporary directory, where I<$$> is the
268    process ID. You can also specify the C<user> parameter to put a user ID
269    instead of a process ID in the trace file name. So, for example
270    
271    The default trace level is 2. To get all messages, specify a trace level of 4.
272    For a genome-by-genome update, use 3.
273    
274        TransactFeatures -trace=3 -sql -user=Bruce register ../xacts IDs.tbl
275    
276    would send the trace output to C<traceBruce.log> in the temporary directory.
277    
278    The I<options> parameter is a reference to a hash containing the command-line
279    options, their default values, and an explanation of what they mean. Command-line
280    options may be in the form of switches or keywords. In the case of a switch, the
281    option value is 1 if it is specified and 0 if it is not specified. In the case
282    of a keyword, the value is separated from the option name by an equal sign. You
283    can see this last in the command-line example above.
284    
285    You can specify a different default trace level by setting C<$options->{trace}>
286    prior to calling this method.
287    
288    An example at this point would help. Consider, for example, the command-line utility
289    C<TransactFeatures>. It accepts a list of positional parameters plus the options
290    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
291    the following code.
292    
293        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
294                            { safe => [0, "use database transactions"],
295                              noAlias => [0, "do not expect aliases in CHANGE transactions"],
296                              start => [' ', "start with this genome"],
297                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
298                            "command transactionDirectory IDfile",
299                          @ARGV);
300    
301    
302    The call to C<ParseCommand> specifies the default values for the options and
303    stores the actual options in a hash that is returned as C<$options>. The
304    positional parameters are returned in C<@parameters>.
305    
306    The following is a sample command line for C<TransactFeatures>.
307    
308        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
309    
310    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
311    parameters, and would find themselves in I<@parameters> after executing the
312    above code fragment. The tracing would be set to level 2, and the categories
313    would be C<Tracer>, and <DocUtils>. C<Tracer> is standard,
314    and C<DocUtils> was included because it came in within the first parameter
315    to this method. The I<$options> hash would be
316    
317        { trace => 2, sql => 0, safe => 0,
318          noAlias => 1, start => ' ', tblFiles => 0 }
319    
320    Use of C<StandardSetup> in this way provides a simple way of performing
321    standard tracing setup and command-line parsing. Note that the caller is
322    not even aware of the command-line switches C<-trace> and C<-sql>, which
323    are used by this method to control the tracing. If additional tracing features
324    need to be added in the future, they can be processed by this method without
325    upsetting the command-line utilities.
326    
327    If the C<background> option is specified on the command line, then the
328    standard and error outputs will be directed to files in the temporary
329    directory, using the same suffix as the trace file. So, if the command
330    line specified
331    
332        -user=Bruce -background
333    
334    then the trace output would go to C<traceBruce.log>, the standard output to
335    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
336    simplify starting a command in the background.
337    
338    Finally, if the special option C<-h> is specified, the option names will
339    be traced at level 0 and the program will exit without processing.
340    This provides a limited help capability. For example, if the user enters
341    
342        TransactFeatures -h
343    
344    he would see the following output.
345    
346        TransactFeatures [options] command transactionDirectory IDfile
347            -trace    tracing level (default 2)
348            -sql      trace SQL commands
349            -safe     use database transactions
350            -noAlias  do not expect aliases in CHANGE transactions
351            -start    start with this genome
352            -tblFiles output TBL files containing the corrected IDs
353    
354    The caller has the option of modifying the tracing scheme by placing a value
355    for C<trace> in the incoming options hash. The default value can be overridden,
356    or the tracing to the standard output can be turned off by suffixing a minus
357    sign to the trace level. So, for example,
358    
359        { trace => [0, "tracing level (default 0)"],
360           ...
361    
362    would set the default trace level to 0 instead of 2, while
363    
364        { trace => ["2-", "tracing level (default 2)"],
365           ...
366    
367    would leave the default at 2, but trace only to the log file, not to the
368    standard output.
369    
370    The parameters to this method are as follows.
371    
372    =over 4
373    
374    =item categories
375    
376    Reference to a list of tracing category names. These should be names of
377    packages whose internal workings will need to be debugged to get the
378    command working.
379    
380    =item options
381    
382    Reference to a hash containing the legal options for the current command mapped
383    to their default values and descriptions. The user can override the defaults
384    by specifying the options as command-line switches prefixed by a hyphen.
385    Tracing-related options may be added to this hash. If the C<-h> option is
386    specified on the command line, the option descriptions will be used to
387    explain the options. To turn off tracing to the standard output, add a
388    minus sign to the value for C<trace> (see above).
389    
390    =item parmHelp
391    
392    A string that vaguely describes the positional parameters. This is used
393    if the user specifies the C<-h> option.
394    
395    =item argv
396    
397    List of command line parameters, including the option switches, which must
398    precede the positional parameters and be prefixed by a hyphen.
399    
400    =item RETURN
401    
402    Returns a list. The first element of the list is the reference to a hash that
403    maps the command-line option switches to their values. These will either be the
404    default values or overrides specified on the command line. The remaining
405    elements of the list are the position parameters, in order.
406    
407    =back
408    
409    =cut
410    
411    sub StandardSetup {
412        # Get the parameters.
413        my ($categories, $options, $parmHelp, @argv) = @_;
414        # Add the tracing options.
415        if (! exists $options->{trace}) {
416            $options->{trace} = [2, "tracing level"];
417        }
418        $options->{sql} = [0, "turn on SQL tracing"];
419        $options->{h} = [0, "display command-line options"];
420        $options->{user} = [$$, "trace log file name suffix"];
421        $options->{background} = [0, "spool standard and error output"];
422        # Create a parsing hash from the options hash. The parsing hash
423        # contains the default values rather than the default value
424        # and the description. While we're at it, we'll memorize the
425        # length of the longest option name.
426        my $longestName = 0;
427        my %parseOptions = ();
428        for my $key (keys %{$options}) {
429            if (length $key > $longestName) {
430                $longestName = length $key;
431            }
432            $parseOptions{$key} = $options->{$key}->[0];
433        }
434        # Parse the command line.
435        my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
436        # Get the logfile suffix.
437        my $suffix = $retOptions->{user};
438        # Check for background mode.
439        if ($retOptions->{background}) {
440            my $outFileName = "$FIG_Config::temp/out$suffix.log";
441            my $errFileName = "$FIG_Config::temp/err$suffix.log";
442            open STDOUT, ">$outFileName";
443            open STDERR, ">$errFileName";
444        }
445        # Now we want to set up tracing. First, we need to know if SQL is to
446        # be traced.
447        my @cats = @{$categories};
448        if ($retOptions->{sql}) {
449            push @cats, "SQL";
450        }
451        # Add the default categories.
452        push @cats, "Tracer";
453        # Next, we create the category string by joining the categories.
454        my $cats = join(" ", @cats);
455        # Check to determine whether or not the caller wants to turn off tracing
456        # to the standard output.
457        my $traceLevel = $retOptions->{trace};
458        my $textOKFlag = 1;
459        if ($traceLevel =~ /^(.)-/) {
460            $traceLevel = $1;
461            $textOKFlag = 0;
462        }
463        # Now we set up the trace mode.
464        my $traceMode;
465        # Verify that we can open a file in the FIG temporary directory.
466        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
467        if (open TESTTRACE, ">$traceFileName") {
468            # Here we can trace to a file.
469            $traceMode = ">$traceFileName";
470            if ($textOKFlag) {
471                # Echo to standard output if the text-OK flag is set.
472                $traceMode = "+$traceMode";
473            }
474            # Close the test file.
475            close TESTTRACE;
476        } else {
477            # Here we can't trace to a file. We trace to the standard output if it's
478            # okay, and the error log otherwise.
479            if ($textOKFlag) {
480                $traceMode = "TEXT";
481            } else {
482                $traceMode = "WARN";
483            }
484        }
485        # Now set up the tracing.
486        TSetup("$traceLevel $cats", $traceMode);
487        # Check for the "h" option. If it is specified, dump the command-line
488        # options and exit the program.
489        if ($retOptions->{h}) {
490            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
491            print "$1 [options] $parmHelp\n";
492            for my $key (sort keys %{$options}) {
493                my $name = Pad($key, $longestName, 0, ' ');
494                my $desc = $options->{$key}->[1];
495                if ($options->{$key}->[0]) {
496                    $desc .= " (default " . $options->{$key}->[0] . ")";
497                }
498                print "  $name $desc\n";
499            }
500            exit(0);
501        }
502        # Return the parsed parameters.
503        return ($retOptions, @retParameters);
504    }
505    
506    =head3 Setups
507    
508    C<< my $count = Tracer::Setups(); >>
509    
510    Return the number of times L</TSetup> has been called.
511    
512    This method allows for the creation of conditional tracing setups where, for example, we
513    may want to set up tracing if nobody else has done it before us.
514    
515    =cut
516    
517    sub Setups {
518        return $SetupCount;
519    }
520    
521    =head3 Open
522    
523    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
524    
525    Open a file.
526    
527    The I<$fileSpec> is essentially the second argument of the PERL C<open>
528    function. The mode is specified using Unix-like shell information. So, for
529    example,
530    
531        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
532    
533    would open for output appended to the specified file, and
534    
535        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
536    
537    would open a pipe that sorts the records written and removes duplicates. Note
538    the use of file handle syntax in the Open call. To use anonymous file handles,
539    code as follows.
540    
541        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
542    
543    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
544    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
545    failed open will throw an exception and the third parameter will be used to construct
546    an error message. If the parameter is omitted, a standard message is constructed
547    using the file spec.
548    
549        Could not open "/usr/spool/news/twitlog"
550    
551    Note that the mode characters are automatically cleaned from the file name.
552    The actual error message from the file system will be captured and appended to the
553    message in any case.
554    
555        Could not open "/usr/spool/news/twitlog": file not found.
556    
557    In some versions of PERL the only error message we get is a number, which
558    corresponds to the C++ C<errno> value.
559    
560        Could not open "/usr/spool/news/twitlog": 6.
561    
562    =over 4
563    
564    =item fileHandle
565    
566    File handle. If this parameter is C<undef>, a file handle will be generated
567    and returned as the value of this method.
568    
569    =item fileSpec
570    
571    File name and mode, as per the PERL C<open> function.
572    
573    =item message (optional)
574    
575    Error message to use if the open fails. If omitted, a standard error message
576    will be generated. In either case, the error information from the file system
577    is appended to the message. To specify a conditional open that does not throw
578    an error if it fails, use C<0>.
579    
580    =item RETURN
581    
582    Returns the name of the file handle assigned to the file, or C<undef> if the
583    open failed.
584    
585    =back
586    
587    =cut
588    
589    sub Open {
590        # Get the parameters.
591        my ($fileHandle, $fileSpec, $message) = @_;
592        # Attempt to open the file.
593        my $rv = open $fileHandle, $fileSpec;
594        # If the open failed, generate an error message.
595        if (! $rv) {
596            # Save the system error message.
597            my $sysMessage = $!;
598            # See if we need a default message.
599            if (!$message) {
600                # Clean any obvious mode characters and leading spaces from the
601                # filename.
602                my ($fileName) = FindNamePart($fileSpec);
603                $message = "Could not open \"$fileName\"";
604            }
605            # Terminate with an error using the supplied message and the
606            # error message from the file system.
607            Confess("$message: $!");
608        }
609        # Return the file handle.
610        return $fileHandle;
611    }
612    
613    =head3 FindNamePart
614    
615    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
616    
617    Extract the portion of a file specification that contains the file name.
618    
619    A file specification is the string passed to an C<open> call. It specifies the file
620    mode and name. In a truly complex situation, it can specify a pipe sequence. This
621    method assumes that the file name is whatever follows the first angle bracket
622    sequence.  So, for example, in the following strings the file name is
623    C</usr/fig/myfile.txt>.
624    
625        >>/usr/fig/myfile.txt
626        </usr/fig/myfile.txt
627        | sort -u > /usr/fig/myfile.txt
628    
629    If the method cannot find a file name using its normal methods, it will return the
630    whole incoming string.
631    
632    =over 4
633    
634    =item fileSpec
635    
636    File specification string from which the file name is to be extracted.
637    
638    =item RETURN
639    
640    Returns a three-element list. The first element contains the file name portion of
641    the specified string, or the whole string if a file name cannot be found via normal
642    methods. The second element contains the start position of the file name portion and
643    the third element contains the length.
644    
645    =back
646    
647    =cut
648    #: Return Type $;
649    sub FindNamePart {
650        # Get the parameters.
651        my ($fileSpec) = @_;
652        # Default to the whole input string.
653        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
654        # Parse out the file name if we can.
655        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
656            $retVal = $2;
657            $len = length $retVal;
658            $pos = (length $fileSpec) - (length $3) - $len;
659        }
660        # Return the result.
661        return ($retVal, $pos, $len);
662    }
663    
664    =head3 OpenDir
665    
666    C<< my @files = OpenDir($dirName, $filtered, $flag); >>
667    
668    Open a directory and return all the file names. This function essentially performs
669    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
670    set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
671    or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
672    filtered out of the return list. If the directory does not open and I<$flag> is not
673    set, an exception is thrown. So, for example,
674    
675        my @files = OpenDir("/Volumes/fig/contigs", 1);
676    
677    is effectively the same as
678    
679        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
680        my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
681    
682    Similarly, the following code
683    
684        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
685    
686    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
687    automatically returns an empty list if the directory fails to open.
688    
689    =over 4
690    
691    =item dirName
692    
693    Name of the directory to open.
694    
695    =item filtered
696    
697    TRUE if files whose names begin with a period (C<.>) should be automatically removed
698    from the list, else FALSE.
699    
700    =item flag
701    
702    TRUE if a failure to open is okay, else FALSE
703    
704    =back
705    
706    =cut
707    #: Return Type @;
708    sub OpenDir {
709        # Get the parameters.
710        my ($dirName, $filtered, $flag) = @_;
711        # Declare the return variable.
712        my @retVal = ();
713        # Open the directory.
714        if (opendir(my $dirHandle, $dirName)) {
715            # The directory opened successfully. Get the appropriate list according to the
716            # strictures of the filter parameter.
717            if ($filtered) {
718                @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
719            } else {
720                @retVal = readdir $dirHandle;
721            }
722        } elsif (! $flag) {
723            # Here the directory would not open and it's considered an error.
724            Confess("Could not open directory $dirName.");
725        }
726        # Return the result.
727        return @retVal;
728  }  }
729    
730  =head3 SetLevel  =head3 SetLevel
# Line 370  Line 970 
970          my ($message) = @_;          my ($message) = @_;
971          # Get the timestamp.          # Get the timestamp.
972          my $timeStamp = Now();          my $timeStamp = Now();
973          # Format the message.      # Format the message. Note we strip off any line terminators at the end.
974          my $formatted = "$timeStamp $message";      my $formatted = "[$timeStamp] <$LastCategory>: " . Strip($message);
975          # Process according to the destination.          # Process according to the destination.
976          if ($Destination eq "TEXT") {          if ($Destination eq "TEXT") {
977                  # Write the message to the standard output.                  # Write the message to the standard output.
# Line 391  Line 991 
991         warn $message;         warn $message;
992          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
993                  # Write the trace message to an output file.                  # Write the trace message to an output file.
994                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
995                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
996                  close TRACING;                  close TRACING;
997            # If the Tee flag is on, echo it to the standard output.
998            if ($TeeFlag) {
999                print "$formatted\n";
1000            }
1001          }          }
1002  }  }
1003    
# Line 436  Line 1040 
1040                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
1041                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
1042                          # 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.
1043                # The calling package is normally the first parameter. If it is
1044                # omitted, the first parameter will be the tracelevel. So, the
1045                # first thing we do is shift the so-called category into the
1046                # $traceLevel variable where it belongs.
1047                          $traceLevel = $category;                          $traceLevel = $category;
1048                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
1049              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 445  Line 1053 
1053                                  $category = $package;                                  $category = $package;
1054                          }                          }
1055                  }                  }
1056                  # Use the package and tracelevel to compute the result.          # Save the category name.
1057                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          $LastCategory = $category;
1058            # Convert it to lower case before we hash it.
1059            $category = lc $category;
1060            # Use the category and tracelevel to compute the result.
1061            if (ref $traceLevel) {
1062                Confess("Bad trace level.");
1063            } elsif (ref $TraceLevel) {
1064                Confess("Bad trace config.");
1065            }
1066            $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
1067      }      }
1068          # Return the computed result.          # Return the computed result.
1069      return $retVal;      return $retVal;
# Line 528  Line 1145 
1145          return ($optionTable, @retVal);          return ($optionTable, @retVal);
1146  }  }
1147    
1148    =head3 Escape
1149    
1150    C<< my $codedString = Tracer::Escape($realString); >>
1151    
1152    Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1153    replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1154    result is to reverse the effect of L</UnEscape>.
1155    
1156    =over 4
1157    
1158    =item realString
1159    
1160    String to escape.
1161    
1162    =item RETURN
1163    
1164    Escaped equivalent of the real string.
1165    
1166    =back
1167    
1168    =cut
1169    
1170    sub Escape {
1171        # Get the parameter.
1172        my ($realString) = @_;
1173        # Initialize the return variable.
1174        my $retVal = "";
1175        # Loop through the parameter string, looking for sequences to escape.
1176        while (length $realString > 0) {
1177            # Look for the first sequence to escape.
1178            if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1179                # Here we found it. The text preceding the sequence is in $1. The sequence
1180                # itself is in $2. First, move the clear text to the return variable.
1181                $retVal .= $1;
1182                # Strip the processed section off the real string.
1183                $realString = substr $realString, (length $2) + (length $1);
1184                # Get the matched character.
1185                my $char = $2;
1186                # If we have a CR, we are done.
1187                if ($char ne "\r") {
1188                    # It's not a CR, so encode the escape sequence.
1189                    $char =~ tr/\t\n/tn/;
1190                    $retVal .= "\\" . $char;
1191                }
1192            } else {
1193                # Here there are no more escape sequences. The rest of the string is
1194                # transferred unmodified.
1195                $retVal .= $realString;
1196                $realString = "";
1197            }
1198        }
1199        # Return the result.
1200        return $retVal;
1201    }
1202    
1203  =head3 UnEscape  =head3 UnEscape
1204    
1205  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1206    
1207  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
1208  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
1209    be deleted.
1210    
1211  =over 4  =over 4
1212    
# Line 555  Line 1228 
1228          my ($codedString) = @_;          my ($codedString) = @_;
1229          # Initialize the return variable.          # Initialize the return variable.
1230          my $retVal = "";          my $retVal = "";
1231        # Only proceed if the incoming string is nonempty.
1232        if (defined $codedString) {
1233          # 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
1234          # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1235          # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1236          while (length $codedString > 0) {          while (length $codedString > 0) {
1237                  # Look for the first escape sequence.                  # Look for the first escape sequence.
1238                  if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1239                          # 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
1240                          # 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.
1241                          $retVal .= $1;                          $retVal .= $1;
1242                          $codedString = substr $codedString, (2 + length $1);                          $codedString = substr $codedString, (2 + length $1);
1243                          # Decode the escape sequence.                  # Get the escape value.
1244                          my $char = $2;                          my $char = $2;
1245                          $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1246                    if ($char ne 'r') {
1247                        # Here it's not an 'r', so we convert it.
1248                        $char =~ tr/\\tn/\\\t\n/;
1249                          $retVal .= $char;                          $retVal .= $char;
1250                    }
1251                  } else {                  } else {
1252                          # 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
1253                          # transferred unmodified.                          # transferred unmodified.
# Line 576  Line 1255 
1255                          $codedString = "";                          $codedString = "";
1256                  }                  }
1257          }          }
1258        }
1259          # Return the result.          # Return the result.
1260          return $retVal;          return $retVal;
1261  }  }
# Line 673  Line 1353 
1353          return @inputList;          return @inputList;
1354  }  }
1355    
1356    =head3 Percent
1357    
1358    C<< my $percent = Tracer::Percent($number, $base); >>
1359    
1360    Returns the percent of the base represented by the given number. If the base
1361    is zero, returns zero.
1362    
1363    =over 4
1364    
1365    =item number
1366    
1367    Percent numerator.
1368    
1369    =item base
1370    
1371    Percent base.
1372    
1373    =item RETURN
1374    
1375    Returns the percentage of the base represented by the numerator.
1376    
1377    =back
1378    
1379    =cut
1380    
1381    sub Percent {
1382        # Get the parameters.
1383        my ($number, $base) = @_;
1384        # Declare the return variable.
1385        my $retVal = 0;
1386        # Compute the percent.
1387        if ($base != 0) {
1388            $retVal = $number * 100 / $base;
1389        }
1390        # Return the result.
1391        return $retVal;
1392    }
1393    
1394  =head3 GetFile  =head3 GetFile
1395    
1396  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1397    
1398  Return the entire contents of a file.      or
1399    
1400    C<< my $fileContents = Tracer::GetFile($fileName); >>
1401    
1402    Return the entire contents of a file. In list context, line-ends are removed and
1403    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1404    
1405  =over 4  =over 4
1406    
# Line 688  Line 1411 
1411  =item RETURN  =item RETURN
1412    
1413  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.
1414  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
1415    the file, an empty list will be returned.
1416    
1417  =back  =back
1418    
# Line 700  Line 1424 
1424          # Declare the return variable.          # Declare the return variable.
1425          my @retVal = ();          my @retVal = ();
1426          # Open the file for input.          # Open the file for input.
1427          my $ok = open INPUTFILE, "<$fileName";      my $handle = Open(undef, "<$fileName");
1428          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  
1429          # characters.          # characters.
1430          my $lineCount = 0;          my $lineCount = 0;
1431                  while (my $line = <INPUTFILE>) {      while (my $line = <$handle>) {
1432              $lineCount++;              $lineCount++;
1433              $line =~ s/(\r|\n)+$//g;          $line = Strip($line);
1434                          push @retVal, $line;                          push @retVal, $line;
1435                  }                  }
1436                  # Close it.                  # Close it.
1437                  close INPUTFILE;      close $handle;
1438          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(0);  
         }  
1439          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1440      if (wantarray) {      if (wantarray) {
1441              return @retVal;              return @retVal;
# Line 726  Line 1444 
1444      }      }
1445  }  }
1446    
1447  =head3 QTrace  =head3 PutFile
1448    
1449  C<< my $data = QTrace($format); >>  C<< Tracer::PutFile($fileName, \@lines); >>
1450    
1451  Return the queued trace data in the specified format.  Write out a file from a list of lines of text.
1452    
1453  =over 4  =over 4
1454    
1455  =item format  =item fileName
1456    
1457  C<html> to format the data as an HTML list, C<text> to format it as straight text.  Name of the output file.
1458    
1459    =item lines
1460    
1461    Reference to a list of text lines. The lines will be written to the file in order, with trailing
1462    new-line characters. Alternatively, may be a string, in which case the string will be written without
1463    modification.
1464    
1465    =back
1466    
1467    =cut
1468    
1469    sub PutFile {
1470        # Get the parameters.
1471        my ($fileName, $lines) = @_;
1472        # Open the output file.
1473        my $handle = Open(undef, ">$fileName");
1474        if (ref $lines ne 'ARRAY') {
1475            # Here we have a scalar, so we write it raw.
1476            print $handle $lines;
1477        } else {
1478            # Write the lines one at a time.
1479            for my $line (@{$lines}) {
1480                print $handle "$line\n";
1481            }
1482        }
1483        # Close the output file.
1484        close $handle;
1485    }
1486    
1487    =head3 QTrace
1488    
1489    C<< my $data = QTrace($format); >>
1490    
1491    Return the queued trace data in the specified format.
1492    
1493    =over 4
1494    
1495    =item format
1496    
1497    C<html> to format the data as an HTML list, C<text> to format it as straight text.
1498    
1499  =back  =back
1500    
# Line 747  Line 1505 
1505          my ($format) = @_;          my ($format) = @_;
1506          # Create the return variable.          # Create the return variable.
1507          my $retVal = "";          my $retVal = "";
1508        # Only proceed if there is an actual queue.
1509        if (@Queue) {
1510          # Process according to the format.          # Process according to the format.
1511          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1512                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 762  Line 1522 
1522          }          }
1523          # Clear the queue.          # Clear the queue.
1524          @Queue = ();          @Queue = ();
1525        }
1526          # Return the formatted list.          # Return the formatted list.
1527          return $retVal;          return $retVal;
1528  }  }
# Line 770  Line 1531 
1531    
1532  C<< Confess($message); >>  C<< Confess($message); >>
1533    
1534  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  
1535  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.
1536  So, for example  So, for example
1537    
# Line 793  Line 1553 
1553          # Get the parameters.          # Get the parameters.
1554          my ($message) = @_;          my ($message) = @_;
1555          # Trace the call stack.          # Trace the call stack.
1556          Cluck($message) if T(1);      Cluck($message);
1557          # Abort the program.          # Abort the program.
1558          croak(">>> $message");          croak(">>> $message");
1559  }  }
# Line 803  Line 1563 
1563  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1564    
1565  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
1566  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.
1567  So, for example  So, for example
1568    
1569  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 924  Line 1684 
1684    
1685  =head3 AddToListMap  =head3 AddToListMap
1686    
1687  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1688    
1689  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
1690  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 1699 
1699    
1700  Key for which the value is to be added.  Key for which the value is to be added.
1701    
1702  =item value  =item value1, value2, ... valueN
1703    
1704  Value to add to the key's value list.  List of values to add to the key's value list.
1705    
1706  =back  =back
1707    
# Line 949  Line 1709 
1709    
1710  sub AddToListMap {  sub AddToListMap {
1711      # Get the parameters.      # Get the parameters.
1712      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1713      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1714      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1715          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1716        } else {
1717            push @{$hash->{$key}}, @values;
1718        }
1719    }
1720    
1721    =head3 DebugMode
1722    
1723    C<< if (Tracer::DebugMode) { ...code... } >>
1724    
1725    Return TRUE if debug mode has been turned on, else abort.
1726    
1727    Certain CGI scripts are too dangerous to exist in the production
1728    environment. This method provides a simple way to prevent them
1729    from working unless they are explicitly turned on by creating a password
1730    cookie via the B<SetPassword> script.  If debugging mode
1731    is not turned on, an error will occur.
1732    
1733    =cut
1734    
1735    sub DebugMode {
1736        # Declare the return variable.
1737        my $retVal = 0;
1738        # Check the debug configuration.
1739        my $password = CGI::cookie("DebugMode");
1740        my $encrypted = Digest::MD5::md5_hex($password);
1741        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1742            $retVal = 1;
1743        } else {
1744            # Here debug mode is off, so we generate an error.
1745            Confess("Cannot use this facility without logging in.");
1746        }
1747        # Return the determination indicator.
1748        return $retVal;
1749    }
1750    
1751    =head3 Strip
1752    
1753    C<< my $string = Tracer::Strip($line); >>
1754    
1755    Strip all line terminators off a string. This is necessary when dealing with files
1756    that may have been transferred back and forth several times among different
1757    operating environments.
1758    
1759    =over 4
1760    
1761    =item line
1762    
1763    Line of text to be stripped.
1764    
1765    =item RETURN
1766    
1767    The same line of text with all the line-ending characters chopped from the end.
1768    
1769    =back
1770    
1771    =cut
1772    
1773    sub Strip {
1774        # Get a copy of the parameter string.
1775        my ($string) = @_;
1776        my $retVal = (defined $string ? $string : "");
1777        # Strip the line terminator characters.
1778        $retVal =~ s/(\r|\n)+$//g;
1779        # Return the result.
1780        return $retVal;
1781    }
1782    
1783    =head3 Pad
1784    
1785    C<< my $paddedString = Tracer::Pad($string, $len, $left, $padChar); >>
1786    
1787    Pad a string to a specified length. The pad character will be a
1788    space, and the padding will be on the right side unless specified
1789    in the third parameter.
1790    
1791    =over 4
1792    
1793    =item string
1794    
1795    String to be padded.
1796    
1797    =item len
1798    
1799    Desired length of the padded string.
1800    
1801    =item left (optional)
1802    
1803    TRUE if the string is to be left-padded; otherwise it will be padded on the right.
1804    
1805    =item padChar (optional)
1806    
1807    Character to use for padding. The default is a space.
1808    
1809    =item RETURN
1810    
1811    Returns a copy of the original string with the pad character added to the
1812    specified end so that it achieves the desired length.
1813    
1814    =back
1815    
1816    =cut
1817    
1818    sub Pad {
1819        # Get the parameters.
1820        my ($string, $len, $left, $padChar) = @_;
1821        # Compute the padding character.
1822        if (! defined $padChar) {
1823            $padChar = " ";
1824        }
1825        # Compute the number of spaces needed.
1826        my $needed = $len - length $string;
1827        # Copy the string into the return variable.
1828        my $retVal = $string;
1829        # Only proceed if padding is needed.
1830        if ($needed > 0) {
1831            # Create the pad string.
1832            my $pad = $padChar x $needed;
1833            # Affix it to the return value.
1834            if ($left) {
1835                $retVal = $pad . $retVal;
1836      } else {      } else {
1837          push @{$hash->{$key}}, $value;              $retVal .= $pad;
1838            }
1839      }      }
1840        # Return the result.
1841        return $retVal;
1842    }
1843    
1844    =head3 EOF
1845    
1846    This is a constant that is lexically greater than any useful string.
1847    
1848    =cut
1849    
1850    sub EOF {
1851        return "\xFF\xFF\xFF\xFF\xFF";
1852    }
1853    
1854    =head3 TICK
1855    
1856    C<< my @results = TICK($commandString); >>
1857    
1858    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1859    dot-slash (C<./> will be removed. So, for example, if you were doing
1860    
1861        `./protein.cgi`
1862    
1863    from inside a CGI script, it would work fine in Unix, but would issue an error message
1864    in Windows complaining that C<'.'> is not a valid command. If instead you code
1865    
1866        TICK("./protein.cgi")
1867    
1868    it will work correctly in both environments.
1869    
1870    =over 4
1871    
1872    =item commandString
1873    
1874    The command string to pass to the system.
1875    
1876    =item RETURN
1877    
1878    Returns the standard output from the specified command, as a list.
1879    
1880    =back
1881    
1882    =cut
1883    #: Return Type @;
1884    sub TICK {
1885        # Get the parameters.
1886        my ($commandString) = @_;
1887        # Chop off the dot-slash if this is Windows.
1888        if ($FIG_Config::win_mode) {
1889            $commandString =~ s!^\./!!;
1890        }
1891        # Activate the command and return the result.
1892        return `$commandString`;
1893    }
1894    
1895    =head3 ScriptSetup
1896    
1897    C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>
1898    
1899    Perform standard tracing and debugging setup for scripts. The value returned is
1900    the CGI object followed by a pre-built variable hash.
1901    
1902    The C<Trace> query parameter is used to determine whether or not tracing is active and
1903    which trace modules (other than C<Tracer> itself) should be turned on. Specifying
1904    the C<CGI> trace module will trace parameter and environment information. Parameters are
1905    traced at level 3 and environment variables at level 4. To trace to a file instead of to
1906    the web page, set C<TF> to 1. At the end of the script, the client should call
1907    L</ScriptFinish> to output the web page.
1908    
1909    In some situations, it is not practical to invoke tracing via form parameters. For this
1910    situation, you can turn on emergency tracing by invoking the L</Emergency> method from
1911    a web page. Emergency tracing is detected via a file with the name
1912    C<Emergency>I<IPaddr>C<.txt> in the FIG temporary directory, where I<IPaddr> is the
1913    IP address of the remote user who wants tracing turned on. The file contains a time
1914    limit in hours on the first line, a tracing destination on the second line, a trace
1915    level on the third line, and the tracing modules on subsequent lines.
1916    
1917    =over 4
1918    
1919    =item noTrace (optional)
1920    
1921    If specified, tracing will be suppressed. This is useful if the script wants to set up
1922    tracing manually.
1923    
1924    =item RETURN
1925    
1926    Returns a two-element list consisting of a CGI query object and a variable hash for
1927    the output page.
1928    
1929    =back
1930    
1931    =cut
1932    
1933    sub ScriptSetup {
1934        # Get the parameters.
1935        my ($noTrace) = @_;
1936        # Get the CGI query object.
1937        my $cgi = CGI->new();
1938        # Set up tracing if it's not suppressed.
1939        CGITrace($cgi) unless $noTrace;
1940        # Create the variable hash.
1941        my $varHash = { results => '' };
1942        # Return the query object and variable hash.
1943        return ($cgi, $varHash);
1944    }
1945    
1946    =head3 CGITrace
1947    
1948    C<< Tracer::CGITrace($cgi); >>
1949    
1950    Set up tracing for a CGI script. See L</ScriptSetup> for more information.
1951    
1952    =over 4
1953    
1954    =item cgi
1955    
1956    Ths CGI query object for this script.
1957    
1958    =back
1959    
1960    =cut
1961    
1962    sub CGITrace {
1963        # Get the parameters.
1964        my ($cgi) = @_;
1965        # Default to no tracing except errors.
1966        my ($tracing, $dest) = ("0", "WARN");
1967        # Check for emergency tracing.
1968        my $ip = EmergencyIP($cgi);
1969        my $emergencyFile = EmergencyFileName($ip);
1970        if (-e $emergencyFile) {
1971            # We have the file. Read in the data.
1972            my @tracing = GetFile($emergencyFile);
1973            # Pull off the time limit.
1974            my $expire = shift @tracing;
1975            # Convert it to seconds.
1976            $expire *= 3600;
1977            # Check the file data.
1978            my $stat = stat($emergencyFile);
1979            my ($now) = gettimeofday;
1980            if ($now - $stat->mtime > $expire) {
1981                # Delete the expired file.
1982                unlink $emergencyFile;
1983            } else {
1984                # Emergency tracing is on. Pull off the destination and
1985                # the trace level;
1986                $dest = shift @tracing;
1987                my $level = shift @tracing;
1988                # Convert the destination to a real tracing destination.
1989                # temp directory.
1990                $dest = EmergencyTracingDest($ip, $dest);
1991                # Insure Tracer is specified.
1992                my %moduleHash = map { $_ => 1 } @tracing;
1993                $moduleHash{Tracer} = 1;
1994                # Set the trace parameter.
1995                $tracing = join(" ", $level, sort keys %moduleHash);
1996                # Make sure the script knows tracing is on.
1997                $cgi->param(-name => 'Trace', -value => $tracing);
1998                $cgi->param(-name => 'TF', -value => (($dest =~ /^>/) ? 1 : 0));
1999            }
2000        } elsif ($cgi->param('Trace')) {
2001            # Here the user has requested tracing via a form.
2002            $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
2003            $tracing = $cgi->param('Trace') . " Tracer";
2004        }
2005        # Setup the tracing we've determined from all the stuff above.
2006        TSetup($tracing, $dest);
2007        # Trace the parameter and environment data.
2008        TraceParms($cgi);
2009    }
2010    
2011    =head3 EmergencyFileName
2012    
2013    C<< my $fileName = Tracer::EmergencyFileName($ip); >>
2014    
2015    Return the emergency tracing file name. This is the file that specifies
2016    the tracing information.
2017    
2018    =over 4
2019    
2020    =item ip
2021    
2022    IP address of the user who wants tracing, as taken from the C<< $cgi->remote_host() >>
2023    method.
2024    
2025    =item RETURN
2026    
2027    Returns the name of the file to contain the emergency tracing information.
2028    
2029    =back
2030    
2031    =cut
2032    
2033    sub EmergencyFileName {
2034        # Get the parameters.
2035        my ($ip) = @_;
2036        # Compute the emergency tracing file name.
2037        return "$FIG_Config::temp/Emergency$ip.txt";
2038    }
2039    
2040    =head3 EmergencyFileTarget
2041    
2042    C<< my $fileName = Tracer::EmergencyFileTarget($ip); >>
2043    
2044    Return the emergency tracing target file name. This is the file that receives
2045    the tracing output for file-based tracing.
2046    
2047    =over 4
2048    
2049    =item ip
2050    
2051    IP address of the user who wants tracing, as taken from the C<< $cgi->remote_host() >>
2052    method.
2053    
2054    =item RETURN
2055    
2056    Returns the name of the file to contain the emergency tracing information.
2057    
2058    =back
2059    
2060    =cut
2061    
2062    sub EmergencyFileTarget {
2063        # Get the parameters.
2064        my ($ip) = @_;
2065        # Compute the emergency tracing file name.
2066        return "$FIG_Config::temp/Emergency$ip.log";
2067    }
2068    
2069    =head3 EmergencyTracingDest
2070    
2071    C<< my $dest = Tracer::EmergencyTracingDest($ip, $myDest); >>
2072    
2073    This method converts an emergency tracing destination to a real
2074    tracing destination. The main difference is that if the
2075    destination is C<FILE> or C<APPEND>, we convert it to file
2076    output.
2077    
2078    =over 4
2079    
2080    =item ip
2081    
2082    IP address of the user who wants tracing, as taken from the C<< $cgi->remote_host() >>
2083    method.
2084    
2085    =item myDest
2086    
2087    Destination from the emergency tracing file.
2088    
2089    =item RETURN
2090    
2091    Returns a destination that can be passed into L</TSetup>.
2092    
2093    =back
2094    
2095    =cut
2096    
2097    sub EmergencyTracingDest {
2098        # Get the parameters.
2099        my ($ip, $myDest) = @_;
2100        # Declare the return variable.
2101        my $retVal;
2102        # Process according to the destination value.
2103        if ($myDest eq 'FILE') {
2104            $retVal = ">" . EmergencyFileTarget($ip);
2105        } elsif ($myDest eq 'APPEND') {
2106            $retVal = ">>" . EmergencyFileTarget($ip);
2107        } else {
2108            $retVal = $myDest;
2109        }
2110        # Return the result.
2111        return $retVal;
2112    }
2113    
2114    =head3 Emergency
2115    
2116    C<< Emergency($cgi, $hours, $dest, $level, @modules); >>
2117    
2118    Turn on emergency tracing. This method can only be invoked over the web and is
2119    should not be called if debug mode is off. The caller specifies the duration of the
2120    emergency in hours, the desired tracing destination, the trace level,
2121    and a list of the trace modules to activate. For the duration, when a user
2122    from the specified remote web location invokes a Sprout CGI script, tracing
2123    will be turned on automatically. See L</TSetup> for more about tracing
2124    setup and L</ScriptSetup> for more about emergency tracing.
2125    
2126    =over 4
2127    
2128    =item cgi
2129    
2130    A CGI query object.
2131    
2132    =item hours
2133    
2134    Number of hours to keep emergency tracing alive.
2135    
2136    =item dest
2137    
2138    Tracing destination. If no path information is specified for a file
2139    destination, it is put in the FIG temporary directory.
2140    
2141    =item level
2142    
2143    Tracing level. A higher level means more trace messages.
2144    
2145    =item modules
2146    
2147    A list of the tracing modules to activate.
2148    
2149    =back
2150    
2151    =cut
2152    
2153    sub Emergency {
2154        # Get the parameters.
2155        my ($cgi, $hours, $dest, $level, @modules) = @_;
2156        # Get the IP address.
2157        my $ip = EmergencyIP($cgi);
2158        # Create the emergency file.
2159        my $specFile = EmergencyFileName($ip);
2160        my $outHandle = Open(undef, ">$specFile");
2161        print $outHandle join("\n", $hours, $dest, $level, @modules, "");
2162    }
2163    
2164    =head3 EmergencyIP
2165    
2166    C<< my $ip = EmergencyIP($cgi); >>
2167    
2168    Return the IP address to be used for emergency tracing. In actual fact, this is not an
2169    IP address but a session ID stored in a cookie. It used to be an IP address, but those
2170    are too fluid.
2171    
2172    =over 4
2173    
2174    =item cgi
2175    
2176    CGI query object.
2177    
2178    =item RETURN
2179    
2180    Returns the IP address to be used for labelling emergency tracing.
2181    
2182    =back
2183    
2184    =cut
2185    
2186    sub EmergencyIP {
2187        # Get the parameters.
2188        my ($cgi) = @_;
2189        # Look for a cookie.
2190        my $retVal = $cgi->cookie('IP');
2191        # If no cookie, return the remote host address. This will probably not
2192        # work, but that's okay, since the lack of a cookie means the
2193        # tracing is not turned on.
2194        $retVal = $cgi->remote_host() if ! $retVal;
2195        # Return the result.
2196        return $retVal;
2197    }
2198    
2199    
2200    =head3 TraceParms
2201    
2202    C<< Tracer::TraceParms($cgi); >>
2203    
2204    Trace the CGI parameters at trace level CGI => 3 and the environment variables
2205    at level CGI => 4.
2206    
2207    =over 4
2208    
2209    =item cgi
2210    
2211    CGI query object containing the parameters to trace.
2212    
2213    =back
2214    
2215    =cut
2216    
2217    sub TraceParms {
2218        # Get the parameters.
2219        my ($cgi) = @_;
2220        if (T(CGI => 3)) {
2221            # Here we want to trace the parameter data.
2222            my @names = $cgi->param;
2223            for my $parmName (sort @names) {
2224                # Note we skip the Trace parameters, which are for our use only.
2225                if ($parmName ne 'Trace' && $parmName ne 'TF') {
2226                    my @values = $cgi->param($parmName);
2227                    Trace("CGI: $parmName = " . join(", ", @values));
2228                }
2229            }
2230            # Display the request method.
2231            my $method = $cgi->request_method();
2232            Trace("Method: $method");
2233        }
2234        if (T(CGI => 4)) {
2235            # Here we want the environment data too.
2236            for my $envName (sort keys %ENV) {
2237                Trace("ENV: $envName = $ENV{$envName}");
2238            }
2239        }
2240    }
2241    
2242    =head3 ScriptFinish
2243    
2244    C<< ScriptFinish($webData, $varHash); >>
2245    
2246    Output a web page at the end of a script. Either the string to be output or the
2247    name of a template file can be specified. If the second parameter is omitted,
2248    it is assumed we have a string to be output; otherwise, it is assumed we have the
2249    name of a template file. The template should have the variable C<DebugData>
2250    specified in any form that invokes a standard script. If debugging mode is turned
2251    on, a form field will be put in that allows the user to enter tracing data.
2252    Trace messages will be placed immediately before the terminal C<BODY> tag in
2253    the output, formatted as a list.
2254    
2255    A typical standard script would loook like the following.
2256    
2257        BEGIN {
2258            # Print the HTML header.
2259            print "CONTENT-TYPE: text/html\n\n";
2260        }
2261        use Tracer;
2262        use CGI;
2263        use FIG;
2264        # ... more uses ...
2265    
2266        my ($cgi, $varHash) = ScriptSetup();
2267        eval {
2268            # ... get data from $cgi, put it in $varHash ...
2269        };
2270        if ($@) {
2271            Trace("Script Error: $@") if T(0);
2272        }
2273        ScriptFinish("Html/MyTemplate.html", $varHash);
2274    
2275    The idea here is that even if the script fails, you'll see trace messages and
2276    useful output.
2277    
2278    =over 4
2279    
2280    =item webData
2281    
2282    A string containing either the full web page to be written to the output or the
2283    name of a template file from which the page is to be constructed. If the name
2284    of a template file is specified, then the second parameter must be present;
2285    otherwise, it must be absent.
2286    
2287    =item varHash (optional)
2288    
2289    If specified, then a reference to a hash mapping variable names for a template
2290    to their values. The template file will be read into memory, and variable markers
2291    will be replaced by data in this hash reference.
2292    
2293    =back
2294    
2295    =cut
2296    
2297    sub ScriptFinish {
2298        # Get the parameters.
2299        my ($webData, $varHash) = @_;
2300        # Check for a template file situation.
2301        my $outputString;
2302        if (defined $varHash) {
2303            # Here we have a template file. We need to determine the template type.
2304            my $template;
2305            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
2306                $template = "$FIG_Config::template_url/$webData";
2307            } else {
2308                $template = "<<$webData";
2309            }
2310            $outputString = PageBuilder::Build($template, $varHash, "Html");
2311        } else {
2312            # Here the user gave us a raw string.
2313            $outputString = $webData;
2314        }
2315        # Check for trace messages.
2316        if ($Destination ne "NONE" && $TraceLevel > 0) {
2317            # We have trace messages, so we want to put them at the end of the body. This
2318            # is either at the end of the whole string or at the beginning of the BODY
2319            # end-tag.
2320            my $pos = length $outputString;
2321            if ($outputString =~ m#</body>#gi) {
2322                $pos = (pos $outputString) - 7;
2323            }
2324            # If the trace messages were queued, we unroll them. Otherwise, we display the
2325            # destination.
2326            my $traceHtml;
2327            if ($Destination eq "QUEUE") {
2328                $traceHtml = QTrace('Html');
2329            } elsif ($Destination =~ /^>>(.+)$/) {
2330                # Here the tracing output it to a file. We code it as a hyperlink so the user
2331                # can copy the file name into the clipboard easily.
2332                my $actualDest = $1;
2333                $traceHtml = "<p>Tracing output to <a href=\"$actualDest\">$actualDest</a>.</p>\n";
2334            } else {
2335                # Here we have one of the special destinations.
2336                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
2337            }
2338            substr $outputString, $pos, 0, $traceHtml;
2339        }
2340        # Write the output string.
2341        print $outputString;
2342    }
2343    
2344    =head3 Insure
2345    
2346    C<< Insure($dirName); >>
2347    
2348    Insure a directory is present.
2349    
2350    =over 4
2351    
2352    =item dirName
2353    
2354    Name of the directory to check. If it does not exist, it will be created.
2355    
2356    =back
2357    
2358    =cut
2359    
2360    sub Insure {
2361        my ($dirName) = @_;
2362        if (! -d $dirName) {
2363            Trace("Creating $dirName directory.") if T(2);
2364            eval { mkpath $dirName; };
2365            if ($@) {
2366                Confess("Error creating $dirName: $@");
2367            }
2368        }
2369    }
2370    
2371    =head3 ChDir
2372    
2373    C<< ChDir($dirName); >>
2374    
2375    Change to the specified directory.
2376    
2377    =over 4
2378    
2379    =item dirName
2380    
2381    Name of the directory to which we want to change.
2382    
2383    =back
2384    
2385    =cut
2386    
2387    sub ChDir {
2388        my ($dirName) = @_;
2389        if (! -d $dirName) {
2390            Confess("Cannot change to directory $dirName: no such directory.");
2391        } else {
2392            Trace("Changing to directory $dirName.") if T(4);
2393            my $okFlag = chdir $dirName;
2394            if (! $okFlag) {
2395                Confess("Error switching to directory $dirName.");
2396            }
2397        }
2398    }
2399    
2400    =head3 SendSMS
2401    
2402    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2403    
2404    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2405    user name, password, and API ID for the relevant account in the hash reference variable
2406    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2407    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2408    is C<2561022>, then the FIG_Config file must contain
2409    
2410        $phone =  { user => 'BruceTheHumanPet',
2411                    password => 'silly',
2412                    api_id => '2561022' };
2413    
2414    The original purpose of this method was to insure Bruce would be notified immediately when the
2415    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2416    when you call this method.
2417    
2418    The message ID will be returned if successful, and C<undef> if an error occurs.
2419    
2420    =over 4
2421    
2422    =item phoneNumber
2423    
2424    Phone number to receive the message, in international format. A United States phone number
2425    would be prefixed by "1". A British phone number would be prefixed by "44".
2426    
2427    =item msg
2428    
2429    Message to send to the specified phone.
2430    
2431    =item RETURN
2432    
2433    Returns the message ID if successful, and C<undef> if the message could not be sent.
2434    
2435    =back
2436    
2437    =cut
2438    
2439    sub SendSMS {
2440        # Get the parameters.
2441        my ($phoneNumber, $msg) = @_;
2442        # Declare the return variable. If we do not change it, C<undef> will be returned.
2443        my $retVal;
2444        # Only proceed if we have phone support.
2445        if (! defined $FIG_Config::phone) {
2446            Trace("Phone support not present in FIG_Config.") if T(1);
2447        } else {
2448            # Get the phone data.
2449            my $parms = $FIG_Config::phone;
2450            # Get the Clickatell URL.
2451            my $url = "http://api.clickatell.com/http/";
2452            # Create the user agent.
2453            my $ua = LWP::UserAgent->new;
2454            # Request a Clickatell session.
2455            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2456                                         password => $parms->{password},
2457                                         api_id => $parms->{api_id},
2458                                         to => $phoneNumber,
2459                                         text => $msg});
2460            # Check for an error.
2461            if (! $resp->is_success) {
2462                Trace("Alert failed.") if T(1);
2463            } else {
2464                # Get the message ID.
2465                my $rstring = $resp->content;
2466                if ($rstring =~ /^ID:\s+(.*)$/) {
2467                    $retVal = $1;
2468                } else {
2469                    Trace("Phone attempt failed with $rstring") if T(1);
2470                }
2471            }
2472        }
2473        # Return the result.
2474        return $retVal;
2475    }
2476    
2477    =head3 CommaFormat
2478    
2479    C<< my $formatted = Tracer::CommaFormat($number); >>
2480    
2481    Insert commas into a number.
2482    
2483    =over 4
2484    
2485    =item number
2486    
2487    A sequence of digits.
2488    
2489    =item RETURN
2490    
2491    Returns the same digits with commas strategically inserted.
2492    
2493    =back
2494    
2495    =cut
2496    
2497    sub CommaFormat {
2498        # Get the parameters.
2499        my ($number) = @_;
2500        # Pad the length up to a multiple of three.
2501        my $padded = "$number";
2502        $padded = " " . $padded while length($padded) % 3 != 0;
2503        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2504        # cause the delimiters to be included in the output stream. The
2505        # GREP removes the empty strings in between the delimiters.
2506        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2507        # Clean out the spaces.
2508        $retVal =~ s/ //g;
2509        # Return the result.
2510        return $retVal;
2511    }
2512    =head3 SetPermissions
2513    
2514    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2515    
2516    Set the permissions for a directory and all the files and folders inside it.
2517    In addition, the group ownership will be changed to the specified value.
2518    
2519    This method is more vulnerable than most to permission and compatability
2520    problems, so it does internal error recovery.
2521    
2522    =over 4
2523    
2524    =item dirName
2525    
2526    Name of the directory to process.
2527    
2528    =item group
2529    
2530    Name of the group to be assigned.
2531    
2532    =item mask
2533    
2534    Permission mask. Bits that are C<1> in this mask will be ORed into the
2535    permission bits of any file or directory that does not already have them
2536    set to 1.
2537    
2538    =item otherMasks
2539    
2540    Map of search patterns to permission masks. If a directory name matches
2541    one of the patterns, that directory and all its members and subdirectories
2542    will be assigned the new pattern. For example, the following would
2543    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2544    
2545        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2546    
2547    The list is ordered, so the following would use 0777 for C<tmp1> and
2548    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2549    
2550        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2551                                                       '^tmp' => 0666);
2552    
2553    Note that the pattern matches are all case-insensitive, and only directory
2554    names are matched, not file names.
2555    
2556    =back
2557    
2558    =cut
2559    
2560    sub SetPermissions {
2561        # Get the parameters.
2562        my ($dirName, $group, $mask, @otherMasks) = @_;
2563        # Set up for error recovery.
2564        eval {
2565            # Switch to the specified directory.
2566            ChDir($dirName);
2567            # Get the group ID.
2568            my $gid = getgrnam($group);
2569            # Get the mask for tracing.
2570            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2571            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2572            my $fixCount = 0;
2573            my $lookCount = 0;
2574            # @dirs will be a stack of directories to be processed.
2575            my @dirs = (getcwd());
2576            while (scalar(@dirs) > 0) {
2577                # Get the current directory.
2578                my $dir = pop @dirs;
2579                # Check for a match to one of the specified directory names. To do
2580                # that, we need to pull the individual part of the name off of the
2581                # whole path.
2582                my $simpleName = $dir;
2583                if ($dir =~ m!/([^/]+)$!) {
2584                    $simpleName = $1;
2585                }
2586                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2587                # Search for a match.
2588                my $match = 0;
2589                my $i;
2590                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2591                    my $pattern = $otherMasks[$i];
2592                    if ($simpleName =~ /$pattern/i) {
2593                        $match = 1;
2594                    }
2595                }
2596                # Check for a match. Note we use $i-1 because the loop added 2
2597                # before terminating due to the match.
2598                if ($match && $otherMasks[$i-1] != $mask) {
2599                    # This directory matches one of the incoming patterns, and it's
2600                    # a different mask, so we process it recursively with that mask.
2601                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2602                } else {
2603                    # Here we can process normally. Get all of the non-hidden members.
2604                    my @submems = OpenDir($dir, 1);
2605                    for my $submem (@submems) {
2606                        # Get the full name.
2607                        my $thisMem = "$dir/$submem";
2608                        Trace("Checking member $thisMem.") if T(4);
2609                        $lookCount++;
2610                        if ($lookCount % 1000 == 0) {
2611                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2612                        }
2613                        # Fix the group.
2614                        chown -1, $gid, $thisMem;
2615                        # Insure this member is not a symlink.
2616                        if (! -l $thisMem) {
2617                            # Get its info.
2618                            my $fileInfo = stat $thisMem;
2619                            # Only proceed if we got the info. Otherwise, it's a hard link
2620                            # and we want to skip it anyway.
2621                            if ($fileInfo) {
2622                                my $fileMode = $fileInfo->mode;
2623                                if (($fileMode & $mask) != $mask) {
2624                                    # Fix this member.
2625                                    $fileMode |= $mask;
2626                                    chmod $fileMode, $thisMem;
2627                                    $fixCount++;
2628                                }
2629                                # If it's a subdirectory, stack it.
2630                                if (-d $thisMem) {
2631                                    push @dirs, $thisMem;
2632                                }
2633                            }
2634                        }
2635                    }
2636                }
2637            }
2638            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2639        };
2640        # Check for an error.
2641        if ($@) {
2642            Confess("SetPermissions error: $@");
2643        }
2644    }
2645    
2646    =head3 CompareLists
2647    
2648    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2649    
2650    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2651    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2652    The return value contains a list of items that are only in the new list
2653    (inserted) and only in the old list (deleted).
2654    
2655    =over 4
2656    
2657    =item newList
2658    
2659    Reference to a list of new tuples.
2660    
2661    =item oldList
2662    
2663    Reference to a list of old tuples.
2664    
2665    =item keyIndex (optional)
2666    
2667    Index into each tuple of its key field. The default is 0.
2668    
2669    =item RETURN
2670    
2671    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2672    list (inserted) followed by a reference to the list of items that are only in the old
2673    list (deleted).
2674    
2675    =back
2676    
2677    =cut
2678    
2679    sub CompareLists {
2680        # Get the parameters.
2681        my ($newList, $oldList, $keyIndex) = @_;
2682        if (! defined $keyIndex) {
2683            $keyIndex = 0;
2684        }
2685        # Declare the return variables.
2686        my ($inserted, $deleted) = ([], []);
2687        # Loop through the two lists simultaneously.
2688        my ($newI, $oldI) = (0, 0);
2689        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2690        while ($newI < $newN || $oldI < $oldN) {
2691            # Get the current object in each list. Note that if one
2692            # of the lists is past the end, we'll get undef.
2693            my $newItem = $newList->[$newI];
2694            my $oldItem = $oldList->[$oldI];
2695            if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2696                # The old item is not in the new list, so mark it deleted.
2697                push @{$deleted}, $oldItem;
2698                $oldI++;
2699            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2700                # The new item is not in the old list, so mark it inserted.
2701                push @{$inserted}, $newItem;
2702                $newI++;
2703            } else {
2704                # The item is in both lists, so push forward.
2705                $oldI++;
2706                $newI++;
2707            }
2708        }
2709        # Return the result.
2710        return ($inserted, $deleted);
2711    }
2712    
2713    =head3 GetLine
2714    
2715    C<< my @data = Tracer::GetLine($handle); >>
2716    
2717    Read a line of data from a tab-delimited file.
2718    
2719    =over 4
2720    
2721    =item handle
2722    
2723    Open file handle from which to read.
2724    
2725    =item RETURN
2726    
2727    Returns a list of the fields in the record read. The fields are presumed to be
2728    tab-delimited. If we are at the end of the file, then an empty list will be
2729    returned. If an empty line is read, a single list item consisting of a null
2730    string will be returned.
2731    
2732    =back
2733    
2734    =cut
2735    
2736    sub GetLine {
2737        # Get the parameters.
2738        my ($handle) = @_;
2739        # Declare the return variable.
2740        my @retVal = ();
2741        # Read from the file.
2742        my $line = <$handle>;
2743        # Only proceed if we found something.
2744        if (defined $line) {
2745            # Remove the new-line.
2746            chomp $line;
2747            # If the line is empty, return a single empty string; otherwise, parse
2748            # it into fields.
2749            if ($line eq "") {
2750                push @retVal, "";
2751            } else {
2752                push @retVal, split /\t/,$line;
2753            }
2754        }
2755        # Return the result.
2756        return @retVal;
2757    }
2758    
2759    =head3 PutLine
2760    
2761    C<< Tracer::PutLine($handle, \@fields); >>
2762    
2763    Write a line of data to a tab-delimited file. The specified field values will be
2764    output in tab-separated form, with a trailing new-line.
2765    
2766    =over 4
2767    
2768    =item handle
2769    
2770    Output file handle.
2771    
2772    =item fields
2773    
2774    List of field values.
2775    
2776    =back
2777    
2778    =cut
2779    
2780    sub PutLine {
2781        # Get the parameters.
2782        my ($handle, $fields) = @_;
2783        # Write the data.
2784        print $handle join("\t", @{$fields}) . "\n";
2785    }
2786    
2787    =head3 GenerateURL
2788    
2789    C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >>
2790    
2791    Generate a GET-style URL for the specified page with the specified parameter
2792    names and values. The values will be URL-escaped automatically. So, for
2793    example
2794    
2795        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
2796    
2797    would return
2798    
2799        form.cgi?type=1&string=%22high%20pass%22%20or%20highway
2800    
2801    =over 4
2802    
2803    =item page
2804    
2805    Page URL.
2806    
2807    =item parameters
2808    
2809    Hash mapping parameter names to parameter values.
2810    
2811    =item RETURN
2812    
2813    Returns a GET-style URL that goes to the specified page and passes in the
2814    specified parameters and values.
2815    
2816    =back
2817    
2818    =cut
2819    
2820    sub GenerateURL {
2821        # Get the parameters.
2822        my ($page, %parameters) = @_;
2823        # Prime the return variable with the page URL.
2824        my $retVal = $page;
2825        # Loop through the parameters, creating parameter elements in a list.
2826        my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
2827        # If the list is nonempty, tack it on.
2828        if (@parmList) {
2829            $retVal .= "?" . join("&", @parmList);
2830        }
2831        # Return the result.
2832        return $retVal;
2833  }  }
2834    
2835  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3