[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.45, Mon May 8 20:37:02 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);
# Line 27  Line 27 
27      use FIG_Config;      use FIG_Config;
28      use PageBuilder;      use PageBuilder;
29      use Digest::MD5;      use Digest::MD5;
30        use File::Basename;
31        use File::Path;
32    
33  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
34    
# Line 174  Line 176 
176      # Presume category-based tracing until we learn otherwise.      # Presume category-based tracing until we learn otherwise.
177      $AllTrace = 0;      $AllTrace = 0;
178      # 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
179      # tracing.      # tracing. We must also clear away any pre-existing data.
180        %Categories = ( main => 1 );
181      for my $category (@categoryData) {      for my $category (@categoryData) {
182          if ($category eq '*') {          if ($category eq '*') {
183              $AllTrace = 1;              $AllTrace = 1;
# Line 207  Line 210 
210    
211  =head3 StandardSetup  =head3 StandardSetup
212    
213  C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, @ARGV); >>  C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
214    
215  This method performs standard command-line parsing and tracing setup. The return  This method performs standard command-line parsing and tracing setup. The return
216  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 257 
257      TransactFeatures -trace=3 -sql register ../xacts IDs.tbl      TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
258    
259  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
260  C<trace.log> in the FIG temporary directory.  C<trace>I<$$>C<.log> in the FIG temporary directory, where I<$$> is the
261    process ID. You can also specify the C<user> parameter to put a user ID
262    instead of a process ID in the trace file name. So, for example
263    
264  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.
265  is turned on and tends to produce one flurry of messages per genome. To get all  For a genome-by-genome update, use 3.
266  messages, specify a trace level of 4. For generally quiet output, use 2.  
267        TransactFeatures -trace=3 -sql -user=Bruce register ../xacts IDs.tbl
268    
269    would send the trace output to C<traceBruce.log> in the temporary directory.
270    
271  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
272  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
273  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
274  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
275  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
276    can see this last in the command-line example above.
277    
278    You can specify a different default trace level by setting C<$options->{trace}>
279    prior to calling this method.
280    
281  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
282  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 284 
284  the following code.  the following code.
285    
286      my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],      my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
287                                                        { trace => 3, sql => 0,                          { safe => [0, "use database transactions"],
288                                                          safe => 0, noAlias => 0,                            noAlias => [0, "do not expect aliases in CHANGE transactions"],
289                                                          start => ' ', tblFiles => 0},                            start => [' ', "start with this genome"],
290                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
291                            "command transactionDirectory IDfile",
292                                                      @ARGV);                                                      @ARGV);
293    
294    
# Line 303  Line 317 
317  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
318  upsetting the command-line utilities.  upsetting the command-line utilities.
319    
320    If the C<background> option is specified on the command line, then the
321    standard and error outputs will be directed to files in the temporary
322    directory, using the same suffix as the trace file. So, if the command
323    line specified
324    
325        -user=Bruce -background
326    
327    then the trace output would go to C<traceBruce.log>, the standard output to
328    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
329    simplify starting a command in the background.
330    
331    Finally, if the special option C<-h> is specified, the option names will
332    be traced at level 0 and the program will exit without processing.
333    This provides a limited help capability. For example, if the user enters
334    
335        TransactFeatures -h
336    
337    he would see the following output.
338    
339        TransactFeatures [options] command transactionDirectory IDfile
340            -trace    tracing level (default 2)
341            -sql      trace SQL commands
342            -safe     use database transactions
343            -noAlias  do not expect aliases in CHANGE transactions
344            -start    start with this genome
345            -tblFiles output TBL files containing the corrected IDs
346    
347    The caller has the option of modifying the tracing scheme by placing a value
348    for C<trace> in the incoming options hash. The default value can be overridden,
349    or the tracing to the standard output can be turned off by suffixing a minus
350    sign to the trace level. So, for example,
351    
352        { trace => [0, "tracing level (default 0)"],
353           ...
354    
355    would set the default trace level to 0 instead of 2, while
356    
357        { trace => ["2-", "tracing level (default 2)"],
358           ...
359    
360    would leave the default at 2, but trace only to the log file, not to the
361    standard output.
362    
363  The parameters to this method are as follows.  The parameters to this method are as follows.
364    
365  =over 4  =over 4
# Line 316  Line 373 
373  =item options  =item options
374    
375  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
376  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
377  options as command-line switches prefixed by a hyphen. Tracing-related options  by specifying the options as command-line switches prefixed by a hyphen.
378  may be added to this hash.  Tracing-related options may be added to this hash. If the C<-h> option is
379    specified on the command line, the option descriptions will be used to
380    explain the options. To turn off tracing to the standard output, add a
381    minus sign to the value for C<trace> (see above).
382    
383    =item parmHelp
384    
385  =item ARGV  A string that vaguely describes the positional parameters. This is used
386    if the user specifies the C<-h> option.
387    
388    =item argv
389    
390  List of command line parameters, including the option switches, which must  List of command line parameters, including the option switches, which must
391  precede the positional parameters and be prefixed by a hyphen.  precede the positional parameters and be prefixed by a hyphen.
# Line 338  Line 403 
403    
404  sub StandardSetup {  sub StandardSetup {
405      # Get the parameters.      # Get the parameters.
406      my ($categories, $options, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
407      # Add the tracing options.      # Add the tracing options.
408      $options->{trace} = 3;      if (! exists $options->{trace}) {
409      $options->{sql} = 0;          $options->{trace} = [2, "tracing level"];
410        }
411        $options->{sql} = [0, "turn on SQL tracing"];
412        $options->{h} = [0, "display command-line options"];
413        $options->{user} = [$$, "trace log file name suffix"];
414        $options->{background} = [0, "spool standard and error output"];
415        # Create a parsing hash from the options hash. The parsing hash
416        # contains the default values rather than the default value
417        # and the description. While we're at it, we'll memorize the
418        # length of the longest option name.
419        my $longestName = 0;
420        my %parseOptions = ();
421        for my $key (keys %{$options}) {
422            if (length $key > $longestName) {
423                $longestName = length $key;
424            }
425            $parseOptions{$key} = $options->{$key}->[0];
426        }
427      # Parse the command line.      # Parse the command line.
428      my ($retOptions, @retParameters) = ParseCommand($options, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
429        # Get the logfile suffix.
430        my $suffix = $retOptions->{user};
431        # Check for background mode.
432        if ($retOptions->{background}) {
433            my $outFileName = "$FIG_Config::temp/out$suffix.log";
434            my $errFileName = "$FIG_Config::temp/err$suffix.log";
435            open STDOUT, ">$outFileName";
436            open STDERR, ">$errFileName";
437        }
438      # 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
439      # be traced.      # be traced.
440      my @cats = @{$categories};      my @cats = @{$categories};
# Line 352  Line 443 
443      }      }
444      # Add the default categories.      # Add the default categories.
445      push @cats, "Tracer", "FIG";      push @cats, "Tracer", "FIG";
446      # Next, we create the category string by prefixing the trace level      # Next, we create the category string by joining the categories.
447      # and joining the categories.      my $cats = join(" ", @cats);
448      my $cats = join(" ", $options->{trace}, @cats);      # Check to determine whether or not the caller wants to turn off tracing
449        # to the standard output.
450        my $traceLevel = $retOptions->{trace};
451        my $textOKFlag = 1;
452        if ($traceLevel =~ /^(.)-/) {
453            $traceLevel = $1;
454            $textOKFlag = 0;
455        }
456        # Now we set up the trace mode.
457        my $traceMode;
458        # Verify that we can open a file in the FIG temporary directory.
459        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
460        if (open TESTTRACE, ">$traceFileName") {
461            # Here we can trace to a file.
462            $traceMode = ">$traceFileName";
463            if ($textOKFlag) {
464                # Echo to standard output if the text-OK flag is set.
465                $traceMode = "+$traceMode";
466            }
467            # Close the test file.
468            close TESTTRACE;
469        } else {
470            # Here we can't trace to a file. We trace to the standard output if it's
471            # okay, and the error log otherwise.
472            if ($textOKFlag) {
473                $traceMode = "TEXT";
474            } else {
475                $traceMode = "WARN";
476            }
477        }
478      # Now set up the tracing.      # Now set up the tracing.
479      TSetup($cats, "+>$FIG_Config::temp/trace.log");      TSetup("$traceLevel $cats", $traceMode);
480        # Check for the "h" option. If it is specified, dump the command-line
481        # options and exit the program.
482        if ($retOptions->{h}) {
483            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
484            Trace("$1 [options] $parmHelp") if T(0);
485            for my $key (sort keys %{$options}) {
486                my $name = Pad($key, $longestName, 0, ' ');
487                my $desc = $options->{$key}->[1];
488                if ($options->{$key}->[0]) {
489                    $desc .= " (default " . $options->{$key}->[0] . ")";
490                }
491                Trace("  $name $desc") if T(0);
492            }
493            exit(0);
494        }
495      # Return the parsed parameters.      # Return the parsed parameters.
496      return ($retOptions, @retParameters);      return ($retOptions, @retParameters);
497  }  }
# Line 526  Line 661 
661  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
662  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
663  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<$>),
664  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
665  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
666  for example,  set, an exception is thrown. So, for example,
667    
668      my @files = OpenDir("/Volumes/fig/contigs", 1);      my @files = OpenDir("/Volumes/fig/contigs", 1);
669    
670  is effectively the same as  is effectively the same as
671    
672      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
673      my @files = grep { $_ !~ /^[\.\$\#]/ } readdir(TMP);      my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
674    
675  Similarly, the following code  Similarly, the following code
676    
# Line 573  Line 708 
708          # The directory opened successfully. Get the appropriate list according to the          # The directory opened successfully. Get the appropriate list according to the
709          # strictures of the filter parameter.          # strictures of the filter parameter.
710          if ($filtered) {          if ($filtered) {
711              @retVal = grep { $_ !~ /^[\.\$\#]/ } readdir $dirHandle;              @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
712          } else {          } else {
713              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
714          }          }
# Line 916  Line 1051 
1051          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
1052          $category = lc $category;          $category = lc $category;
1053          # Use the category and tracelevel to compute the result.          # Use the category and tracelevel to compute the result.
1054            if (ref $traceLevel) {
1055                Confess("Bad trace level.");
1056            } elsif (ref $TraceLevel) {
1057                Confess("Bad trace config.");
1058            }
1059          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
1060      }      }
1061      # Return the computed result.      # Return the computed result.
# Line 1210  Line 1350 
1350    
1351  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1352    
1353  Return the entire contents of a file.      or
1354    
1355    C<< my $fileContents = Tracer::GetFile($fileName); >>
1356    
1357    Return the entire contents of a file. In list context, line-ends are removed and
1358    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1359    
1360  =over 4  =over 4
1361    
# Line 1221  Line 1366 
1366  =item RETURN  =item RETURN
1367    
1368  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.
1369  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
1370    the file, an empty list will be returned.
1371    
1372  =back  =back
1373    
# Line 1669  Line 1815 
1815      return `$commandString`;      return `$commandString`;
1816  }  }
1817    
1818    =head3 ScriptSetup
1819    
1820    C<< my ($query, $varHash) = ScriptSetup(); >>
1821    
1822    Perform standard tracing and debugging setup for scripts. The value returned is
1823    the CGI object followed by a pre-built variable hash.
1824    
1825    The C<Trace> query parameter is used to determine whether or not tracing is active and
1826    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1827    the C<CGI> trace module will trace parameter and environment information. Parameters are
1828    traced at level 3 and environment variables at level 4. At the end of the script, the
1829    client should call L</ScriptFinish> to output the web page.
1830    
1831    =cut
1832    
1833    sub ScriptSetup {
1834        # Get the CGI query object.
1835        my $query = CGI->new();
1836        # Check for tracing. Set it up if the user asked for it.
1837        if ($query->param('Trace')) {
1838            # Set up tracing to be queued for display at the bottom of the web page.
1839            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1840            # Trace the parameter and environment data.
1841            if (T(CGI => 3)) {
1842                # Here we want to trace the parameter data.
1843                my @names = $query->param;
1844                for my $parmName (sort @names) {
1845                    # Note we skip "Trace", which is for our use only.
1846                    if ($parmName ne 'Trace') {
1847                        my @values = $query->param($parmName);
1848                        Trace("CGI: $parmName = " . join(", ", @values));
1849                    }
1850                }
1851            }
1852            if (T(CGI => 4)) {
1853                # Here we want the environment data too.
1854                for my $envName (sort keys %ENV) {
1855                    Trace("ENV: $envName = $ENV{$envName}");
1856                }
1857            }
1858        } else {
1859            # Here tracing is to be turned off. All we allow is errors traced into the
1860            # error log.
1861            TSetup("0", "WARN");
1862        }
1863        # Create the variable hash.
1864        my $varHash = { DebugData => '' };
1865        # If we're in DEBUG mode, set up the debug mode data for forms.
1866        if (Tracer::DebugMode) {
1867            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1868        }
1869        # Return the query object and variable hash.
1870        return ($query, $varHash);
1871    }
1872    
1873    =head3 ScriptFinish
1874    
1875    C<< ScriptFinish($webData, $varHash); >>
1876    
1877    Output a web page at the end of a script. Either the string to be output or the
1878    name of a template file can be specified. If the second parameter is omitted,
1879    it is assumed we have a string to be output; otherwise, it is assumed we have the
1880    name of a template file. The template should have the variable C<DebugData>
1881    specified in any form that invokes a standard script. If debugging mode is turned
1882    on, a form field will be put in that allows the user to enter tracing data.
1883    Trace messages will be placed immediately before the terminal C<BODY> tag in
1884    the output, formatted as a list.
1885    
1886    A typical standard script would loook like the following.
1887    
1888        BEGIN {
1889            # Print the HTML header.
1890            print "CONTENT-TYPE: text/html\n\n";
1891        }
1892        use Tracer;
1893        use CGI;
1894        use FIG;
1895        # ... more uses ...
1896    
1897        my ($query, $varHash) = ScriptSetup();
1898        eval {
1899            # ... get data from $query, put it in $varHash ...
1900        };
1901        if ($@) {
1902            Trace("Script Error: $@") if T(0);
1903        }
1904        ScriptFinish("Html/MyTemplate.html", $varHash);
1905    
1906    The idea here is that even if the script fails, you'll see trace messages and
1907    useful output.
1908    
1909    =over 4
1910    
1911    =item webData
1912    
1913    A string containing either the full web page to be written to the output or the
1914    name of a template file from which the page is to be constructed. If the name
1915    of a template file is specified, then the second parameter must be present;
1916    otherwise, it must be absent.
1917    
1918    =item varHash (optional)
1919    
1920    If specified, then a reference to a hash mapping variable names for a template
1921    to their values. The template file will be read into memory, and variable markers
1922    will be replaced by data in this hash reference.
1923    
1924    =back
1925    
1926    =cut
1927    
1928    sub ScriptFinish {
1929        # Get the parameters.
1930        my ($webData, $varHash) = @_;
1931        # Check for a template file situation.
1932        my $outputString;
1933        if (defined $varHash) {
1934            # Here we have a template file. We need to apply the variables to the template.
1935            $outputString = PageBuilder::Build("<$webData", $varHash, "Html");
1936        } else {
1937            # Here the user gave us a raw string.
1938            $outputString = $webData;
1939        }
1940        # Check for trace messages.
1941        if ($Destination eq "QUEUE") {
1942            # We have trace messages, so we want to put them at the end of the body. This
1943            # is either at the end of the whole string or at the beginning of the BODY
1944            # end-tag.
1945            my $pos = length $outputString;
1946            if ($outputString =~ m#</body>#gi) {
1947                $pos = (pos $outputString) - 7;
1948            }
1949            substr $outputString, $pos, 0, QTrace('Html');
1950        }
1951        # Write the output string.
1952        print $outputString;
1953    }
1954    
1955    =head3 Insure
1956    
1957    C<< Insure($dirName); >>
1958    
1959    Insure a directory is present.
1960    
1961    =over 4
1962    
1963    =item dirName
1964    
1965    Name of the directory to check. If it does not exist, it will be created.
1966    
1967    =back
1968    
1969    =cut
1970    
1971    sub Insure {
1972        my ($dirName) = @_;
1973        if (! -d $dirName) {
1974            Trace("Creating $dirName directory.") if T(2);
1975            eval { mkpath $dirName; };
1976            if ($@) {
1977                Confess("Error creating $dirName: $@");
1978            }
1979        }
1980    }
1981    
1982    =head3 ChDir
1983    
1984    C<< ChDir($dirName); >>
1985    
1986    Change to the specified directory.
1987    
1988    =over 4
1989    
1990    =item dirName
1991    
1992    Name of the directory to which we want to change.
1993    
1994    =back
1995    
1996    =cut
1997    
1998    sub ChDir {
1999        my ($dirName) = @_;
2000        if (! -d $dirName) {
2001            Confess("Cannot change to directory $dirName: no such directory.");
2002        } else {
2003            Trace("Changing to directory $dirName.") if T(4);
2004            my $okFlag = chdir $dirName;
2005            if (! $okFlag) {
2006                Confess("Error switching to directory $dirName.");
2007            }
2008        }
2009    }
2010    
2011  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3