[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.23, Tue Sep 13 05:36:12 2005 UTC revision 1.66, Tue Sep 26 13:37:07 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 Open OpenDir TICK);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup ScriptSetup ScriptFinish Insure ChDir);
23      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
24      use strict;      use strict;
25      use Carp qw(longmess croak);      use Carp qw(longmess croak);
26      use CGI;      use CGI;
27        use Cwd;
28      use FIG_Config;      use FIG_Config;
29      use PageBuilder;      use PageBuilder;
30      use Digest::MD5;      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 72  Line 96 
96    
97  =over 4  =over 4
98    
99  =item 0 Error  =item Error 0
100    
101  Message indicates an error that may lead to incorrect results or that has stopped the  Message indicates an error that may lead to incorrect results or that has stopped the
102  application entirely.  application entirely.
103    
104  =item 1 Warning  =item Warning 1
105    
106  Message indicates something that is unexpected but that probably did not interfere  Message indicates something that is unexpected but that probably did not interfere
107  with program execution.  with program execution.
108    
109  =item 2 Notice  =item Notice 2
110    
111  Message indicates the beginning or end of a major task.  Message indicates the beginning or end of a major task.
112    
113  =item 3 Information  =item Information 3
114    
115  Message indicates a subtask. In the FIG system, a subtask generally relates to a single  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.  genome. This would be a big loop that is not expected to execute more than 500 times or so.
117    
118  =item 4 Detail  =item Detail 4
119    
120  Message indicates a low-level loop iteration.  Message indicates a low-level loop iteration.
121    
# Line 157  Line 181 
181      # Presume category-based tracing until we learn otherwise.      # Presume category-based tracing until we learn otherwise.
182      $AllTrace = 0;      $AllTrace = 0;
183      # Build the category hash. Note that if we find a "*", we turn on non-category      # Build the category hash. Note that if we find a "*", we turn on non-category
184      # tracing.      # tracing. We must also clear away any pre-existing data.
185        %Categories = ( main => 1 );
186      for my $category (@categoryData) {      for my $category (@categoryData) {
187          if ($category eq '*') {          if ($category eq '*') {
188              $AllTrace = 1;              $AllTrace = 1;
# Line 188  Line 213 
213      $SetupCount++;      $SetupCount++;
214  }  }
215    
216    =head3 StandardSetup
217    
218    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
219    
220    This method performs standard command-line parsing and tracing setup. The return
221    values are a hash of the command-line options and a list of the positional
222    parameters. Tracing is automatically set up and the command-line options are
223    validated.
224    
225    This is a complex method that does a lot of grunt work. The parameters can
226    be more easily understood, however, once they are examined individually.
227    
228    The I<categories> parameter is the most obtuse. It is a reference to a list of
229    special-purpose tracing categories. Most tracing categories are PERL package
230    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
231    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
232    
233        ["Sprout", "SproutLoad", "ERDB"]
234    
235    This would cause trace messages in the specified three packages to appear in
236    the output. There are threer special tracing categories that are automatically
237    handled by this method. In other words, if you used L</TSetup> you would need
238    to include these categories manually, but if you use this method they are turned
239    on automatically.
240    
241    =over 4
242    
243    =item FIG
244    
245    Turns on trace messages inside the B<FIG> package.
246    
247    =item SQL
248    
249    Traces SQL commands and activity.
250    
251    =item Tracer
252    
253    Traces error messages and call stacks.
254    
255    =back
256    
257    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
258    The trace level is specified using the C<-trace> command-line option. For example,
259    the following command line for C<TransactFeatures> turns on SQL tracing and runs
260    all tracing at level 3.
261    
262        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
263    
264    Standard tracing is output to the standard output and echoed to the file
265    C<trace>I<$$>C<.log> in the FIG temporary directory, where I<$$> is the
266    process ID. You can also specify the C<user> parameter to put a user ID
267    instead of a process ID in the trace file name. So, for example
268    
269    The default trace level is 2. To get all messages, specify a trace level of 4.
270    For a genome-by-genome update, use 3.
271    
272        TransactFeatures -trace=3 -sql -user=Bruce register ../xacts IDs.tbl
273    
274    would send the trace output to C<traceBruce.log> in the temporary directory.
275    
276    The I<options> parameter is a reference to a hash containing the command-line
277    options, their default values, and an explanation of what they mean. Command-line
278    options may be in the form of switches or keywords. In the case of a switch, the
279    option value is 1 if it is specified and 0 if it is not specified. In the case
280    of a keyword, the value is separated from the option name by an equal sign. You
281    can see this last in the command-line example above.
282    
283    You can specify a different default trace level by setting C<$options->{trace}>
284    prior to calling this method.
285    
286    An example at this point would help. Consider, for example, the command-line utility
287    C<TransactFeatures>. It accepts a list of positional parameters plus the options
288    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
289    the following code.
290    
291        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
292                            { safe => [0, "use database transactions"],
293                              noAlias => [0, "do not expect aliases in CHANGE transactions"],
294                              start => [' ', "start with this genome"],
295                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
296                            "command transactionDirectory IDfile",
297                          @ARGV);
298    
299    
300    The call to C<ParseCommand> specifies the default values for the options and
301    stores the actual options in a hash that is returned as C<$options>. The
302    positional parameters are returned in C<@parameters>.
303    
304    The following is a sample command line for C<TransactFeatures>.
305    
306        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
307    
308    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
309    parameters, and would find themselves in I<@parameters> after executing the
310    above code fragment. The tracing would be set to level 2, and the categories
311    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
312    and C<DocUtils> was included because it came in within the first parameter
313    to this method. The I<$options> hash would be
314    
315        { trace => 2, sql => 0, safe => 0,
316          noAlias => 1, start => ' ', tblFiles => 0 }
317    
318    Use of C<StandardSetup> in this way provides a simple way of performing
319    standard tracing setup and command-line parsing. Note that the caller is
320    not even aware of the command-line switches C<-trace> and C<-sql>, which
321    are used by this method to control the tracing. If additional tracing features
322    need to be added in the future, they can be processed by this method without
323    upsetting the command-line utilities.
324    
325    If the C<background> option is specified on the command line, then the
326    standard and error outputs will be directed to files in the temporary
327    directory, using the same suffix as the trace file. So, if the command
328    line specified
329    
330        -user=Bruce -background
331    
332    then the trace output would go to C<traceBruce.log>, the standard output to
333    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
334    simplify starting a command in the background.
335    
336    Finally, if the special option C<-h> is specified, the option names will
337    be traced at level 0 and the program will exit without processing.
338    This provides a limited help capability. For example, if the user enters
339    
340        TransactFeatures -h
341    
342    he would see the following output.
343    
344        TransactFeatures [options] command transactionDirectory IDfile
345            -trace    tracing level (default 2)
346            -sql      trace SQL commands
347            -safe     use database transactions
348            -noAlias  do not expect aliases in CHANGE transactions
349            -start    start with this genome
350            -tblFiles output TBL files containing the corrected IDs
351    
352    The caller has the option of modifying the tracing scheme by placing a value
353    for C<trace> in the incoming options hash. The default value can be overridden,
354    or the tracing to the standard output can be turned off by suffixing a minus
355    sign to the trace level. So, for example,
356    
357        { trace => [0, "tracing level (default 0)"],
358           ...
359    
360    would set the default trace level to 0 instead of 2, while
361    
362        { trace => ["2-", "tracing level (default 2)"],
363           ...
364    
365    would leave the default at 2, but trace only to the log file, not to the
366    standard output.
367    
368    The parameters to this method are as follows.
369    
370    =over 4
371    
372    =item categories
373    
374    Reference to a list of tracing category names. These should be names of
375    packages whose internal workings will need to be debugged to get the
376    command working.
377    
378    =item options
379    
380    Reference to a hash containing the legal options for the current command mapped
381    to their default values and descriptions. The user can override the defaults
382    by specifying the options as command-line switches prefixed by a hyphen.
383    Tracing-related options may be added to this hash. If the C<-h> option is
384    specified on the command line, the option descriptions will be used to
385    explain the options. To turn off tracing to the standard output, add a
386    minus sign to the value for C<trace> (see above).
387    
388    =item parmHelp
389    
390    A string that vaguely describes the positional parameters. This is used
391    if the user specifies the C<-h> option.
392    
393    =item argv
394    
395    List of command line parameters, including the option switches, which must
396    precede the positional parameters and be prefixed by a hyphen.
397    
398    =item RETURN
399    
400    Returns a list. The first element of the list is the reference to a hash that
401    maps the command-line option switches to their values. These will either be the
402    default values or overrides specified on the command line. The remaining
403    elements of the list are the position parameters, in order.
404    
405    =back
406    
407    =cut
408    
409    sub StandardSetup {
410        # Get the parameters.
411        my ($categories, $options, $parmHelp, @argv) = @_;
412        # Add the tracing options.
413        if (! exists $options->{trace}) {
414            $options->{trace} = [2, "tracing level"];
415        }
416        $options->{sql} = [0, "turn on SQL tracing"];
417        $options->{h} = [0, "display command-line options"];
418        $options->{user} = [$$, "trace log file name suffix"];
419        $options->{background} = [0, "spool standard and error output"];
420        # Create a parsing hash from the options hash. The parsing hash
421        # contains the default values rather than the default value
422        # and the description. While we're at it, we'll memorize the
423        # length of the longest option name.
424        my $longestName = 0;
425        my %parseOptions = ();
426        for my $key (keys %{$options}) {
427            if (length $key > $longestName) {
428                $longestName = length $key;
429            }
430            $parseOptions{$key} = $options->{$key}->[0];
431        }
432        # Parse the command line.
433        my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
434        # Get the logfile suffix.
435        my $suffix = $retOptions->{user};
436        # Check for background mode.
437        if ($retOptions->{background}) {
438            my $outFileName = "$FIG_Config::temp/out$suffix.log";
439            my $errFileName = "$FIG_Config::temp/err$suffix.log";
440            open STDOUT, ">$outFileName";
441            open STDERR, ">$errFileName";
442        }
443        # Now we want to set up tracing. First, we need to know if SQL is to
444        # be traced.
445        my @cats = @{$categories};
446        if ($retOptions->{sql}) {
447            push @cats, "SQL";
448        }
449        # Add the default categories.
450        push @cats, "Tracer", "FIG";
451        # Next, we create the category string by joining the categories.
452        my $cats = join(" ", @cats);
453        # Check to determine whether or not the caller wants to turn off tracing
454        # to the standard output.
455        my $traceLevel = $retOptions->{trace};
456        my $textOKFlag = 1;
457        if ($traceLevel =~ /^(.)-/) {
458            $traceLevel = $1;
459            $textOKFlag = 0;
460        }
461        # Now we set up the trace mode.
462        my $traceMode;
463        # Verify that we can open a file in the FIG temporary directory.
464        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
465        if (open TESTTRACE, ">$traceFileName") {
466            # Here we can trace to a file.
467            $traceMode = ">$traceFileName";
468            if ($textOKFlag) {
469                # Echo to standard output if the text-OK flag is set.
470                $traceMode = "+$traceMode";
471            }
472            # Close the test file.
473            close TESTTRACE;
474        } else {
475            # Here we can't trace to a file. We trace to the standard output if it's
476            # okay, and the error log otherwise.
477            if ($textOKFlag) {
478                $traceMode = "TEXT";
479            } else {
480                $traceMode = "WARN";
481            }
482        }
483        # Now set up the tracing.
484        TSetup("$traceLevel $cats", $traceMode);
485        # Check for the "h" option. If it is specified, dump the command-line
486        # options and exit the program.
487        if ($retOptions->{h}) {
488            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
489            Trace("$1 [options] $parmHelp") if T(0);
490            for my $key (sort keys %{$options}) {
491                my $name = Pad($key, $longestName, 0, ' ');
492                my $desc = $options->{$key}->[1];
493                if ($options->{$key}->[0]) {
494                    $desc .= " (default " . $options->{$key}->[0] . ")";
495                }
496                Trace("  $name $desc") if T(0);
497            }
498            exit(0);
499        }
500        # Return the parsed parameters.
501        return ($retOptions, @retParameters);
502    }
503    
504  =head3 Setups  =head3 Setups
505    
506  C<< my $count = Tracer::Setups(); >>  C<< my $count = Tracer::Setups(); >>
# Line 348  Line 661 
661    
662  =head3 OpenDir  =head3 OpenDir
663    
664  C<< my @files = OpenDir($dirName, $filtered); >>  C<< my @files = OpenDir($dirName, $filtered, $flag); >>
665    
666  Open a directory and return all the file names. This function essentially performs  Open a directory and return all the file names. This function essentially performs
667  the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is  the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
668  set to TRUE, all filenames beginning with a period (C<.>) will be filtered out of  set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
669  the return list. If the directory does not open, an exception is thrown. So,  or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
670  for example,  filtered out of the return list. If the directory does not open and I<$flag> is not
671    set, an exception is thrown. So, for example,
672    
673      my @files = OpenDir("/Volumes/fig/contigs", 1);      my @files = OpenDir("/Volumes/fig/contigs", 1);
674    
675  is effectively the same as  is effectively the same as
676    
677      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
678      my @files = grep { $_ !~ /^\./ } readdir(TMP);      my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
679    
680  Similarly, the following code  Similarly, the following code
681    
682      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs");      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
683    
684  Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and  Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
685  automatically throws an error if the directory fails to open.  automatically returns an empty list if the directory fails to open.
686    
687  =over 4  =over 4
688    
# Line 381  Line 695 
695  TRUE if files whose names begin with a period (C<.>) should be automatically removed  TRUE if files whose names begin with a period (C<.>) should be automatically removed
696  from the list, else FALSE.  from the list, else FALSE.
697    
698    =item flag
699    
700    TRUE if a failure to open is okay, else FALSE
701    
702  =back  =back
703    
704  =cut  =cut
705  #: Return Type @;  #: Return Type @;
706  sub OpenDir {  sub OpenDir {
707      # Get the parameters.      # Get the parameters.
708      my ($dirName, $filtered) = @_;      my ($dirName, $filtered, $flag) = @_;
709      # Declare the return variable.      # Declare the return variable.
710      my @retVal;      my @retVal = ();
711      # Open the directory.      # Open the directory.
712      if (opendir(my $dirHandle, $dirName)) {      if (opendir(my $dirHandle, $dirName)) {
713          # The directory opened successfully. Get the appropriate list according to the          # The directory opened successfully. Get the appropriate list according to the
714          # strictures of the filter parameter.          # strictures of the filter parameter.
715          if ($filtered) {          if ($filtered) {
716              @retVal = grep { $_ !~ /^\./ } readdir $dirHandle;              @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
717          } else {          } else {
718              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
719          }          }
720      } else {      } elsif (! $flag) {
721          # Here the directory would not open.          # Here the directory would not open and it's considered an error.
722          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
723      }      }
724      # Return the result.      # Return the result.
# Line 738  Line 1056 
1056          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
1057          $category = lc $category;          $category = lc $category;
1058          # Use the category and tracelevel to compute the result.          # Use the category and tracelevel to compute the result.
1059            if (ref $traceLevel) {
1060                Confess("Bad trace level.");
1061            } elsif (ref $TraceLevel) {
1062                Confess("Bad trace config.");
1063            }
1064          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
1065      }      }
1066      # Return the computed result.      # Return the computed result.
# Line 824  Line 1147 
1147    
1148  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1149    
1150  Escape a string for use in a command length. Spaces will be replaced by C<\b>,  Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1151  tabs replaced by C<\t>, new-lines replaced by C<\n>, and backslashes will be  replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1152  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1153    
1154  =over 4  =over 4
1155    
# Line 850  Line 1173 
1173      # Loop through the parameter string, looking for sequences to escape.      # Loop through the parameter string, looking for sequences to escape.
1174      while (length $realString > 0) {      while (length $realString > 0) {
1175          # Look for the first sequence to escape.          # Look for the first sequence to escape.
1176          if ($realString =~ /^(.*?)([ \n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1177              # Here we found it. The text preceding the sequence is in $1. The sequence              # Here we found it. The text preceding the sequence is in $1. The sequence
1178              # itself is in $2. First, move the clear text to the return variable.              # itself is in $2. First, move the clear text to the return variable.
1179              $retVal .= $1;              $retVal .= $1;
1180              # Strip the processed section off the real string.              # Strip the processed section off the real string.
1181              $realString = substr $realString, (length $2) + (length $1);              $realString = substr $realString, (length $2) + (length $1);
1182              # Encode the escape sequence.              # Get the matched character.
1183              my $char = $2;              my $char = $2;
1184              $char =~ tr/ \t\n/btn/;              # If we have a CR, we are done.
1185                if ($char ne "\r") {
1186                    # It's not a CR, so encode the escape sequence.
1187                    $char =~ tr/\t\n/tn/;
1188              $retVal .= "\\" . $char;              $retVal .= "\\" . $char;
1189                }
1190          } else {          } else {
1191              # Here there are no more escape sequences. The rest of the string is              # Here there are no more escape sequences. The rest of the string is
1192              # transferred unmodified.              # transferred unmodified.
# Line 875  Line 1202 
1202    
1203  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1204    
1205  Replace escape sequences with their actual equivalents. C<\b> will be replaced by a space,  Replace escape sequences with their actual equivalents. C<\t> will be replaced by
1206  C<\t> by a tab, C<\n> by a new-line character, and C<\\> by a back-slash.  a tab, C<\n> by a new-line character, and C<\\> by a backslash. C<\r> codes will
1207    be deleted.
1208    
1209  =over 4  =over 4
1210    
# Line 896  Line 1224 
1224  sub UnEscape {  sub UnEscape {
1225      # Get the parameter.      # Get the parameter.
1226      my ($codedString) = @_;      my ($codedString) = @_;
     Tracer("Coded string is \"$codedString\".") if T(4);  
1227      # Initialize the return variable.      # Initialize the return variable.
1228      my $retVal = "";      my $retVal = "";
1229      # Only proceed if the incoming string is nonempty.      # Only proceed if the incoming string is nonempty.
1230      if (defined $codedString) {      if (defined $codedString) {
1231          # Loop through the parameter string, looking for escape sequences. We can't do          # Loop through the parameter string, looking for escape sequences. We can't do
1232          # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1233          # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1234          while (length $codedString > 0) {          while (length $codedString > 0) {
1235              # Look for the first escape sequence.              # Look for the first escape sequence.
1236              if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1237                  # Here we found it. The text preceding the sequence is in $1. The sequence                  # Here we found it. The text preceding the sequence is in $1. The sequence
1238                  # itself is in $2. First, move the clear text to the return variable.                  # itself is in $2. First, move the clear text to the return variable.
1239                  $retVal .= $1;                  $retVal .= $1;
1240                  $codedString = substr $codedString, (2 + length $1);                  $codedString = substr $codedString, (2 + length $1);
1241                  # Decode the escape sequence.                  # Get the escape value.
1242                  my $char = $2;                  my $char = $2;
1243                  $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1244                    if ($char ne 'r') {
1245                        # Here it's not an 'r', so we convert it.
1246                        $char =~ tr/\\tn/\\\t\n/;
1247                  $retVal .= $char;                  $retVal .= $char;
1248                    }
1249              } else {              } else {
1250                  # Here there are no more escape sequences. The rest of the string is                  # Here there are no more escape sequences. The rest of the string is
1251                  # transferred unmodified.                  # transferred unmodified.
# Line 1020  Line 1351 
1351      return @inputList;      return @inputList;
1352  }  }
1353    
1354    =head3 Percent
1355    
1356    C<< my $percent = Tracer::Percent($number, $base); >>
1357    
1358    Returns the percent of the base represented by the given number. If the base
1359    is zero, returns zero.
1360    
1361    =over 4
1362    
1363    =item number
1364    
1365    Percent numerator.
1366    
1367    =item base
1368    
1369    Percent base.
1370    
1371    =item RETURN
1372    
1373    Returns the percentage of the base represented by the numerator.
1374    
1375    =back
1376    
1377    =cut
1378    
1379    sub Percent {
1380        # Get the parameters.
1381        my ($number, $base) = @_;
1382        # Declare the return variable.
1383        my $retVal = 0;
1384        # Compute the percent.
1385        if ($base != 0) {
1386            $retVal = $number * 100 / $base;
1387        }
1388        # Return the result.
1389        return $retVal;
1390    }
1391    
1392  =head3 GetFile  =head3 GetFile
1393    
1394  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1395    
1396  Return the entire contents of a file.      or
1397    
1398    C<< my $fileContents = Tracer::GetFile($fileName); >>
1399    
1400    Return the entire contents of a file. In list context, line-ends are removed and
1401    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1402    
1403  =over 4  =over 4
1404    
# Line 1035  Line 1409 
1409  =item RETURN  =item RETURN
1410    
1411  In a list context, returns the entire file as a list with the line terminators removed.  In a list context, returns the entire file as a list with the line terminators removed.
1412  In a scalar context, returns the entire file as a string.  In a scalar context, returns the entire file as a string. If an error occurs opening
1413    the file, an empty list will be returned.
1414    
1415  =back  =back
1416    
# Line 1047  Line 1422 
1422      # Declare the return variable.      # Declare the return variable.
1423      my @retVal = ();      my @retVal = ();
1424      # Open the file for input.      # Open the file for input.
1425      my $ok = open INPUTFILE, "<$fileName";      my $handle = Open(undef, "<$fileName");
     if (!$ok) {  
         # If we had an error, trace it. We will automatically return a null value.  
         Trace("Could not open \"$fileName\" for input: $!") if T(0);  
     } else {  
1426          # Read the whole file into the return variable, stripping off any terminator          # Read the whole file into the return variable, stripping off any terminator
1427          # characters.          # characters.
1428          my $lineCount = 0;          my $lineCount = 0;
1429          while (my $line = <INPUTFILE>) {      while (my $line = <$handle>) {
1430              $lineCount++;              $lineCount++;
1431              $line = Strip($line);              $line = Strip($line);
1432              push @retVal, $line;              push @retVal, $line;
1433          }          }
1434          # Close it.          # Close it.
1435          close INPUTFILE;      close $handle;
1436          my $actualLines = @retVal;          my $actualLines = @retVal;
     }  
1437      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1438      if (wantarray) {      if (wantarray) {
1439          return @retVal;          return @retVal;
# Line 1072  Line 1442 
1442      }      }
1443  }  }
1444    
1445    =head3 PutFile
1446    
1447    C<< Tracer::PutFile($fileName, \@lines); >>
1448    
1449    Write out a file from a list of lines of text.
1450    
1451    =over 4
1452    
1453    =item fileName
1454    
1455    Name of the output file.
1456    
1457    =item lines
1458    
1459    Reference to a list of text lines. The lines will be written to the file in order, with trailing
1460    new-line characters. Alternatively, may be a string, in which case the string will be written without
1461    modification.
1462    
1463    =back
1464    
1465    =cut
1466    
1467    sub PutFile {
1468        # Get the parameters.
1469        my ($fileName, $lines) = @_;
1470        # Open the output file.
1471        my $handle = Open(undef, ">$fileName");
1472        if (ref $lines ne 'ARRAY') {
1473            # Here we have a scalar, so we write it raw.
1474            print $handle $lines;
1475        } else {
1476            # Write the lines one at a time.
1477            for my $line (@{$lines}) {
1478                print $handle "$line\n";
1479            }
1480        }
1481        # Close the output file.
1482        close $handle;
1483    }
1484    
1485  =head3 QTrace  =head3 QTrace
1486    
1487  C<< my $data = QTrace($format); >>  C<< my $data = QTrace($format); >>
# Line 1151  Line 1561 
1561  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1562    
1563  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
1564  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.
1565  So, for example  So, for example
1566    
1567  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1272  Line 1682 
1682    
1683  =head3 AddToListMap  =head3 AddToListMap
1684    
1685  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1686    
1687  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
1688  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 1287  Line 1697 
1697    
1698  Key for which the value is to be added.  Key for which the value is to be added.
1699    
1700  =item value  =item value1, value2, ... valueN
1701    
1702  Value to add to the key's value list.  List of values to add to the key's value list.
1703    
1704  =back  =back
1705    
# Line 1297  Line 1707 
1707    
1708  sub AddToListMap {  sub AddToListMap {
1709      # Get the parameters.      # Get the parameters.
1710      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1711      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1712      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1713          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1714      } else {      } else {
1715          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1716      }      }
1717  }  }
1718    
# Line 1332  Line 1742 
1742          $retVal = 1;          $retVal = 1;
1743      } else {      } else {
1744          # Here debug mode is off, so we generate an error page.          # Here debug mode is off, so we generate an error page.
1745          my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");          my $pageString = PageBuilder::Build("<<Html/ErrorPage.html", {}, "Html");
1746          print $pageString;          print $pageString;
1747      }      }
1748      # Return the determination indicator.      # Return the determination indicator.
# Line 1364  Line 1774 
1774  sub Strip {  sub Strip {
1775      # Get a copy of the parameter string.      # Get a copy of the parameter string.
1776      my ($string) = @_;      my ($string) = @_;
1777      my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1778      # Strip the line terminator characters.      # Strip the line terminator characters.
1779      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1780      # Return the result.      # Return the result.
# Line 1432  Line 1842 
1842      return $retVal;      return $retVal;
1843  }  }
1844    
1845    =head3 EOF
1846    
1847    This is a constant that is lexically greater than any useful string.
1848    
1849    =cut
1850    
1851    sub EOF {
1852        return "\xFF\xFF\xFF\xFF\xFF";
1853    }
1854    
1855  =head3 TICK  =head3 TICK
1856    
1857  C<< my @results = TICK($commandString); >>  C<< my @results = TICK($commandString); >>
# Line 1473  Line 1893 
1893      return `$commandString`;      return `$commandString`;
1894  }  }
1895    
1896    =head3 ScriptSetup
1897    
1898    C<< my ($query, $varHash) = ScriptSetup(); >>
1899    
1900    Perform standard tracing and debugging setup for scripts. The value returned is
1901    the CGI object followed by a pre-built variable hash.
1902    
1903    The C<Trace> query parameter is used to determine whether or not tracing is active and
1904    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1905    the C<CGI> trace module will trace parameter and environment information. Parameters are
1906    traced at level 3 and environment variables at level 4. At the end of the script, the
1907    client should call L</ScriptFinish> to output the web page.
1908    
1909    =cut
1910    
1911    sub ScriptSetup {
1912        # Get the CGI query object.
1913        my $query = CGI->new();
1914        # Check for tracing. Set it up if the user asked for it.
1915        if ($query->param('Trace')) {
1916            # Set up tracing.
1917            my $ttype = ($query->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1918            TSetup($query->param('Trace') . " FIG Tracer", $ttype);
1919            # Trace the parameter and environment data.
1920            TraceParms($query);
1921        } else {
1922            # Here tracing is to be turned off. All we allow is errors traced into the
1923            # error log.
1924            TSetup("0", "WARN");
1925        }
1926        # Create the variable hash.
1927        my $varHash = { DebugData => '' };
1928        # Return the query object and variable hash.
1929        return ($query, $varHash);
1930    }
1931    
1932    =head3 TraceParms
1933    
1934    C<< Tracer::TraceParms($query); >>
1935    
1936    Trace the CGI parameters at trace level CGI => 3 and the environment variables
1937    at level CGI => 4.
1938    
1939    =over 4
1940    
1941    =item query
1942    
1943    CGI query object containing the parameters to trace.
1944    
1945    =back
1946    
1947    =cut
1948    
1949    sub TraceParms {
1950        # Get the parameters.
1951        my ($query) = @_;
1952        if (T(CGI => 3)) {
1953            # Here we want to trace the parameter data.
1954            my @names = $query->param;
1955            for my $parmName (sort @names) {
1956                # Note we skip "Trace", which is for our use only.
1957                if ($parmName ne 'Trace') {
1958                    my @values = $query->param($parmName);
1959                    Trace("CGI: $parmName = " . join(", ", @values));
1960                }
1961            }
1962        }
1963        if (T(CGI => 4)) {
1964            # Here we want the environment data too.
1965            for my $envName (sort keys %ENV) {
1966                Trace("ENV: $envName = $ENV{$envName}");
1967            }
1968        }
1969    }
1970    
1971    =head3 ScriptFinish
1972    
1973    C<< ScriptFinish($webData, $varHash); >>
1974    
1975    Output a web page at the end of a script. Either the string to be output or the
1976    name of a template file can be specified. If the second parameter is omitted,
1977    it is assumed we have a string to be output; otherwise, it is assumed we have the
1978    name of a template file. The template should have the variable C<DebugData>
1979    specified in any form that invokes a standard script. If debugging mode is turned
1980    on, a form field will be put in that allows the user to enter tracing data.
1981    Trace messages will be placed immediately before the terminal C<BODY> tag in
1982    the output, formatted as a list.
1983    
1984    A typical standard script would loook like the following.
1985    
1986        BEGIN {
1987            # Print the HTML header.
1988            print "CONTENT-TYPE: text/html\n\n";
1989        }
1990        use Tracer;
1991        use CGI;
1992        use FIG;
1993        # ... more uses ...
1994    
1995        my ($query, $varHash) = ScriptSetup();
1996        eval {
1997            # ... get data from $query, put it in $varHash ...
1998        };
1999        if ($@) {
2000            Trace("Script Error: $@") if T(0);
2001        }
2002        ScriptFinish("Html/MyTemplate.html", $varHash);
2003    
2004    The idea here is that even if the script fails, you'll see trace messages and
2005    useful output.
2006    
2007    =over 4
2008    
2009    =item webData
2010    
2011    A string containing either the full web page to be written to the output or the
2012    name of a template file from which the page is to be constructed. If the name
2013    of a template file is specified, then the second parameter must be present;
2014    otherwise, it must be absent.
2015    
2016    =item varHash (optional)
2017    
2018    If specified, then a reference to a hash mapping variable names for a template
2019    to their values. The template file will be read into memory, and variable markers
2020    will be replaced by data in this hash reference.
2021    
2022    =back
2023    
2024    =cut
2025    
2026    sub ScriptFinish {
2027        # Get the parameters.
2028        my ($webData, $varHash) = @_;
2029        # Check for a template file situation.
2030        my $outputString;
2031        if (defined $varHash) {
2032            # Here we have a template file. We need to determine the template type.
2033            my $template;
2034            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
2035                $template = "$FIG_Config::template_url/$webData";
2036            } else {
2037                $template = "<<$webData";
2038            }
2039            $outputString = PageBuilder::Build($template, $varHash, "Html");
2040        } else {
2041            # Here the user gave us a raw string.
2042            $outputString = $webData;
2043        }
2044        # Check for trace messages.
2045        if ($Destination eq "QUEUE") {
2046            # We have trace messages, so we want to put them at the end of the body. This
2047            # is either at the end of the whole string or at the beginning of the BODY
2048            # end-tag.
2049            my $pos = length $outputString;
2050            if ($outputString =~ m#</body>#gi) {
2051                $pos = (pos $outputString) - 7;
2052            }
2053            substr $outputString, $pos, 0, QTrace('Html');
2054        }
2055        # Write the output string.
2056        print $outputString;
2057    }
2058    
2059    =head3 Insure
2060    
2061    C<< Insure($dirName); >>
2062    
2063    Insure a directory is present.
2064    
2065    =over 4
2066    
2067    =item dirName
2068    
2069    Name of the directory to check. If it does not exist, it will be created.
2070    
2071    =back
2072    
2073    =cut
2074    
2075    sub Insure {
2076        my ($dirName) = @_;
2077        if (! -d $dirName) {
2078            Trace("Creating $dirName directory.") if T(2);
2079            eval { mkpath $dirName; };
2080            if ($@) {
2081                Confess("Error creating $dirName: $@");
2082            }
2083        }
2084    }
2085    
2086    =head3 ChDir
2087    
2088    C<< ChDir($dirName); >>
2089    
2090    Change to the specified directory.
2091    
2092    =over 4
2093    
2094    =item dirName
2095    
2096    Name of the directory to which we want to change.
2097    
2098    =back
2099    
2100    =cut
2101    
2102    sub ChDir {
2103        my ($dirName) = @_;
2104        if (! -d $dirName) {
2105            Confess("Cannot change to directory $dirName: no such directory.");
2106        } else {
2107            Trace("Changing to directory $dirName.") if T(4);
2108            my $okFlag = chdir $dirName;
2109            if (! $okFlag) {
2110                Confess("Error switching to directory $dirName.");
2111            }
2112        }
2113    }
2114    
2115    =head3 SendSMS
2116    
2117    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2118    
2119    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2120    user name, password, and API ID for the relevant account in the hash reference variable
2121    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2122    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2123    is C<2561022>, then the FIG_Config file must contain
2124    
2125        $phone =  { user => 'BruceTheHumanPet',
2126                    password => 'silly',
2127                    api_id => '2561022' };
2128    
2129    The original purpose of this method was to insure Bruce would be notified immediately when the
2130    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2131    when you call this method.
2132    
2133    The message ID will be returned if successful, and C<undef> if an error occurs.
2134    
2135    =over 4
2136    
2137    =item phoneNumber
2138    
2139    Phone number to receive the message, in international format. A United States phone number
2140    would be prefixed by "1". A British phone number would be prefixed by "44".
2141    
2142    =item msg
2143    
2144    Message to send to the specified phone.
2145    
2146    =item RETURN
2147    
2148    Returns the message ID if successful, and C<undef> if the message could not be sent.
2149    
2150    =back
2151    
2152    =cut
2153    
2154    sub SendSMS {
2155        # Get the parameters.
2156        my ($phoneNumber, $msg) = @_;
2157        # Declare the return variable. If we do not change it, C<undef> will be returned.
2158        my $retVal;
2159        # Only proceed if we have phone support.
2160        if (! defined $FIG_Config::phone) {
2161            Trace("Phone support not present in FIG_Config.") if T(1);
2162        } else {
2163            # Get the phone data.
2164            my $parms = $FIG_Config::phone;
2165            # Get the Clickatell URL.
2166            my $url = "http://api.clickatell.com/http/";
2167            # Create the user agent.
2168            my $ua = LWP::UserAgent->new;
2169            # Request a Clickatell session.
2170            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2171                                         password => $parms->{password},
2172                                         api_id => $parms->{api_id},
2173                                         to => $phoneNumber,
2174                                         text => $msg});
2175            # Check for an error.
2176            if (! $resp->is_success) {
2177                Trace("Alert failed.") if T(1);
2178            } else {
2179                # Get the message ID.
2180                my $rstring = $resp->content;
2181                if ($rstring =~ /^ID:\s+(.*)$/) {
2182                    $retVal = $1;
2183                } else {
2184                    Trace("Phone attempt failed with $rstring") if T(1);
2185                }
2186            }
2187        }
2188        # Return the result.
2189        return $retVal;
2190    }
2191    
2192    =head3 CommaFormat
2193    
2194    C<< my $formatted = Tracer::CommaFormat($number); >>
2195    
2196    Insert commas into a number.
2197    
2198    =over 4
2199    
2200    =item number
2201    
2202    A sequence of digits.
2203    
2204    =item RETURN
2205    
2206    Returns the same digits with commas strategically inserted.
2207    
2208    =back
2209    
2210    =cut
2211    
2212    sub CommaFormat {
2213        # Get the parameters.
2214        my ($number) = @_;
2215        # Pad the length up to a multiple of three.
2216        my $padded = "$number";
2217        $padded = " " . $padded while length($padded) % 3 != 0;
2218        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2219        # cause the delimiters to be included in the output stream. The
2220        # GREP removes the empty strings in between the delimiters.
2221        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2222        # Clean out the spaces.
2223        $retVal =~ s/ //g;
2224        # Return the result.
2225        return $retVal;
2226    }
2227    =head3 SetPermissions
2228    
2229    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2230    
2231    Set the permissions for a directory and all the files and folders inside it.
2232    In addition, the group ownership will be changed to the specified value.
2233    
2234    This method is more vulnerable than most to permission and compatability
2235    problems, so it does internal error recovery.
2236    
2237    =over 4
2238    
2239    =item dirName
2240    
2241    Name of the directory to process.
2242    
2243    =item group
2244    
2245    Name of the group to be assigned.
2246    
2247    =item mask
2248    
2249    Permission mask. Bits that are C<1> in this mask will be ORed into the
2250    permission bits of any file or directory that does not already have them
2251    set to 1.
2252    
2253    =item otherMasks
2254    
2255    Map of search patterns to permission masks. If a directory name matches
2256    one of the patterns, that directory and all its members and subdirectories
2257    will be assigned the new pattern. For example, the following would
2258    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2259    
2260        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2261    
2262    The list is ordered, so the following would use 0777 for C<tmp1> and
2263    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2264    
2265        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2266                                                       '^tmp' => 0666);
2267    
2268    Note that the pattern matches are all case-insensitive, and only directory
2269    names are matched, not file names.
2270    
2271    =back
2272    
2273    =cut
2274    
2275    sub SetPermissions {
2276        # Get the parameters.
2277        my ($dirName, $group, $mask, @otherMasks) = @_;
2278        # Set up for error recovery.
2279        eval {
2280            # Switch to the specified directory.
2281            ChDir($dirName);
2282            # Get the group ID.
2283            my $gid = getgrnam($group);
2284            # Get the mask for tracing.
2285            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2286            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2287            my $fixCount = 0;
2288            my $lookCount = 0;
2289            # @dirs will be a stack of directories to be processed.
2290            my @dirs = (getcwd());
2291            while (scalar(@dirs) > 0) {
2292                # Get the current directory.
2293                my $dir = pop @dirs;
2294                # Check for a match to one of the specified directory names. To do
2295                # that, we need to pull the individual part of the name off of the
2296                # whole path.
2297                my $simpleName = $dir;
2298                if ($dir =~ m!/([^/]+)$!) {
2299                    $simpleName = $1;
2300                }
2301                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2302                # Search for a match.
2303                my $match = 0;
2304                my $i;
2305                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2306                    my $pattern = $otherMasks[$i];
2307                    if ($simpleName =~ /$pattern/i) {
2308                        $match = 1;
2309                    }
2310                }
2311                # Check for a match. Note we use $i-1 because the loop added 2
2312                # before terminating due to the match.
2313                if ($match && $otherMasks[$i-1] != $mask) {
2314                    # This directory matches one of the incoming patterns, and it's
2315                    # a different mask, so we process it recursively with that mask.
2316                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2317                } else {
2318                    # Here we can process normally. Get all of the non-hidden members.
2319                    my @submems = OpenDir($dir, 1);
2320                    for my $submem (@submems) {
2321                        # Get the full name.
2322                        my $thisMem = "$dir/$submem";
2323                        Trace("Checking member $thisMem.") if T(4);
2324                        $lookCount++;
2325                        if ($lookCount % 1000 == 0) {
2326                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2327                        }
2328                        # Fix the group.
2329                        chown -1, $gid, $thisMem;
2330                        # Insure this member is not a symlink.
2331                        if (! -l $thisMem) {
2332                            # Get its info.
2333                            my $fileInfo = stat $thisMem;
2334                            # Only proceed if we got the info. Otherwise, it's a hard link
2335                            # and we want to skip it anyway.
2336                            if ($fileInfo) {
2337                                my $fileMode = $fileInfo->mode;
2338                                if (($fileMode & $mask) != $mask) {
2339                                    # Fix this member.
2340                                    $fileMode |= $mask;
2341                                    chmod $fileMode, $thisMem;
2342                                    $fixCount++;
2343                                }
2344                                # If it's a subdirectory, stack it.
2345                                if (-d $thisMem) {
2346                                    push @dirs, $thisMem;
2347                                }
2348                            }
2349                        }
2350                    }
2351                }
2352            }
2353            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2354        };
2355        # Check for an error.
2356        if ($@) {
2357            Confess("SetPermissions error: $@");
2358        }
2359    }
2360    
2361    =head3 CompareLists
2362    
2363    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2364    
2365    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2366    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2367    The return value contains a list of items that are only in the new list
2368    (inserted) and only in the old list (deleted).
2369    
2370    =over 4
2371    
2372    =item newList
2373    
2374    Reference to a list of new tuples.
2375    
2376    =item oldList
2377    
2378    Reference to a list of old tuples.
2379    
2380    =item keyIndex (optional)
2381    
2382    Index into each tuple of its key field. The default is 0.
2383    
2384    =item RETURN
2385    
2386    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2387    list (inserted) followed by a reference to the list of items that are only in the old
2388    list (deleted).
2389    
2390    =back
2391    
2392    =cut
2393    
2394    sub CompareLists {
2395        # Get the parameters.
2396        my ($newList, $oldList, $keyIndex) = @_;
2397        if (! defined $keyIndex) {
2398            $keyIndex = 0;
2399        }
2400        # Declare the return variables.
2401        my ($inserted, $deleted) = ([], []);
2402        # Loop through the two lists simultaneously.
2403        my ($newI, $oldI) = (0, 0);
2404        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2405        while ($newI < $newN || $oldI < $oldN) {
2406            # Get the current object in each list. Note that if one
2407            # of the lists is past the end, we'll get undef.
2408            my $newItem = $newList->[$newI];
2409            my $oldItem = $oldList->[$oldI];
2410            if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2411                # The old item is not in the new list, so mark it deleted.
2412                push @{$deleted}, $oldItem;
2413                $oldI++;
2414            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2415                # The new item is not in the old list, so mark it inserted.
2416                push @{$inserted}, $newItem;
2417                $newI++;
2418            } else {
2419                # The item is in both lists, so push forward.
2420                $oldI++;
2421                $newI++;
2422            }
2423        }
2424        # Return the result.
2425        return ($inserted, $deleted);
2426    }
2427    
2428    =head3 GetLine
2429    
2430    C<< my @data = Tracer::GetLine($handle); >>
2431    
2432    Read a line of data from a tab-delimited file.
2433    
2434    =over 4
2435    
2436    =item handle
2437    
2438    Open file handle from which to read.
2439    
2440    =item RETURN
2441    
2442    Returns a list of the fields in the record read. The fields are presumed to be
2443    tab-delimited. If we are at the end of the file, then an empty list will be
2444    returned. If an empty line is read, a single list item consisting of a null
2445    string will be returned.
2446    
2447    =back
2448    
2449    =cut
2450    
2451    sub GetLine {
2452        # Get the parameters.
2453        my ($handle) = @_;
2454        # Declare the return variable.
2455        my @retVal = ();
2456        # Read from the file.
2457        my $line = <$handle>;
2458        # Only proceed if we found something.
2459        if (defined $line) {
2460            # Remove the new-line.
2461            chomp $line;
2462            # If the line is empty, return a single empty string; otherwise, parse
2463            # it into fields.
2464            if ($line eq "") {
2465                push @retVal, "";
2466            } else {
2467                push @retVal, split /\t/,$line;
2468            }
2469        }
2470        # Return the result.
2471        return @retVal;
2472    }
2473    
2474    =head3 PutLine
2475    
2476    C<< Tracer::PutLine($handle, \@fields); >>
2477    
2478    Write a line of data to a tab-delimited file. The specified field values will be
2479    output in tab-separated form, with a trailing new-line.
2480    
2481    =over 4
2482    
2483    =item handle
2484    
2485    Output file handle.
2486    
2487    =item fields
2488    
2489    List of field values.
2490    
2491    =back
2492    
2493    =cut
2494    
2495    sub PutLine {
2496        # Get the parameters.
2497        my ($handle, $fields) = @_;
2498        # Write the data.
2499        print $handle join("\t", @{$fields}) . "\n";
2500    }
2501    
2502    =head3 GenerateURL
2503    
2504    C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >>
2505    
2506    Generate a GET-style URL for the specified page with the specified parameter
2507    names and values. The values will be URL-escaped automatically. So, for
2508    example
2509    
2510        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
2511    
2512    would return
2513    
2514        form.cgi?type=1&string=%22high%20pass%22%20or%20highway
2515    
2516    =over 4
2517    
2518    =item page
2519    
2520    Page URL.
2521    
2522    =item parameters
2523    
2524    Hash mapping parameter names to parameter values.
2525    
2526    =item RETURN
2527    
2528    Returns a GET-style URL that goes to the specified page and passes in the
2529    specified parameters and values.
2530    
2531    =back
2532    
2533    =cut
2534    
2535    sub GenerateURL {
2536        # Get the parameters.
2537        my ($page, %parameters) = @_;
2538        # Prime the return variable with the page URL.
2539        my $retVal = $page;
2540        # Loop through the parameters, creating parameter elements in a list.
2541        my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
2542        # If the list is nonempty, tack it on.
2543        if (@parmList) {
2544            $retVal .= "?" . join("&", @parmList);
2545        }
2546        # Return the result.
2547        return $retVal;
2548    }
2549    
2550  1;  1;

Legend:
Removed from v.1.23  
changed lines
  Added in v.1.66

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3