[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.26, Wed Sep 14 13:09:53 2005 UTC revision 1.61, Fri Jul 28 02:03:04 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    
36  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
37    
# Line 72  Line 94 
94    
95  =over 4  =over 4
96    
97  =item 0 Error  =item Error 0
98    
99  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
100  application entirely.  application entirely.
101    
102  =item 1 Warning  =item Warning 1
103    
104  Message indicates something that is unexpected but that probably did not interfere  Message indicates something that is unexpected but that probably did not interfere
105  with program execution.  with program execution.
106    
107  =item 2 Notice  =item Notice 2
108    
109  Message indicates the beginning or end of a major task.  Message indicates the beginning or end of a major task.
110    
111  =item 3 Information  =item Information 3
112    
113  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
114  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.
115    
116  =item 4 Detail  =item Detail 4
117    
118  Message indicates a low-level loop iteration.  Message indicates a low-level loop iteration.
119    
# Line 157  Line 179 
179      # Presume category-based tracing until we learn otherwise.      # Presume category-based tracing until we learn otherwise.
180      $AllTrace = 0;      $AllTrace = 0;
181      # 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
182      # tracing.      # tracing. We must also clear away any pre-existing data.
183        %Categories = ( main => 1 );
184      for my $category (@categoryData) {      for my $category (@categoryData) {
185          if ($category eq '*') {          if ($category eq '*') {
186              $AllTrace = 1;              $AllTrace = 1;
# Line 188  Line 211 
211      $SetupCount++;      $SetupCount++;
212  }  }
213    
214    =head3 StandardSetup
215    
216    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
217    
218    This method performs standard command-line parsing and tracing setup. The return
219    values are a hash of the command-line options and a list of the positional
220    parameters. Tracing is automatically set up and the command-line options are
221    validated.
222    
223    This is a complex method that does a lot of grunt work. The parameters can
224    be more easily understood, however, once they are examined individually.
225    
226    The I<categories> parameter is the most obtuse. It is a reference to a list of
227    special-purpose tracing categories. Most tracing categories are PERL package
228    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
229    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
230    
231        ["Sprout", "SproutLoad", "ERDB"]
232    
233    This would cause trace messages in the specified three packages to appear in
234    the output. There are threer special tracing categories that are automatically
235    handled by this method. In other words, if you used L</TSetup> you would need
236    to include these categories manually, but if you use this method they are turned
237    on automatically.
238    
239    =over 4
240    
241    =item FIG
242    
243    Turns on trace messages inside the B<FIG> package.
244    
245    =item SQL
246    
247    Traces SQL commands and activity.
248    
249    =item Tracer
250    
251    Traces error messages and call stacks.
252    
253    =back
254    
255    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
256    The trace level is specified using the C<-trace> command-line option. For example,
257    the following command line for C<TransactFeatures> turns on SQL tracing and runs
258    all tracing at level 3.
259    
260        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
261    
262    Standard tracing is output to the standard output and echoed to the file
263    C<trace>I<$$>C<.log> in the FIG temporary directory, where I<$$> is the
264    process ID. You can also specify the C<user> parameter to put a user ID
265    instead of a process ID in the trace file name. So, for example
266    
267    The default trace level is 2. To get all messages, specify a trace level of 4.
268    For a genome-by-genome update, use 3.
269    
270        TransactFeatures -trace=3 -sql -user=Bruce register ../xacts IDs.tbl
271    
272    would send the trace output to C<traceBruce.log> in the temporary directory.
273    
274    The I<options> parameter is a reference to a hash containing the command-line
275    options, their default values, and an explanation of what they mean. Command-line
276    options may be in the form of switches or keywords. In the case of a switch, the
277    option value is 1 if it is specified and 0 if it is not specified. In the case
278    of a keyword, the value is separated from the option name by an equal sign. You
279    can see this last in the command-line example above.
280    
281    You can specify a different default trace level by setting C<$options->{trace}>
282    prior to calling this method.
283    
284    An example at this point would help. Consider, for example, the command-line utility
285    C<TransactFeatures>. It accepts a list of positional parameters plus the options
286    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
287    the following code.
288    
289        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
290                            { safe => [0, "use database transactions"],
291                              noAlias => [0, "do not expect aliases in CHANGE transactions"],
292                              start => [' ', "start with this genome"],
293                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
294                            "command transactionDirectory IDfile",
295                          @ARGV);
296    
297    
298    The call to C<ParseCommand> specifies the default values for the options and
299    stores the actual options in a hash that is returned as C<$options>. The
300    positional parameters are returned in C<@parameters>.
301    
302    The following is a sample command line for C<TransactFeatures>.
303    
304        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
305    
306    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
307    parameters, and would find themselves in I<@parameters> after executing the
308    above code fragment. The tracing would be set to level 2, and the categories
309    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
310    and C<DocUtils> was included because it came in within the first parameter
311    to this method. The I<$options> hash would be
312    
313        { trace => 2, sql => 0, safe => 0,
314          noAlias => 1, start => ' ', tblFiles => 0 }
315    
316    Use of C<StandardSetup> in this way provides a simple way of performing
317    standard tracing setup and command-line parsing. Note that the caller is
318    not even aware of the command-line switches C<-trace> and C<-sql>, which
319    are used by this method to control the tracing. If additional tracing features
320    need to be added in the future, they can be processed by this method without
321    upsetting the command-line utilities.
322    
323    If the C<background> option is specified on the command line, then the
324    standard and error outputs will be directed to files in the temporary
325    directory, using the same suffix as the trace file. So, if the command
326    line specified
327    
328        -user=Bruce -background
329    
330    then the trace output would go to C<traceBruce.log>, the standard output to
331    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
332    simplify starting a command in the background.
333    
334    Finally, if the special option C<-h> is specified, the option names will
335    be traced at level 0 and the program will exit without processing.
336    This provides a limited help capability. For example, if the user enters
337    
338        TransactFeatures -h
339    
340    he would see the following output.
341    
342        TransactFeatures [options] command transactionDirectory IDfile
343            -trace    tracing level (default 2)
344            -sql      trace SQL commands
345            -safe     use database transactions
346            -noAlias  do not expect aliases in CHANGE transactions
347            -start    start with this genome
348            -tblFiles output TBL files containing the corrected IDs
349    
350    The caller has the option of modifying the tracing scheme by placing a value
351    for C<trace> in the incoming options hash. The default value can be overridden,
352    or the tracing to the standard output can be turned off by suffixing a minus
353    sign to the trace level. So, for example,
354    
355        { trace => [0, "tracing level (default 0)"],
356           ...
357    
358    would set the default trace level to 0 instead of 2, while
359    
360        { trace => ["2-", "tracing level (default 2)"],
361           ...
362    
363    would leave the default at 2, but trace only to the log file, not to the
364    standard output.
365    
366    The parameters to this method are as follows.
367    
368    =over 4
369    
370    =item categories
371    
372    Reference to a list of tracing category names. These should be names of
373    packages whose internal workings will need to be debugged to get the
374    command working.
375    
376    =item options
377    
378    Reference to a hash containing the legal options for the current command mapped
379    to their default values and descriptions. The user can override the defaults
380    by specifying the options as command-line switches prefixed by a hyphen.
381    Tracing-related options may be added to this hash. If the C<-h> option is
382    specified on the command line, the option descriptions will be used to
383    explain the options. To turn off tracing to the standard output, add a
384    minus sign to the value for C<trace> (see above).
385    
386    =item parmHelp
387    
388    A string that vaguely describes the positional parameters. This is used
389    if the user specifies the C<-h> option.
390    
391    =item argv
392    
393    List of command line parameters, including the option switches, which must
394    precede the positional parameters and be prefixed by a hyphen.
395    
396    =item RETURN
397    
398    Returns a list. The first element of the list is the reference to a hash that
399    maps the command-line option switches to their values. These will either be the
400    default values or overrides specified on the command line. The remaining
401    elements of the list are the position parameters, in order.
402    
403    =back
404    
405    =cut
406    
407    sub StandardSetup {
408        # Get the parameters.
409        my ($categories, $options, $parmHelp, @argv) = @_;
410        # Add the tracing options.
411        if (! exists $options->{trace}) {
412            $options->{trace} = [2, "tracing level"];
413        }
414        $options->{sql} = [0, "turn on SQL tracing"];
415        $options->{h} = [0, "display command-line options"];
416        $options->{user} = [$$, "trace log file name suffix"];
417        $options->{background} = [0, "spool standard and error output"];
418        # Create a parsing hash from the options hash. The parsing hash
419        # contains the default values rather than the default value
420        # and the description. While we're at it, we'll memorize the
421        # length of the longest option name.
422        my $longestName = 0;
423        my %parseOptions = ();
424        for my $key (keys %{$options}) {
425            if (length $key > $longestName) {
426                $longestName = length $key;
427            }
428            $parseOptions{$key} = $options->{$key}->[0];
429        }
430        # Parse the command line.
431        my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
432        # Get the logfile suffix.
433        my $suffix = $retOptions->{user};
434        # Check for background mode.
435        if ($retOptions->{background}) {
436            my $outFileName = "$FIG_Config::temp/out$suffix.log";
437            my $errFileName = "$FIG_Config::temp/err$suffix.log";
438            open STDOUT, ">$outFileName";
439            open STDERR, ">$errFileName";
440        }
441        # Now we want to set up tracing. First, we need to know if SQL is to
442        # be traced.
443        my @cats = @{$categories};
444        if ($retOptions->{sql}) {
445            push @cats, "SQL";
446        }
447        # Add the default categories.
448        push @cats, "Tracer", "FIG";
449        # Next, we create the category string by joining the categories.
450        my $cats = join(" ", @cats);
451        # Check to determine whether or not the caller wants to turn off tracing
452        # to the standard output.
453        my $traceLevel = $retOptions->{trace};
454        my $textOKFlag = 1;
455        if ($traceLevel =~ /^(.)-/) {
456            $traceLevel = $1;
457            $textOKFlag = 0;
458        }
459        # Now we set up the trace mode.
460        my $traceMode;
461        # Verify that we can open a file in the FIG temporary directory.
462        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
463        if (open TESTTRACE, ">$traceFileName") {
464            # Here we can trace to a file.
465            $traceMode = ">$traceFileName";
466            if ($textOKFlag) {
467                # Echo to standard output if the text-OK flag is set.
468                $traceMode = "+$traceMode";
469            }
470            # Close the test file.
471            close TESTTRACE;
472        } else {
473            # Here we can't trace to a file. We trace to the standard output if it's
474            # okay, and the error log otherwise.
475            if ($textOKFlag) {
476                $traceMode = "TEXT";
477            } else {
478                $traceMode = "WARN";
479            }
480        }
481        # Now set up the tracing.
482        TSetup("$traceLevel $cats", $traceMode);
483        # Check for the "h" option. If it is specified, dump the command-line
484        # options and exit the program.
485        if ($retOptions->{h}) {
486            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
487            Trace("$1 [options] $parmHelp") if T(0);
488            for my $key (sort keys %{$options}) {
489                my $name = Pad($key, $longestName, 0, ' ');
490                my $desc = $options->{$key}->[1];
491                if ($options->{$key}->[0]) {
492                    $desc .= " (default " . $options->{$key}->[0] . ")";
493                }
494                Trace("  $name $desc") if T(0);
495            }
496            exit(0);
497        }
498        # Return the parsed parameters.
499        return ($retOptions, @retParameters);
500    }
501    
502  =head3 Setups  =head3 Setups
503    
504  C<< my $count = Tracer::Setups(); >>  C<< my $count = Tracer::Setups(); >>
# Line 348  Line 659 
659    
660  =head3 OpenDir  =head3 OpenDir
661    
662  C<< my @files = OpenDir($dirName, $filtered); >>  C<< my @files = OpenDir($dirName, $filtered, $flag); >>
663    
664  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
665  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
666  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<$>),
667  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
668  for example,  filtered out of the return list. If the directory does not open and I<$flag> is not
669    set, an exception is thrown. So, for example,
670    
671      my @files = OpenDir("/Volumes/fig/contigs", 1);      my @files = OpenDir("/Volumes/fig/contigs", 1);
672    
673  is effectively the same as  is effectively the same as
674    
675      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
676      my @files = grep { $_ !~ /^\./ } readdir(TMP);      my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
677    
678  Similarly, the following code  Similarly, the following code
679    
680      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs");      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
681    
682  Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and  Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
683  automatically throws an error if the directory fails to open.  automatically returns an empty list if the directory fails to open.
684    
685  =over 4  =over 4
686    
# Line 381  Line 693 
693  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
694  from the list, else FALSE.  from the list, else FALSE.
695    
696    =item flag
697    
698    TRUE if a failure to open is okay, else FALSE
699    
700  =back  =back
701    
702  =cut  =cut
703  #: Return Type @;  #: Return Type @;
704  sub OpenDir {  sub OpenDir {
705      # Get the parameters.      # Get the parameters.
706      my ($dirName, $filtered) = @_;      my ($dirName, $filtered, $flag) = @_;
707      # Declare the return variable.      # Declare the return variable.
708      my @retVal;      my @retVal = ();
709      # Open the directory.      # Open the directory.
710      if (opendir(my $dirHandle, $dirName)) {      if (opendir(my $dirHandle, $dirName)) {
711          # The directory opened successfully. Get the appropriate list according to the          # The directory opened successfully. Get the appropriate list according to the
712          # strictures of the filter parameter.          # strictures of the filter parameter.
713          if ($filtered) {          if ($filtered) {
714              @retVal = grep { $_ !~ /^\./ } readdir $dirHandle;              @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
715          } else {          } else {
716              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
717          }          }
718      } else {      } elsif (! $flag) {
719          # Here the directory would not open.          # Here the directory would not open and it's considered an error.
720          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
721      }      }
722      # Return the result.      # Return the result.
# Line 738  Line 1054 
1054          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
1055          $category = lc $category;          $category = lc $category;
1056          # Use the category and tracelevel to compute the result.          # Use the category and tracelevel to compute the result.
1057            if (ref $traceLevel) {
1058                Confess("Bad trace level.");
1059            } elsif (ref $TraceLevel) {
1060                Confess("Bad trace config.");
1061            }
1062          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
1063      }      }
1064      # Return the computed result.      # Return the computed result.
# Line 825  Line 1146 
1146  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1147    
1148  Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines  Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1149  replaced by C<\n>, and backslashes will be doubled. The effect is to exactly reverse the  replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
1150  effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1151    
1152  =over 4  =over 4
1153    
# Line 850  Line 1171 
1171      # Loop through the parameter string, looking for sequences to escape.      # Loop through the parameter string, looking for sequences to escape.
1172      while (length $realString > 0) {      while (length $realString > 0) {
1173          # Look for the first sequence to escape.          # Look for the first sequence to escape.
1174          if ($realString =~ /^(.*?)([\n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1175              # Here we found it. The text preceding the sequence is in $1. The sequence              # Here we found it. The text preceding the sequence is in $1. The sequence
1176              # itself is in $2. First, move the clear text to the return variable.              # itself is in $2. First, move the clear text to the return variable.
1177              $retVal .= $1;              $retVal .= $1;
1178              # Strip the processed section off the real string.              # Strip the processed section off the real string.
1179              $realString = substr $realString, (length $2) + (length $1);              $realString = substr $realString, (length $2) + (length $1);
1180              # Encode the escape sequence.              # Get the matched character.
1181              my $char = $2;              my $char = $2;
1182                # If we have a CR, we are done.
1183                if ($char ne "\r") {
1184                    # It's not a CR, so encode the escape sequence.
1185              $char =~ tr/\t\n/tn/;              $char =~ tr/\t\n/tn/;
1186              $retVal .= "\\" . $char;              $retVal .= "\\" . $char;
1187                }
1188          } else {          } else {
1189              # Here there are no more escape sequences. The rest of the string is              # Here there are no more escape sequences. The rest of the string is
1190              # transferred unmodified.              # transferred unmodified.
# Line 876  Line 1201 
1201  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1202    
1203  Replace escape sequences with their actual equivalents. C<\t> will be replaced by  Replace escape sequences with their actual equivalents. C<\t> will be replaced by
1204  a tab, C<\n> by a new-line character, and C<\\> by a back-slash.  a tab, C<\n> by a new-line character, and C<\\> by a backslash. C<\r> codes will
1205    be deleted.
1206    
1207  =over 4  =over 4
1208    
# Line 905  Line 1231 
1231          # "\<tab>" no matter what we do.)          # "\<tab>" no matter what we do.)
1232          while (length $codedString > 0) {          while (length $codedString > 0) {
1233              # Look for the first escape sequence.              # Look for the first escape sequence.
1234              if ($codedString =~ /^(.*?)\\(\\|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1235                  # Here we found it. The text preceding the sequence is in $1. The sequence                  # Here we found it. The text preceding the sequence is in $1. The sequence
1236                  # itself is in $2. First, move the clear text to the return variable.                  # itself is in $2. First, move the clear text to the return variable.
1237                  $retVal .= $1;                  $retVal .= $1;
1238                  $codedString = substr $codedString, (2 + length $1);                  $codedString = substr $codedString, (2 + length $1);
1239                  # Decode the escape sequence.                  # Get the escape value.
1240                  my $char = $2;                  my $char = $2;
1241                    # If we have a "\r", we are done.
1242                    if ($char ne 'r') {
1243                        # Here it's not an 'r', so we convert it.
1244                  $char =~ tr/\\tn/\\\t\n/;                  $char =~ tr/\\tn/\\\t\n/;
1245                  $retVal .= $char;                  $retVal .= $char;
1246                    }
1247              } else {              } else {
1248                  # Here there are no more escape sequences. The rest of the string is                  # Here there are no more escape sequences. The rest of the string is
1249                  # transferred unmodified.                  # transferred unmodified.
# Line 1019  Line 1349 
1349      return @inputList;      return @inputList;
1350  }  }
1351    
1352    =head3 Percent
1353    
1354    C<< my $percent = Tracer::Percent($number, $base); >>
1355    
1356    Returns the percent of the base represented by the given number. If the base
1357    is zero, returns zero.
1358    
1359    =over 4
1360    
1361    =item number
1362    
1363    Percent numerator.
1364    
1365    =item base
1366    
1367    Percent base.
1368    
1369    =item RETURN
1370    
1371    Returns the percentage of the base represented by the numerator.
1372    
1373    =back
1374    
1375    =cut
1376    
1377    sub Percent {
1378        # Get the parameters.
1379        my ($number, $base) = @_;
1380        # Declare the return variable.
1381        my $retVal = 0;
1382        # Compute the percent.
1383        if ($base != 0) {
1384            $retVal = $number * 100 / $base;
1385        }
1386        # Return the result.
1387        return $retVal;
1388    }
1389    
1390  =head3 GetFile  =head3 GetFile
1391    
1392  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1393    
1394  Return the entire contents of a file.      or
1395    
1396    C<< my $fileContents = Tracer::GetFile($fileName); >>
1397    
1398    Return the entire contents of a file. In list context, line-ends are removed and
1399    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1400    
1401  =over 4  =over 4
1402    
# Line 1034  Line 1407 
1407  =item RETURN  =item RETURN
1408    
1409  In a list context, returns the entire file as a list with the line terminators removed.  In a list context, returns the entire file as a list with the line terminators removed.
1410  In a scalar context, returns the entire file as a string.  In a scalar context, returns the entire file as a string. If an error occurs opening
1411    the file, an empty list will be returned.
1412    
1413  =back  =back
1414    
# Line 1046  Line 1420 
1420      # Declare the return variable.      # Declare the return variable.
1421      my @retVal = ();      my @retVal = ();
1422      # Open the file for input.      # Open the file for input.
1423      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 {  
1424          # Read the whole file into the return variable, stripping off any terminator          # Read the whole file into the return variable, stripping off any terminator
1425          # characters.          # characters.
1426          my $lineCount = 0;          my $lineCount = 0;
1427          while (my $line = <INPUTFILE>) {      while (my $line = <$handle>) {
1428              $lineCount++;              $lineCount++;
1429              $line = Strip($line);              $line = Strip($line);
1430              push @retVal, $line;              push @retVal, $line;
1431          }          }
1432          # Close it.          # Close it.
1433          close INPUTFILE;      close $handle;
1434          my $actualLines = @retVal;          my $actualLines = @retVal;
     }  
1435      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1436      if (wantarray) {      if (wantarray) {
1437          return @retVal;          return @retVal;
# Line 1071  Line 1440 
1440      }      }
1441  }  }
1442    
1443    =head3 PutFile
1444    
1445    C<< Tracer::PutFile($fileName, \@lines); >>
1446    
1447    Write out a file from a list of lines of text.
1448    
1449    =over 4
1450    
1451    =item fileName
1452    
1453    Name of the output file.
1454    
1455    =item lines
1456    
1457    Reference to a list of text lines. The lines will be written to the file in order, with trailing
1458    new-line characters.
1459    
1460    =back
1461    
1462    =cut
1463    
1464    sub PutFile {
1465        # Get the parameters.
1466        my ($fileName, $lines) = @_;
1467        # Open the output file.
1468        my $handle = Open(undef, ">$fileName");
1469        # Write the lines.
1470        for my $line (@{$lines}) {
1471            print $handle "$line\n";
1472        }
1473        # Close the output file.
1474        close $handle;
1475    }
1476    
1477  =head3 QTrace  =head3 QTrace
1478    
1479  C<< my $data = QTrace($format); >>  C<< my $data = QTrace($format); >>
# Line 1150  Line 1553 
1553  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1554    
1555  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
1556  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.
1557  So, for example  So, for example
1558    
1559  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1271  Line 1674 
1674    
1675  =head3 AddToListMap  =head3 AddToListMap
1676    
1677  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1678    
1679  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
1680  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 1286  Line 1689 
1689    
1690  Key for which the value is to be added.  Key for which the value is to be added.
1691    
1692  =item value  =item value1, value2, ... valueN
1693    
1694  Value to add to the key's value list.  List of values to add to the key's value list.
1695    
1696  =back  =back
1697    
# Line 1296  Line 1699 
1699    
1700  sub AddToListMap {  sub AddToListMap {
1701      # Get the parameters.      # Get the parameters.
1702      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1703      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1704      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1705          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1706      } else {      } else {
1707          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1708      }      }
1709  }  }
1710    
# Line 1331  Line 1734 
1734          $retVal = 1;          $retVal = 1;
1735      } else {      } else {
1736          # Here debug mode is off, so we generate an error page.          # Here debug mode is off, so we generate an error page.
1737          my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");          my $pageString = PageBuilder::Build("<<Html/ErrorPage.html", {}, "Html");
1738          print $pageString;          print $pageString;
1739      }      }
1740      # Return the determination indicator.      # Return the determination indicator.
# Line 1363  Line 1766 
1766  sub Strip {  sub Strip {
1767      # Get a copy of the parameter string.      # Get a copy of the parameter string.
1768      my ($string) = @_;      my ($string) = @_;
1769      my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1770      # Strip the line terminator characters.      # Strip the line terminator characters.
1771      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1772      # Return the result.      # Return the result.
# Line 1431  Line 1834 
1834      return $retVal;      return $retVal;
1835  }  }
1836    
1837    =head3 EOF
1838    
1839    This is a constant that is lexically greater than any useful string.
1840    
1841    =cut
1842    
1843    sub EOF {
1844        return "\xFF\xFF\xFF\xFF\xFF";
1845    }
1846    
1847  =head3 TICK  =head3 TICK
1848    
1849  C<< my @results = TICK($commandString); >>  C<< my @results = TICK($commandString); >>
# Line 1472  Line 1885 
1885      return `$commandString`;      return `$commandString`;
1886  }  }
1887    
1888    =head3 ScriptSetup
1889    
1890    C<< my ($query, $varHash) = ScriptSetup(); >>
1891    
1892    Perform standard tracing and debugging setup for scripts. The value returned is
1893    the CGI object followed by a pre-built variable hash.
1894    
1895    The C<Trace> query parameter is used to determine whether or not tracing is active and
1896    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1897    the C<CGI> trace module will trace parameter and environment information. Parameters are
1898    traced at level 3 and environment variables at level 4. At the end of the script, the
1899    client should call L</ScriptFinish> to output the web page.
1900    
1901    =cut
1902    
1903    sub ScriptSetup {
1904        # Get the CGI query object.
1905        my $query = CGI->new();
1906        # Check for tracing. Set it up if the user asked for it.
1907        if ($query->param('Trace')) {
1908            # Set up tracing to be queued for display at the bottom of the web page.
1909            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1910            # Trace the parameter and environment data.
1911            if (T(CGI => 3)) {
1912                # Here we want to trace the parameter data.
1913                my @names = $query->param;
1914                for my $parmName (sort @names) {
1915                    # Note we skip "Trace", which is for our use only.
1916                    if ($parmName ne 'Trace') {
1917                        my @values = $query->param($parmName);
1918                        Trace("CGI: $parmName = " . join(", ", @values));
1919                    }
1920                }
1921            }
1922            if (T(CGI => 4)) {
1923                # Here we want the environment data too.
1924                for my $envName (sort keys %ENV) {
1925                    Trace("ENV: $envName = $ENV{$envName}");
1926                }
1927            }
1928        } else {
1929            # Here tracing is to be turned off. All we allow is errors traced into the
1930            # error log.
1931            TSetup("0", "WARN");
1932        }
1933        # Create the variable hash.
1934        my $varHash = { DebugData => '' };
1935        # If we're in DEBUG mode, set up the debug mode data for forms.
1936        if (Tracer::DebugMode) {
1937            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1938        }
1939        # Return the query object and variable hash.
1940        return ($query, $varHash);
1941    }
1942    
1943    =head3 ScriptFinish
1944    
1945    C<< ScriptFinish($webData, $varHash); >>
1946    
1947    Output a web page at the end of a script. Either the string to be output or the
1948    name of a template file can be specified. If the second parameter is omitted,
1949    it is assumed we have a string to be output; otherwise, it is assumed we have the
1950    name of a template file. The template should have the variable C<DebugData>
1951    specified in any form that invokes a standard script. If debugging mode is turned
1952    on, a form field will be put in that allows the user to enter tracing data.
1953    Trace messages will be placed immediately before the terminal C<BODY> tag in
1954    the output, formatted as a list.
1955    
1956    A typical standard script would loook like the following.
1957    
1958        BEGIN {
1959            # Print the HTML header.
1960            print "CONTENT-TYPE: text/html\n\n";
1961        }
1962        use Tracer;
1963        use CGI;
1964        use FIG;
1965        # ... more uses ...
1966    
1967        my ($query, $varHash) = ScriptSetup();
1968        eval {
1969            # ... get data from $query, put it in $varHash ...
1970        };
1971        if ($@) {
1972            Trace("Script Error: $@") if T(0);
1973        }
1974        ScriptFinish("Html/MyTemplate.html", $varHash);
1975    
1976    The idea here is that even if the script fails, you'll see trace messages and
1977    useful output.
1978    
1979    =over 4
1980    
1981    =item webData
1982    
1983    A string containing either the full web page to be written to the output or the
1984    name of a template file from which the page is to be constructed. If the name
1985    of a template file is specified, then the second parameter must be present;
1986    otherwise, it must be absent.
1987    
1988    =item varHash (optional)
1989    
1990    If specified, then a reference to a hash mapping variable names for a template
1991    to their values. The template file will be read into memory, and variable markers
1992    will be replaced by data in this hash reference.
1993    
1994    =back
1995    
1996    =cut
1997    
1998    sub ScriptFinish {
1999        # Get the parameters.
2000        my ($webData, $varHash) = @_;
2001        # Check for a template file situation.
2002        my $outputString;
2003        if (defined $varHash) {
2004            # Here we have a template file. We need to apply the variables to the template.
2005            $outputString = PageBuilder::Build("<<$webData", $varHash, "Html");
2006        } else {
2007            # Here the user gave us a raw string.
2008            $outputString = $webData;
2009        }
2010        # Check for trace messages.
2011        if ($Destination eq "QUEUE") {
2012            # We have trace messages, so we want to put them at the end of the body. This
2013            # is either at the end of the whole string or at the beginning of the BODY
2014            # end-tag.
2015            my $pos = length $outputString;
2016            if ($outputString =~ m#</body>#gi) {
2017                $pos = (pos $outputString) - 7;
2018            }
2019            substr $outputString, $pos, 0, QTrace('Html');
2020        }
2021        # Write the output string.
2022        print $outputString;
2023    }
2024    
2025    =head3 Insure
2026    
2027    C<< Insure($dirName); >>
2028    
2029    Insure a directory is present.
2030    
2031    =over 4
2032    
2033    =item dirName
2034    
2035    Name of the directory to check. If it does not exist, it will be created.
2036    
2037    =back
2038    
2039    =cut
2040    
2041    sub Insure {
2042        my ($dirName) = @_;
2043        if (! -d $dirName) {
2044            Trace("Creating $dirName directory.") if T(2);
2045            eval { mkpath $dirName; };
2046            if ($@) {
2047                Confess("Error creating $dirName: $@");
2048            }
2049        }
2050    }
2051    
2052    =head3 ChDir
2053    
2054    C<< ChDir($dirName); >>
2055    
2056    Change to the specified directory.
2057    
2058    =over 4
2059    
2060    =item dirName
2061    
2062    Name of the directory to which we want to change.
2063    
2064    =back
2065    
2066    =cut
2067    
2068    sub ChDir {
2069        my ($dirName) = @_;
2070        if (! -d $dirName) {
2071            Confess("Cannot change to directory $dirName: no such directory.");
2072        } else {
2073            Trace("Changing to directory $dirName.") if T(4);
2074            my $okFlag = chdir $dirName;
2075            if (! $okFlag) {
2076                Confess("Error switching to directory $dirName.");
2077            }
2078        }
2079    }
2080    
2081    =head3 SendSMS
2082    
2083    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2084    
2085    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2086    user name, password, and API ID for the relevant account in the hash reference variable
2087    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2088    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2089    is C<2561022>, then the FIG_Config file must contain
2090    
2091        $phone =  { user => 'BruceTheHumanPet',
2092                    password => 'silly',
2093                    api_id => '2561022' };
2094    
2095    The original purpose of this method was to insure Bruce would be notified immediately when the
2096    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2097    when you call this method.
2098    
2099    The message ID will be returned if successful, and C<undef> if an error occurs.
2100    
2101    =over 4
2102    
2103    =item phoneNumber
2104    
2105    Phone number to receive the message, in international format. A United States phone number
2106    would be prefixed by "1". A British phone number would be prefixed by "44".
2107    
2108    =item msg
2109    
2110    Message to send to the specified phone.
2111    
2112    =item RETURN
2113    
2114    Returns the message ID if successful, and C<undef> if the message could not be sent.
2115    
2116    =back
2117    
2118    =cut
2119    
2120    sub SendSMS {
2121        # Get the parameters.
2122        my ($phoneNumber, $msg) = @_;
2123        # Declare the return variable. If we do not change it, C<undef> will be returned.
2124        my $retVal;
2125        # Only proceed if we have phone support.
2126        if (! defined $FIG_Config::phone) {
2127            Trace("Phone support not present in FIG_Config.") if T(1);
2128        } else {
2129            # Get the phone data.
2130            my $parms = $FIG_Config::phone;
2131            # Get the Clickatell URL.
2132            my $url = "http://api.clickatell.com/http/";
2133            # Create the user agent.
2134            my $ua = LWP::UserAgent->new;
2135            # Request a Clickatell session.
2136            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2137                                         password => $parms->{password},
2138                                         api_id => $parms->{api_id},
2139                                         to => $phoneNumber,
2140                                         text => $msg});
2141            # Check for an error.
2142            if (! $resp->is_success) {
2143                Trace("Alert failed.") if T(1);
2144            } else {
2145                # Get the message ID.
2146                my $rstring = $resp->content;
2147                if ($rstring =~ /^ID:\s+(.*)$/) {
2148                    $retVal = $1;
2149                } else {
2150                    Trace("Phone attempt failed with $rstring") if T(1);
2151                }
2152            }
2153        }
2154        # Return the result.
2155        return $retVal;
2156    }
2157    
2158    =head3 CommaFormat
2159    
2160    C<< my $formatted = Tracer::CommaFormat($number); >>
2161    
2162    Insert commas into a number.
2163    
2164    =over 4
2165    
2166    =item number
2167    
2168    A sequence of digits.
2169    
2170    =item RETURN
2171    
2172    Returns the same digits with commas strategically inserted.
2173    
2174    =back
2175    
2176    =cut
2177    
2178    sub CommaFormat {
2179        # Get the parameters.
2180        my ($number) = @_;
2181        # Pad the length up to a multiple of three.
2182        my $padded = "$number";
2183        $padded = " " . $padded while length($padded) % 3 != 0;
2184        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2185        # cause the delimiters to be included in the output stream. The
2186        # GREP removes the empty strings in between the delimiters.
2187        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2188        # Clean out the spaces.
2189        $retVal =~ s/ //g;
2190        # Return the result.
2191        return $retVal;
2192    }
2193    =head3 SetPermissions
2194    
2195    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2196    
2197    Set the permissions for a directory and all the files and folders inside it.
2198    In addition, the group ownership will be changed to the specified value.
2199    
2200    This method is more vulnerable than most to permission and compatability
2201    problems, so it does internal error recovery.
2202    
2203    =over 4
2204    
2205    =item dirName
2206    
2207    Name of the directory to process.
2208    
2209    =item group
2210    
2211    Name of the group to be assigned.
2212    
2213    =item mask
2214    
2215    Permission mask. Bits that are C<1> in this mask will be ORed into the
2216    permission bits of any file or directory that does not already have them
2217    set to 1.
2218    
2219    =item otherMasks
2220    
2221    Map of search patterns to permission masks. If a directory name matches
2222    one of the patterns, that directory and all its members and subdirectories
2223    will be assigned the new pattern. For example, the following would
2224    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2225    
2226        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2227    
2228    The list is ordered, so the following would use 0777 for C<tmp1> and
2229    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2230    
2231        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2232                                                       '^tmp' => 0666);
2233    
2234    Note that the pattern matches are all case-insensitive, and only directory
2235    names are matched, not file names.
2236    
2237    =back
2238    
2239    =cut
2240    
2241    sub SetPermissions {
2242        # Get the parameters.
2243        my ($dirName, $group, $mask, @otherMasks) = @_;
2244        # Set up for error recovery.
2245        eval {
2246            # Switch to the specified directory.
2247            ChDir($dirName);
2248            # Get the group ID.
2249            my $gid = getgrnam($group);
2250            # Get the mask for tracing.
2251            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2252            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2253            my $fixCount = 0;
2254            my $lookCount = 0;
2255            # @dirs will be a stack of directories to be processed.
2256            my @dirs = (getcwd());
2257            while (scalar(@dirs) > 0) {
2258                # Get the current directory.
2259                my $dir = pop @dirs;
2260                # Check for a match to one of the specified directory names. To do
2261                # that, we need to pull the individual part of the name off of the
2262                # whole path.
2263                my $simpleName = $dir;
2264                if ($dir =~ m!/([^/]+)$!) {
2265                    $simpleName = $1;
2266                }
2267                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2268                # Search for a match.
2269                my $match = 0;
2270                my $i;
2271                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2272                    my $pattern = $otherMasks[$i];
2273                    if ($simpleName =~ /$pattern/i) {
2274                        $match = 1;
2275                    }
2276                }
2277                # Check for a match. Note we use $i-1 because the loop added 2
2278                # before terminating due to the match.
2279                if ($match && $otherMasks[$i-1] != $mask) {
2280                    # This directory matches one of the incoming patterns, and it's
2281                    # a different mask, so we process it recursively with that mask.
2282                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2283                } else {
2284                    # Here we can process normally. Get all of the non-hidden members.
2285                    my @submems = OpenDir($dir, 1);
2286                    for my $submem (@submems) {
2287                        # Get the full name.
2288                        my $thisMem = "$dir/$submem";
2289                        Trace("Checking member $thisMem.") if T(4);
2290                        $lookCount++;
2291                        if ($lookCount % 1000 == 0) {
2292                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2293                        }
2294                        # Fix the group.
2295                        chown -1, $gid, $thisMem;
2296                        # Insure this member is not a symlink.
2297                        if (! -l $thisMem) {
2298                            # Get its info.
2299                            my $fileInfo = stat $thisMem;
2300                            # Only proceed if we got the info. Otherwise, it's a hard link
2301                            # and we want to skip it anyway.
2302                            if ($fileInfo) {
2303                                my $fileMode = $fileInfo->mode;
2304                                if (($fileMode & $mask) != $mask) {
2305                                    # Fix this member.
2306                                    $fileMode |= $mask;
2307                                    chmod $fileMode, $thisMem;
2308                                    $fixCount++;
2309                                }
2310                                # If it's a subdirectory, stack it.
2311                                if (-d $thisMem) {
2312                                    push @dirs, $thisMem;
2313                                }
2314                            }
2315                        }
2316                    }
2317                }
2318            }
2319            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2320        };
2321        # Check for an error.
2322        if ($@) {
2323            Confess("SetPermissions error: $@");
2324        }
2325    }
2326    
2327  1;  1;

Legend:
Removed from v.1.26  
changed lines
  Added in v.1.61

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3