[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.37, Fri Feb 17 00:26:23 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);
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 10  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 72  Line 91 
91    
92  =over 4  =over 4
93    
94  =item 0 Error  =item Error 0
95    
96  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
97  application entirely.  application entirely.
98    
99  =item 1 Warning  =item Warning 1
100    
101  Message indicates something that is unexpected but that probably did not interfere  Message indicates something that is unexpected but that probably did not interfere
102  with program execution.  with program execution.
103    
104  =item 2 Notice  =item Notice 2
105    
106  Message indicates the beginning or end of a major task.  Message indicates the beginning or end of a major task.
107    
108  =item 3 Information  =item Information 3
109    
110  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
111  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.
112    
113  =item 4 Detail  =item Detail 4
114    
115  Message indicates a low-level loop iteration.  Message indicates a low-level loop iteration.
116    
# Line 157  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 188  Line 208 
208      $SetupCount++;      $SetupCount++;
209  }  }
210    
211    =head3 StandardSetup
212    
213    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>
214    
215    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
217    parameters. Tracing is automatically set up and the command-line options are
218    validated.
219    
220    This is a complex method that does a lot of grunt work. The parameters can
221    be more easily understood, however, once they are examined individually.
222    
223    The I<categories> parameter is the most obtuse. It is a reference to a list of
224    special-purpose tracing categories. Most tracing categories are PERL package
225    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
226    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
227    
228        ["Sprout", "SproutLoad", "ERDB"]
229    
230    This would cause trace messages in the specified three packages to appear in
231    the output. There are threer special tracing categories that are automatically
232    handled by this method. In other words, if you used L</TSetup> you would need
233    to include these categories manually, but if you use this method they are turned
234    on automatically.
235    
236    =over 4
237    
238    =item FIG
239    
240    Turns on trace messages inside the B<FIG> package.
241    
242    =item SQL
243    
244    Traces SQL commands and activity.
245    
246    =item Tracer
247    
248    Traces error messages and call stacks.
249    
250    =back
251    
252    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
253    The trace level is specified using the C<-trace> command-line option. For example,
254    the following command line for C<TransactFeatures> turns on SQL tracing and runs
255    all tracing at level 3.
256    
257        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
258    
259    Standard tracing is output to the standard output and echoed to the file
260    C<trace.log> in the FIG temporary directory.
261    
262    The default trace level is 2. To get all messages, specify a trace level of 4.
263    For a genome-by-genome update, use 3.
264    
265    The I<options> parameter is a reference to a hash containing the command-line
266    options, their default values, and an explanation of what they mean. Command-line
267    options may be in the form of switches or keywords. In the case of a switch, the
268    option value is 1 if it is specified and 0 if it is not specified. In the case
269    of a keyword, the value is separated from the option name by an equal sign. You
270    can see this last in the command-line example above.
271    
272    An example at this point would help. Consider, for example, the command-line utility
273    C<TransactFeatures>. It accepts a list of positional parameters plus the options
274    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
275    the following code.
276    
277        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
278                            { safe => [0, "use database transactions"],
279                              noAlias => [0, "do not expect aliases in CHANGE transactions"],
280                              start => [' ', "start with this genome"],
281                              tblFiles => [0, "output TBL files containing the corrected IDs"] },
282                            "command transactionDirectory IDfile",
283                          @ARGV);
284    
285    
286    The call to C<ParseCommand> specifies the default values for the options and
287    stores the actual options in a hash that is returned as C<$options>. The
288    positional parameters are returned in C<@parameters>.
289    
290    The following is a sample command line for C<TransactFeatures>.
291    
292        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
293    
294    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
295    parameters, and would find themselves in I<@parameters> after executing the
296    above code fragment. The tracing would be set to level 2, and the categories
297    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
298    and C<DocUtils> was included because it came in within the first parameter
299    to this method. The I<$options> hash would be
300    
301        { trace => 2, sql => 0, safe => 0,
302          noAlias => 1, start => ' ', tblFiles => 0 }
303    
304    Use of C<StandardSetup> in this way provides a simple way of performing
305    standard tracing setup and command-line parsing. Note that the caller is
306    not even aware of the command-line switches C<-trace> and C<-sql>, which
307    are used by this method to control the tracing. If additional tracing features
308    need to be added in the future, they can be processed by this method without
309    upsetting the command-line utilities.
310    
311    Finally, if the special option C<-h> is specified, the option names will
312    be traced at level 0 and the program will exit without processing.
313    This provides a limited help capability. For example, if the user enters
314    
315        TransactFeatures -h
316    
317    he would see the following output.
318    
319        TransactFeatures [options] command transactionDirectory IDfile
320            -trace    tracing level (default 2)
321            -sql      trace SQL commands
322            -safe     use database transactions
323            -noAlias  do not expect aliases in CHANGE transactions
324            -start    start with this genome
325            -tblFiles output TBL files containing the corrected IDs
326    
327    The parameters to this method are as follows.
328    
329    =over 4
330    
331    =item categories
332    
333    Reference to a list of tracing category names. These should be names of
334    packages whose internal workings will need to be debugged to get the
335    command working.
336    
337    =item options
338    
339    Reference to a hash containing the legal options for the current command mapped
340    to their default values and descriptions. The user can override the defaults
341    by specifying the options as command-line switches prefixed by a hyphen.
342    Tracing-related options may be added to this hash. If the C<-h> option is
343    specified on the command line, the option descriptions will be used to
344    explain the options.
345    
346    =item parmHelp
347    
348    A string that vaguely describes the positional parameters. This is used
349    if the user specifies the C<-h> option.
350    
351    =item ARGV
352    
353    List of command line parameters, including the option switches, which must
354    precede the positional parameters and be prefixed by a hyphen.
355    
356    =item RETURN
357    
358    Returns a list. The first element of the list is the reference to a hash that
359    maps the command-line option switches to their values. These will either be the
360    default values or overrides specified on the command line. The remaining
361    elements of the list are the position parameters, in order.
362    
363    =back
364    
365    =cut
366    
367    sub StandardSetup {
368        # Get the parameters.
369        my ($categories, $options, $parmHelp, @argv) = @_;
370        # Add the tracing options.
371        $options->{trace} = [2, "tracing level"];
372        $options->{sql} = [0, "turn on SQL tracing"];
373        $options->{h} = [0, "display command-line options"];
374        # Create a parsing hash from the options hash. The parsing hash
375        # contains the default values rather than the default value
376        # and the description. While we're at it, we'll memorize the
377        # length of the longest option name.
378        my $longestName = 0;
379        my %parseOptions = ();
380        for my $key (keys %{$options}) {
381            if (length $key > $longestName) {
382                $longestName = length $key;
383            }
384            $parseOptions{$key} = $options->{$key}->[0];
385        }
386        # Parse the command line.
387        my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
388        # Now we want to set up tracing. First, we need to know if SQL is to
389        # be traced.
390        my @cats = @{$categories};
391        if ($retOptions->{sql}) {
392            push @cats, "SQL";
393        }
394        # Add the default categories.
395        push @cats, "Tracer", "FIG";
396        # Next, we create the category string by prefixing the trace level
397        # and joining the categories.
398        my $cats = join(" ", $parseOptions{trace}, @cats);
399        # Now set up the tracing.
400        TSetup($cats, "+>$FIG_Config::temp/trace.log");
401        # Check for the "h" option. If it is specified, dump the command-line
402        # options and exit the program.
403        if ($retOptions->{h}) {
404            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
405            Trace("$1 [options] $parmHelp") if T(0);
406            for my $key (sort keys %{$options}) {
407                my $name = Pad($key, $longestName, 0, ' ');
408                my $desc = $options->{$key}->[1];
409                if ($options->{$key}->[0]) {
410                    $desc .= " (default " . $options->{$key}->[0] . ")";
411                }
412                Trace("  $name $desc") if T(0);
413            }
414            exit(0);
415        }
416        # Return the parsed parameters.
417        return ($retOptions, @retParameters);
418    }
419    
420  =head3 Setups  =head3 Setups
421    
422  C<< my $count = Tracer::Setups(); >>  C<< my $count = Tracer::Setups(); >>
# Line 348  Line 577 
577    
578  =head3 OpenDir  =head3 OpenDir
579    
580  C<< my @files = OpenDir($dirName, $filtered); >>  C<< my @files = OpenDir($dirName, $filtered, $flag); >>
581    
582  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
583  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
584  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<$>),
585  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
586  for example,  filtered out of the return list. If the directory does not open and I<$flag> is not
587    set, an exception is thrown. So, for example,
588    
589      my @files = OpenDir("/Volumes/fig/contigs", 1);      my @files = OpenDir("/Volumes/fig/contigs", 1);
590    
591  is effectively the same as  is effectively the same as
592    
593      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
594      my @files = grep { $_ !~ /^\./ } readdir(TMP);      my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
595    
596  Similarly, the following code  Similarly, the following code
597    
598      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs");      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
599    
600  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
601  automatically throws an error if the directory fails to open.  automatically returns an empty list if the directory fails to open.
602    
603  =over 4  =over 4
604    
# Line 381  Line 611 
611  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
612  from the list, else FALSE.  from the list, else FALSE.
613    
614    =item flag
615    
616    TRUE if a failure to open is okay, else FALSE
617    
618  =back  =back
619    
620  =cut  =cut
621  #: Return Type @;  #: Return Type @;
622  sub OpenDir {  sub OpenDir {
623      # Get the parameters.      # Get the parameters.
624      my ($dirName, $filtered) = @_;      my ($dirName, $filtered, $flag) = @_;
625      # Declare the return variable.      # Declare the return variable.
626      my @retVal;      my @retVal = ();
627      # Open the directory.      # Open the directory.
628      if (opendir(my $dirHandle, $dirName)) {      if (opendir(my $dirHandle, $dirName)) {
629          # The directory opened successfully. Get the appropriate list according to the          # The directory opened successfully. Get the appropriate list according to the
630          # strictures of the filter parameter.          # strictures of the filter parameter.
631          if ($filtered) {          if ($filtered) {
632              @retVal = grep { $_ !~ /^\./ } readdir $dirHandle;              @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
633          } else {          } else {
634              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
635          }          }
636      } else {      } elsif (! $flag) {
637          # Here the directory would not open.          # Here the directory would not open and it's considered an error.
638          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
639      }      }
640      # Return the result.      # Return the result.
# Line 738  Line 972 
972          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
973          $category = lc $category;          $category = lc $category;
974          # Use the category and tracelevel to compute the result.          # Use the category and tracelevel to compute the result.
975            if (ref $traceLevel) {
976                Confess("Bad trace level.");
977            } elsif (ref $TraceLevel) {
978                Confess("Bad trace config.");
979            }
980          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
981      }      }
982      # Return the computed result.      # Return the computed result.
# Line 825  Line 1064 
1064  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1065    
1066  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
1067  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
1068  effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1069    
1070  =over 4  =over 4
1071    
# Line 850  Line 1089 
1089      # Loop through the parameter string, looking for sequences to escape.      # Loop through the parameter string, looking for sequences to escape.
1090      while (length $realString > 0) {      while (length $realString > 0) {
1091          # Look for the first sequence to escape.          # Look for the first sequence to escape.
1092          if ($realString =~ /^(.*?)([\n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1093              # 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
1094              # 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.
1095              $retVal .= $1;              $retVal .= $1;
1096              # Strip the processed section off the real string.              # Strip the processed section off the real string.
1097              $realString = substr $realString, (length $2) + (length $1);              $realString = substr $realString, (length $2) + (length $1);
1098              # Encode the escape sequence.              # Get the matched character.
1099              my $char = $2;              my $char = $2;
1100                # If we have a CR, we are done.
1101                if ($char ne "\r") {
1102                    # It's not a CR, so encode the escape sequence.
1103              $char =~ tr/\t\n/tn/;              $char =~ tr/\t\n/tn/;
1104              $retVal .= "\\" . $char;              $retVal .= "\\" . $char;
1105                }
1106          } else {          } else {
1107              # 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
1108              # transferred unmodified.              # transferred unmodified.
# Line 876  Line 1119 
1119  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1120    
1121  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
1122  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
1123    be deleted.
1124    
1125  =over 4  =over 4
1126    
# Line 905  Line 1149 
1149          # "\<tab>" no matter what we do.)          # "\<tab>" no matter what we do.)
1150          while (length $codedString > 0) {          while (length $codedString > 0) {
1151              # Look for the first escape sequence.              # Look for the first escape sequence.
1152              if ($codedString =~ /^(.*?)\\(\\|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1153                  # 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
1154                  # 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.
1155                  $retVal .= $1;                  $retVal .= $1;
1156                  $codedString = substr $codedString, (2 + length $1);                  $codedString = substr $codedString, (2 + length $1);
1157                  # Decode the escape sequence.                  # Get the escape value.
1158                  my $char = $2;                  my $char = $2;
1159                    # If we have a "\r", we are done.
1160                    if ($char ne 'r') {
1161                        # Here it's not an 'r', so we convert it.
1162                  $char =~ tr/\\tn/\\\t\n/;                  $char =~ tr/\\tn/\\\t\n/;
1163                  $retVal .= $char;                  $retVal .= $char;
1164                    }
1165              } else {              } else {
1166                  # 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
1167                  # transferred unmodified.                  # transferred unmodified.
# Line 1023  Line 1271 
1271    
1272  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
1273    
1274  Return the entire contents of a file.      or
1275    
1276    C<< my $fileContents = Tracer::GetFile($fileName); >>
1277    
1278    Return the entire contents of a file. In list context, line-ends are removed and
1279    each line is a list element. In scalar context, line-ends are replaced by C<\n>.
1280    
1281  =over 4  =over 4
1282    
# Line 1150  Line 1403 
1403  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1404    
1405  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
1406  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.
1407  So, for example  So, for example
1408    
1409  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1363  Line 1616 
1616  sub Strip {  sub Strip {
1617      # Get a copy of the parameter string.      # Get a copy of the parameter string.
1618      my ($string) = @_;      my ($string) = @_;
1619      my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1620      # Strip the line terminator characters.      # Strip the line terminator characters.
1621      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1622      # Return the result.      # Return the result.
# Line 1431  Line 1684 
1684      return $retVal;      return $retVal;
1685  }  }
1686    
1687    =head3 EOF
1688    
1689    This is a constant that is lexically greater than any useful string.
1690    
1691    =cut
1692    
1693    sub EOF {
1694        return "\xFF\xFF\xFF\xFF\xFF";
1695    }
1696    
1697  =head3 TICK  =head3 TICK
1698    
1699  C<< my @results = TICK($commandString); >>  C<< my @results = TICK($commandString); >>
# Line 1472  Line 1735 
1735      return `$commandString`;      return `$commandString`;
1736  }  }
1737    
1738    =head3 ScriptSetup
1739    
1740    C<< my ($query, $varHash) = ScriptSetup(); >>
1741    
1742    Perform standard tracing and debugging setup for scripts. The value returned is
1743    the CGI object followed by a pre-built variable hash.
1744    
1745    The C<Trace> query parameter is used to determine whether or not tracing is active and
1746    which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying
1747    the C<CGI> trace module will trace parameter and environment information. Parameters are
1748    traced at level 3 and environment variables at level 4. At the end of the script, the
1749    client should call L</ScriptFinish> to output the web page.
1750    
1751    =cut
1752    
1753    sub ScriptSetup {
1754        # Get the CGI query object.
1755        my $query = CGI->new();
1756        # Check for tracing. Set it up if the user asked for it.
1757        if ($query->param('Trace')) {
1758            # Set up tracing to be queued for display at the bottom of the web page.
1759            TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");
1760            # Trace the parameter and environment data.
1761            if (T(CGI => 3)) {
1762                # Here we want to trace the parameter data.
1763                my @names = $query->param;
1764                for my $parmName (sort @names) {
1765                    # Note we skip "Trace", which is for our use only.
1766                    if ($parmName ne 'Trace') {
1767                        my @values = $query->param($parmName);
1768                        Trace("CGI: $parmName = " . join(", ", @values));
1769                    }
1770                }
1771            }
1772            if (T(CGI => 4)) {
1773                # Here we want the environment data too.
1774                for my $envName (sort keys %ENV) {
1775                    Trace("ENV: $envName = $ENV{$envName}");
1776                }
1777            }
1778        } else {
1779            # Here tracing is to be turned off. All we allow is errors traced into the
1780            # error log.
1781            TSetup("0", "WARN");
1782        }
1783        # Create the variable hash.
1784        my $varHash = { DebugData => '' };
1785        # If we're in DEBUG mode, set up the debug mode data for forms.
1786        if (Tracer::DebugMode) {
1787            $varHash->{DebugData} = GetFile("Html/DebugFragment.html");
1788        }
1789        # Return the query object and variable hash.
1790        return ($query, $varHash);
1791    }
1792    
1793    =head3 ScriptFinish
1794    
1795    C<< ScriptFinish($webData, $varHash); >>
1796    
1797    Output a web page at the end of a script. Either the string to be output or the
1798    name of a template file can be specified. If the second parameter is omitted,
1799    it is assumed we have a string to be output; otherwise, it is assumed we have the
1800    name of a template file. The template should have the variable C<DebugData>
1801    specified in any form that invokes a standard script. If debugging mode is turned
1802    on, a form field will be put in that allows the user to enter tracing data.
1803    Trace messages will be placed immediately before the terminal C<BODY> tag in
1804    the output, formatted as a list.
1805    
1806    A typical standard script would loook like the following.
1807    
1808        BEGIN {
1809            # Print the HTML header.
1810            print "CONTENT-TYPE: text/html\n\n";
1811        }
1812        use Tracer;
1813        use CGI;
1814        use FIG;
1815        # ... more uses ...
1816    
1817        my ($query, $varHash) = ScriptSetup();
1818        eval {
1819            # ... get data from $query, put it in $varHash ...
1820        };
1821        if ($@) {
1822            Trace("Script Error: $@") if T(0);
1823        }
1824        ScriptFinish("Html/MyTemplate.html", $varHash);
1825    
1826    The idea here is that even if the script fails, you'll see trace messages and
1827    useful output.
1828    
1829    =over 4
1830    
1831    =item webData
1832    
1833    A string containing either the full web page to be written to the output or the
1834    name of a template file from which the page is to be constructed. If the name
1835    of a template file is specified, then the second parameter must be present;
1836    otherwise, it must be absent.
1837    
1838    =item varHash (optional)
1839    
1840    If specified, then a reference to a hash mapping variable names for a template
1841    to their values. The template file will be read into memory, and variable markers
1842    will be replaced by data in this hash reference.
1843    
1844    =back
1845    
1846    =cut
1847    
1848    sub ScriptFinish {
1849        # Get the parameters.
1850        my ($webData, $varHash) = @_;
1851        # Check for a template file situation.
1852        my $outputString;
1853        if (defined $varHash) {
1854            # Here we have a template file. We need to apply the variables to the template.
1855            $outputString = PageBuilder::Build("<$webData", $varHash, "Html");
1856        } else {
1857            # Here the user gave us a raw string.
1858            $outputString = $webData;
1859        }
1860        # Check for trace messages.
1861        if ($Destination eq "QUEUE") {
1862            # We have trace messages, so we want to put them at the end of the body. This
1863            # is either at the end of the whole string or at the beginning of the BODY
1864            # end-tag.
1865            my $pos = length $outputString;
1866            if ($outputString =~ m#</body>#gi) {
1867                $pos = (pos $outputString) - 7;
1868            }
1869            substr $outputString, $pos, 0, QTrace('Html');
1870        }
1871        # Write the output string.
1872        print $outputString;
1873    }
1874    
1875    =head3 Insure
1876    
1877    C<< Insure($dirName); >>
1878    
1879    Insure a directory is present.
1880    
1881    =over 4
1882    
1883    =item dirName
1884    
1885    Name of the directory to check. If it does not exist, it will be created.
1886    
1887    =back
1888    
1889    =cut
1890    
1891    sub Insure {
1892        my ($dirName) = @_;
1893        if (! -d $dirName) {
1894            Trace("Creating $dirName directory.") if T(2);
1895            mkpath $dirName;
1896        }
1897    }
1898    
1899  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3