[Bio] / FigKernelPackages / Tracer.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/Tracer.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3