[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.32, Thu Jan 5 22:26:54 2006 UTC revision 1.67, Fri Sep 29 15:00:17 2006 UTC
# Line 19  Line 19 
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 StandardSetup);      @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 174  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 207  Line 215 
215    
216  =head3 StandardSetup  =head3 StandardSetup
217    
218  C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, @ARGV); >>  C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
219    
220  This method performs standard command-line parsing and tracing setup. The return  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  values are a hash of the command-line options and a list of the positional
# Line 254  Line 262 
262      TransactFeatures -trace=3 -sql register ../xacts IDs.tbl      TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
263    
264  Standard tracing is output to the standard output and echoed to the file  Standard tracing is output to the standard output and echoed to the file
265  C<trace.log> in the FIG temporary directory.  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 3. This dumps out all SQL commands if SQL tracing  The default trace level is 2. To get all messages, specify a trace level of 4.
270  is turned on and tends to produce one flurry of messages per genome. To get all  For a genome-by-genome update, use 3.
271  messages, specify a trace level of 4. For generally quiet output, use 2.  
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  The I<options> parameter is a reference to a hash containing the command-line
277  options and their default values. Command-line options may be in the form of switches  options, their default values, and an explanation of what they mean. Command-line
278  or keywords. In the case of a switch, the option value is 1 if it is specified and  options may be in the form of switches or keywords. In the case of a switch, the
279  0 if it is not specified. In the case of a keyword, the value is separated from the  option value is 1 if it is specified and 0 if it is not specified. In the case
280  option name by an equal sign. You can see this last in the command-line example above.  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  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  C<TransactFeatures>. It accepts a list of positional parameters plus the options
# Line 272  Line 289 
289  the following code.  the following code.
290    
291      my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],      my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
292                                                        { trace => 3, sql => 0,                          { safe => [0, "use database transactions"],
293                                                          safe => 0, noAlias => 0,                            noAlias => [0, "do not expect aliases in CHANGE transactions"],
294                                                          start => ' ', tblFiles => 0},                            start => [' ', "start with this genome"],
295                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
296                            "command transactionDirectory IDfile",
297                                                      @ARGV);                                                      @ARGV);
298    
299    
# Line 303  Line 322 
322  need to be added in the future, they can be processed by this method without  need to be added in the future, they can be processed by this method without
323  upsetting the command-line utilities.  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.  The parameters to this method are as follows.
369    
370  =over 4  =over 4
# Line 316  Line 378 
378  =item options  =item options
379    
380  Reference to a hash containing the legal options for the current command mapped  Reference to a hash containing the legal options for the current command mapped
381  to their default values. The use can override the defaults by specifying the  to their default values and descriptions. The user can override the defaults
382  options as command-line switches prefixed by a hyphen. Tracing-related options  by specifying the options as command-line switches prefixed by a hyphen.
383  may be added to this hash.  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  =item argv
394    
395  List of command line parameters, including the option switches, which must  List of command line parameters, including the option switches, which must
396  precede the positional parameters and be prefixed by a hyphen.  precede the positional parameters and be prefixed by a hyphen.
# Line 338  Line 408 
408    
409  sub StandardSetup {  sub StandardSetup {
410      # Get the parameters.      # Get the parameters.
411      my ($categories, $options, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
412      # Add the tracing options.      # Add the tracing options.
413      $options->{trace} = 3;      if (! exists $options->{trace}) {
414      $options->{sql} = 0;          $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.      # Parse the command line.
433      my ($retOptions, @retParameters) = ParseCommand($options, @argv);      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      # Now we want to set up tracing. First, we need to know if SQL is to
444      # be traced.      # be traced.
445      my @cats = @{$categories};      my @cats = @{$categories};
# Line 352  Line 448 
448      }      }
449      # Add the default categories.      # Add the default categories.
450      push @cats, "Tracer", "FIG";      push @cats, "Tracer", "FIG";
451      # Next, we create the category string by prefixing the trace level      # Next, we create the category string by joining the categories.
452      # and joining the categories.      my $cats = join(" ", @cats);
453      my $cats = join(" ", $options->{trace}, @cats);      # 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.      # Now set up the tracing.
484      TSetup($cats, "+>$FIG_Config::temp/trace.log");      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.      # Return the parsed parameters.
501      return ($retOptions, @retParameters);      return ($retOptions, @retParameters);
502  }  }
# Line 526  Line 666 
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<.>), dollar sign (C<$>),  set to TRUE, all filenames beginning with a period (C<.>), dollar sign (C<$>),
669  or pound sign (C<#>) will be filtered out of the return list. If the directory  or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be
670  does not open and I<$flag> is not set, an exception is thrown. So,  filtered out of the return list. If the directory does not open and I<$flag> is not
671  for example,  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    
# Line 573  Line 713 
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          }          }
# Line 916  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 1206  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 1221  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 1233  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 1258  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 1458  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 1473  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 1483  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 1518  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 1669  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            # Now output a GET-style URL for this query.
1963            my $getURL = $query->url(-relative => 1, -query => 1);
1964            # Strip out the Trace parameters.
1965            $getURL =~ s/Trace=\d[^;&]+[;&]//;
1966            $getURL =~ s/TF=\d[;&]//;
1967            # Output the URL.
1968            Trace("URL: ../FIG/$getURL");
1969            # Display the request method.
1970            my $method = $query->request_method();
1971            Trace("Method: $method");
1972        }
1973        if (T(CGI => 4)) {
1974            # Here we want the environment data too.
1975            for my $envName (sort keys %ENV) {
1976                Trace("ENV: $envName = $ENV{$envName}");
1977            }
1978        }
1979    }
1980    
1981    =head3 ScriptFinish
1982    
1983    C<< ScriptFinish($webData, $varHash); >>
1984    
1985    Output a web page at the end of a script. Either the string to be output or the
1986    name of a template file can be specified. If the second parameter is omitted,
1987    it is assumed we have a string to be output; otherwise, it is assumed we have the
1988    name of a template file. The template should have the variable C<DebugData>
1989    specified in any form that invokes a standard script. If debugging mode is turned
1990    on, a form field will be put in that allows the user to enter tracing data.
1991    Trace messages will be placed immediately before the terminal C<BODY> tag in
1992    the output, formatted as a list.
1993    
1994    A typical standard script would loook like the following.
1995    
1996        BEGIN {
1997            # Print the HTML header.
1998            print "CONTENT-TYPE: text/html\n\n";
1999        }
2000        use Tracer;
2001        use CGI;
2002        use FIG;
2003        # ... more uses ...
2004    
2005        my ($query, $varHash) = ScriptSetup();
2006        eval {
2007            # ... get data from $query, put it in $varHash ...
2008        };
2009        if ($@) {
2010            Trace("Script Error: $@") if T(0);
2011        }
2012        ScriptFinish("Html/MyTemplate.html", $varHash);
2013    
2014    The idea here is that even if the script fails, you'll see trace messages and
2015    useful output.
2016    
2017    =over 4
2018    
2019    =item webData
2020    
2021    A string containing either the full web page to be written to the output or the
2022    name of a template file from which the page is to be constructed. If the name
2023    of a template file is specified, then the second parameter must be present;
2024    otherwise, it must be absent.
2025    
2026    =item varHash (optional)
2027    
2028    If specified, then a reference to a hash mapping variable names for a template
2029    to their values. The template file will be read into memory, and variable markers
2030    will be replaced by data in this hash reference.
2031    
2032    =back
2033    
2034    =cut
2035    
2036    sub ScriptFinish {
2037        # Get the parameters.
2038        my ($webData, $varHash) = @_;
2039        # Check for a template file situation.
2040        my $outputString;
2041        if (defined $varHash) {
2042            # Here we have a template file. We need to determine the template type.
2043            my $template;
2044            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
2045                $template = "$FIG_Config::template_url/$webData";
2046            } else {
2047                $template = "<<$webData";
2048            }
2049            $outputString = PageBuilder::Build($template, $varHash, "Html");
2050        } else {
2051            # Here the user gave us a raw string.
2052            $outputString = $webData;
2053        }
2054        # Check for trace messages.
2055        if ($Destination eq "QUEUE") {
2056            # We have trace messages, so we want to put them at the end of the body. This
2057            # is either at the end of the whole string or at the beginning of the BODY
2058            # end-tag.
2059            my $pos = length $outputString;
2060            if ($outputString =~ m#</body>#gi) {
2061                $pos = (pos $outputString) - 7;
2062            }
2063            substr $outputString, $pos, 0, QTrace('Html');
2064        }
2065        # Write the output string.
2066        print $outputString;
2067    }
2068    
2069    =head3 Insure
2070    
2071    C<< Insure($dirName); >>
2072    
2073    Insure a directory is present.
2074    
2075    =over 4
2076    
2077    =item dirName
2078    
2079    Name of the directory to check. If it does not exist, it will be created.
2080    
2081    =back
2082    
2083    =cut
2084    
2085    sub Insure {
2086        my ($dirName) = @_;
2087        if (! -d $dirName) {
2088            Trace("Creating $dirName directory.") if T(2);
2089            eval { mkpath $dirName; };
2090            if ($@) {
2091                Confess("Error creating $dirName: $@");
2092            }
2093        }
2094    }
2095    
2096    =head3 ChDir
2097    
2098    C<< ChDir($dirName); >>
2099    
2100    Change to the specified directory.
2101    
2102    =over 4
2103    
2104    =item dirName
2105    
2106    Name of the directory to which we want to change.
2107    
2108    =back
2109    
2110    =cut
2111    
2112    sub ChDir {
2113        my ($dirName) = @_;
2114        if (! -d $dirName) {
2115            Confess("Cannot change to directory $dirName: no such directory.");
2116        } else {
2117            Trace("Changing to directory $dirName.") if T(4);
2118            my $okFlag = chdir $dirName;
2119            if (! $okFlag) {
2120                Confess("Error switching to directory $dirName.");
2121            }
2122        }
2123    }
2124    
2125    =head3 SendSMS
2126    
2127    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2128    
2129    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2130    user name, password, and API ID for the relevant account in the hash reference variable
2131    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2132    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2133    is C<2561022>, then the FIG_Config file must contain
2134    
2135        $phone =  { user => 'BruceTheHumanPet',
2136                    password => 'silly',
2137                    api_id => '2561022' };
2138    
2139    The original purpose of this method was to insure Bruce would be notified immediately when the
2140    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2141    when you call this method.
2142    
2143    The message ID will be returned if successful, and C<undef> if an error occurs.
2144    
2145    =over 4
2146    
2147    =item phoneNumber
2148    
2149    Phone number to receive the message, in international format. A United States phone number
2150    would be prefixed by "1". A British phone number would be prefixed by "44".
2151    
2152    =item msg
2153    
2154    Message to send to the specified phone.
2155    
2156    =item RETURN
2157    
2158    Returns the message ID if successful, and C<undef> if the message could not be sent.
2159    
2160    =back
2161    
2162    =cut
2163    
2164    sub SendSMS {
2165        # Get the parameters.
2166        my ($phoneNumber, $msg) = @_;
2167        # Declare the return variable. If we do not change it, C<undef> will be returned.
2168        my $retVal;
2169        # Only proceed if we have phone support.
2170        if (! defined $FIG_Config::phone) {
2171            Trace("Phone support not present in FIG_Config.") if T(1);
2172        } else {
2173            # Get the phone data.
2174            my $parms = $FIG_Config::phone;
2175            # Get the Clickatell URL.
2176            my $url = "http://api.clickatell.com/http/";
2177            # Create the user agent.
2178            my $ua = LWP::UserAgent->new;
2179            # Request a Clickatell session.
2180            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2181                                         password => $parms->{password},
2182                                         api_id => $parms->{api_id},
2183                                         to => $phoneNumber,
2184                                         text => $msg});
2185            # Check for an error.
2186            if (! $resp->is_success) {
2187                Trace("Alert failed.") if T(1);
2188            } else {
2189                # Get the message ID.
2190                my $rstring = $resp->content;
2191                if ($rstring =~ /^ID:\s+(.*)$/) {
2192                    $retVal = $1;
2193                } else {
2194                    Trace("Phone attempt failed with $rstring") if T(1);
2195                }
2196            }
2197        }
2198        # Return the result.
2199        return $retVal;
2200    }
2201    
2202    =head3 CommaFormat
2203    
2204    C<< my $formatted = Tracer::CommaFormat($number); >>
2205    
2206    Insert commas into a number.
2207    
2208    =over 4
2209    
2210    =item number
2211    
2212    A sequence of digits.
2213    
2214    =item RETURN
2215    
2216    Returns the same digits with commas strategically inserted.
2217    
2218    =back
2219    
2220    =cut
2221    
2222    sub CommaFormat {
2223        # Get the parameters.
2224        my ($number) = @_;
2225        # Pad the length up to a multiple of three.
2226        my $padded = "$number";
2227        $padded = " " . $padded while length($padded) % 3 != 0;
2228        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2229        # cause the delimiters to be included in the output stream. The
2230        # GREP removes the empty strings in between the delimiters.
2231        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2232        # Clean out the spaces.
2233        $retVal =~ s/ //g;
2234        # Return the result.
2235        return $retVal;
2236    }
2237    =head3 SetPermissions
2238    
2239    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2240    
2241    Set the permissions for a directory and all the files and folders inside it.
2242    In addition, the group ownership will be changed to the specified value.
2243    
2244    This method is more vulnerable than most to permission and compatability
2245    problems, so it does internal error recovery.
2246    
2247    =over 4
2248    
2249    =item dirName
2250    
2251    Name of the directory to process.
2252    
2253    =item group
2254    
2255    Name of the group to be assigned.
2256    
2257    =item mask
2258    
2259    Permission mask. Bits that are C<1> in this mask will be ORed into the
2260    permission bits of any file or directory that does not already have them
2261    set to 1.
2262    
2263    =item otherMasks
2264    
2265    Map of search patterns to permission masks. If a directory name matches
2266    one of the patterns, that directory and all its members and subdirectories
2267    will be assigned the new pattern. For example, the following would
2268    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2269    
2270        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2271    
2272    The list is ordered, so the following would use 0777 for C<tmp1> and
2273    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2274    
2275        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2276                                                       '^tmp' => 0666);
2277    
2278    Note that the pattern matches are all case-insensitive, and only directory
2279    names are matched, not file names.
2280    
2281    =back
2282    
2283    =cut
2284    
2285    sub SetPermissions {
2286        # Get the parameters.
2287        my ($dirName, $group, $mask, @otherMasks) = @_;
2288        # Set up for error recovery.
2289        eval {
2290            # Switch to the specified directory.
2291            ChDir($dirName);
2292            # Get the group ID.
2293            my $gid = getgrnam($group);
2294            # Get the mask for tracing.
2295            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2296            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2297            my $fixCount = 0;
2298            my $lookCount = 0;
2299            # @dirs will be a stack of directories to be processed.
2300            my @dirs = (getcwd());
2301            while (scalar(@dirs) > 0) {
2302                # Get the current directory.
2303                my $dir = pop @dirs;
2304                # Check for a match to one of the specified directory names. To do
2305                # that, we need to pull the individual part of the name off of the
2306                # whole path.
2307                my $simpleName = $dir;
2308                if ($dir =~ m!/([^/]+)$!) {
2309                    $simpleName = $1;
2310                }
2311                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2312                # Search for a match.
2313                my $match = 0;
2314                my $i;
2315                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2316                    my $pattern = $otherMasks[$i];
2317                    if ($simpleName =~ /$pattern/i) {
2318                        $match = 1;
2319                    }
2320                }
2321                # Check for a match. Note we use $i-1 because the loop added 2
2322                # before terminating due to the match.
2323                if ($match && $otherMasks[$i-1] != $mask) {
2324                    # This directory matches one of the incoming patterns, and it's
2325                    # a different mask, so we process it recursively with that mask.
2326                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2327                } else {
2328                    # Here we can process normally. Get all of the non-hidden members.
2329                    my @submems = OpenDir($dir, 1);
2330                    for my $submem (@submems) {
2331                        # Get the full name.
2332                        my $thisMem = "$dir/$submem";
2333                        Trace("Checking member $thisMem.") if T(4);
2334                        $lookCount++;
2335                        if ($lookCount % 1000 == 0) {
2336                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2337                        }
2338                        # Fix the group.
2339                        chown -1, $gid, $thisMem;
2340                        # Insure this member is not a symlink.
2341                        if (! -l $thisMem) {
2342                            # Get its info.
2343                            my $fileInfo = stat $thisMem;
2344                            # Only proceed if we got the info. Otherwise, it's a hard link
2345                            # and we want to skip it anyway.
2346                            if ($fileInfo) {
2347                                my $fileMode = $fileInfo->mode;
2348                                if (($fileMode & $mask) != $mask) {
2349                                    # Fix this member.
2350                                    $fileMode |= $mask;
2351                                    chmod $fileMode, $thisMem;
2352                                    $fixCount++;
2353                                }
2354                                # If it's a subdirectory, stack it.
2355                                if (-d $thisMem) {
2356                                    push @dirs, $thisMem;
2357                                }
2358                            }
2359                        }
2360                    }
2361                }
2362            }
2363            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2364        };
2365        # Check for an error.
2366        if ($@) {
2367            Confess("SetPermissions error: $@");
2368        }
2369    }
2370    
2371    =head3 CompareLists
2372    
2373    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2374    
2375    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2376    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2377    The return value contains a list of items that are only in the new list
2378    (inserted) and only in the old list (deleted).
2379    
2380    =over 4
2381    
2382    =item newList
2383    
2384    Reference to a list of new tuples.
2385    
2386    =item oldList
2387    
2388    Reference to a list of old tuples.
2389    
2390    =item keyIndex (optional)
2391    
2392    Index into each tuple of its key field. The default is 0.
2393    
2394    =item RETURN
2395    
2396    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2397    list (inserted) followed by a reference to the list of items that are only in the old
2398    list (deleted).
2399    
2400    =back
2401    
2402    =cut
2403    
2404    sub CompareLists {
2405        # Get the parameters.
2406        my ($newList, $oldList, $keyIndex) = @_;
2407        if (! defined $keyIndex) {
2408            $keyIndex = 0;
2409        }
2410        # Declare the return variables.
2411        my ($inserted, $deleted) = ([], []);
2412        # Loop through the two lists simultaneously.
2413        my ($newI, $oldI) = (0, 0);
2414        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2415        while ($newI < $newN || $oldI < $oldN) {
2416            # Get the current object in each list. Note that if one
2417            # of the lists is past the end, we'll get undef.
2418            my $newItem = $newList->[$newI];
2419            my $oldItem = $oldList->[$oldI];
2420            if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2421                # The old item is not in the new list, so mark it deleted.
2422                push @{$deleted}, $oldItem;
2423                $oldI++;
2424            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2425                # The new item is not in the old list, so mark it inserted.
2426                push @{$inserted}, $newItem;
2427                $newI++;
2428            } else {
2429                # The item is in both lists, so push forward.
2430                $oldI++;
2431                $newI++;
2432            }
2433        }
2434        # Return the result.
2435        return ($inserted, $deleted);
2436    }
2437    
2438    =head3 GetLine
2439    
2440    C<< my @data = Tracer::GetLine($handle); >>
2441    
2442    Read a line of data from a tab-delimited file.
2443    
2444    =over 4
2445    
2446    =item handle
2447    
2448    Open file handle from which to read.
2449    
2450    =item RETURN
2451    
2452    Returns a list of the fields in the record read. The fields are presumed to be
2453    tab-delimited. If we are at the end of the file, then an empty list will be
2454    returned. If an empty line is read, a single list item consisting of a null
2455    string will be returned.
2456    
2457    =back
2458    
2459    =cut
2460    
2461    sub GetLine {
2462        # Get the parameters.
2463        my ($handle) = @_;
2464        # Declare the return variable.
2465        my @retVal = ();
2466        # Read from the file.
2467        my $line = <$handle>;
2468        # Only proceed if we found something.
2469        if (defined $line) {
2470            # Remove the new-line.
2471            chomp $line;
2472            # If the line is empty, return a single empty string; otherwise, parse
2473            # it into fields.
2474            if ($line eq "") {
2475                push @retVal, "";
2476            } else {
2477                push @retVal, split /\t/,$line;
2478            }
2479        }
2480        # Return the result.
2481        return @retVal;
2482    }
2483    
2484    =head3 PutLine
2485    
2486    C<< Tracer::PutLine($handle, \@fields); >>
2487    
2488    Write a line of data to a tab-delimited file. The specified field values will be
2489    output in tab-separated form, with a trailing new-line.
2490    
2491    =over 4
2492    
2493    =item handle
2494    
2495    Output file handle.
2496    
2497    =item fields
2498    
2499    List of field values.
2500    
2501    =back
2502    
2503    =cut
2504    
2505    sub PutLine {
2506        # Get the parameters.
2507        my ($handle, $fields) = @_;
2508        # Write the data.
2509        print $handle join("\t", @{$fields}) . "\n";
2510    }
2511    
2512    =head3 GenerateURL
2513    
2514    C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >>
2515    
2516    Generate a GET-style URL for the specified page with the specified parameter
2517    names and values. The values will be URL-escaped automatically. So, for
2518    example
2519    
2520        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
2521    
2522    would return
2523    
2524        form.cgi?type=1&string=%22high%20pass%22%20or%20highway
2525    
2526    =over 4
2527    
2528    =item page
2529    
2530    Page URL.
2531    
2532    =item parameters
2533    
2534    Hash mapping parameter names to parameter values.
2535    
2536    =item RETURN
2537    
2538    Returns a GET-style URL that goes to the specified page and passes in the
2539    specified parameters and values.
2540    
2541    =back
2542    
2543    =cut
2544    
2545    sub GenerateURL {
2546        # Get the parameters.
2547        my ($page, %parameters) = @_;
2548        # Prime the return variable with the page URL.
2549        my $retVal = $page;
2550        # Loop through the parameters, creating parameter elements in a list.
2551        my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
2552        # If the list is nonempty, tack it on.
2553        if (@parmList) {
2554            $retVal .= "?" . join("&", @parmList);
2555        }
2556        # Return the result.
2557        return $retVal;
2558    }
2559    
2560  1;  1;

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.67

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3