[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.9, Wed May 4 03:05:12 2005 UTC revision 1.30, Mon Dec 5 19:06:30 2005 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);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK);
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 FIG_Config;          use FIG_Config;
28      use PageBuilder;      use PageBuilder;
29        use Digest::MD5;
30    
31  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
32    
# Line 20  Line 38 
38  has a list of categories and a single trace level set by the B<TSetup> method. Only messages whose trace  has a list of categories and a single trace level set by the B<TSetup> method. Only messages whose trace
39  level is less than or equal to this package's trace level and whose category is activated will  level is less than or equal to this package's trace level and whose category is activated will
40  be written. Thus, a higher trace level on a message indicates that the message  be written. Thus, a higher trace level on a message indicates that the message
41  is less likely to be seen. A higher trace level passed to B<Setup> means more trace messages will  is less likely to be seen. A higher trace level passed to B<TSetup> means more trace messages will
42  appear. To generate a trace message, use the following syntax.  appear. To generate a trace message, use the following syntax.
43    
44  C<< Trace($message) if T(errors => 4); >>  C<< Trace($message) if T(errors => 4); >>
# Line 38  Line 56 
56    
57  C<< Trace($message) if T(2); >>  C<< Trace($message) if T(2); >>
58    
59  To set up tracing, you call the C</Setup> method. The method takes as input a trace level, a list  To set up tracing, you call the L</TSetup> method. The method takes as input a trace level, a list
60  of category names, and a set of options. The trace level and list of category names are  of category names, and a set of options. The trace level and list of category names are
61  specified as a space-delimited string. Thus  specified as a space-delimited string. Thus
62    
63  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
64    
65  sets the trace level to 3, activates the C<errors>, C<Sprout>, and C<ERDB> categories, and  sets the trace level to 3, activates the C<errors>, C<Sprout>, and C<ERDB> categories, and
66  specifies that messages should be output as HTML paragraphs. The parameters are formatted  specifies that messages should be output as HTML paragraphs.
67  to make it easier to input tracing configuration on a web form.  
68    To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
69    level 3 and writes the output to the standard error output. This sort of thing might be
70    useful in a CGI environment.
71    
72    C<< TSetup('3 *', 'WARN'); >>
73    
74  In addition to HTML and file output for trace messages, you can specify that the trace messages  In addition to HTML and file output for trace messages, you can specify that the trace messages
75  be queued. The messages can then be retrieved by calling the L</QTrace> method. This approach  be queued. The messages can then be retrieved by calling the L</QTrace> method. This approach
# Line 61  Line 84 
84  Thus, debugging information is available and easily retrieved even when the application is  Thus, debugging information is available and easily retrieved even when the application is
85  being used out in the field.  being used out in the field.
86    
87    There is no hard and fast rule on how to use trace levels. The following is therefore only
88    a suggestion.
89    
90    =over 4
91    
92    =item 0 Error
93    
94    Message indicates an error that may lead to incorrect results or that has stopped the
95    application entirely.
96    
97    =item 1 Warning
98    
99    Message indicates something that is unexpected but that probably did not interfere
100    with program execution.
101    
102    =item 2 Notice
103    
104    Message indicates the beginning or end of a major task.
105    
106    =item 3 Information
107    
108    Message indicates a subtask. In the FIG system, a subtask generally relates to a single
109    genome. This would be a big loop that is not expected to execute more than 500 times or so.
110    
111    =item 4 Detail
112    
113    Message indicates a low-level loop iteration.
114    
115    =back
116    
117  =cut  =cut
118    
119  # Declare the configuration variables.  # Declare the configuration variables.
120    
121  my $Destination = "NONE";       # Description of where to send the trace output.  my $Destination = "NONE";       # Description of where to send the trace output.
122    my $TeeFlag = 0;            # TRUE if output is going to a file and to the
123                                # standard output
124  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
125                                                          # hash of active category names                                                          # hash of active category names
126  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
127                                                          # messages                                                          # messages
128  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
129  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
130    my $SetupCount = 0;         # number of times TSetup called
131    my $AllTrace = 0;           # TRUE if we are tracing all categories.
132    
133  =head2 Public Methods  =head2 Public Methods
134    
# Line 93  Line 150 
150    
151  The destination for the trace output. To send the trace output to a file, specify the file  The destination for the trace output. To send the trace output to a file, specify the file
152  name preceded by a ">" symbol. If a double symbol is used (">>"), then the data is appended  name preceded by a ">" symbol. If a double symbol is used (">>"), then the data is appended
153  to the file. Otherwise the file is cleared before tracing begins. In addition to sending  to the file. Otherwise the file is cleared before tracing begins. Precede the first ">"
154  the trace messages to a file, you can specify a special destination. C<HTML> will cause  symbol with a C<+> to echo output to a file AND to the standard output. In addition to
155  tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>  sending the trace messages to a file, you can specify a special destination. C<HTML> will
156    cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
157  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace
158  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace
159  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
# Line 113  Line 171 
171          my @categoryData = split /\s+/, $categoryList;          my @categoryData = split /\s+/, $categoryList;
172          # Extract the trace level.          # Extract the trace level.
173          $TraceLevel = shift @categoryData;          $TraceLevel = shift @categoryData;
174          # Build the category hash.      # Presume category-based tracing until we learn otherwise.
175        $AllTrace = 0;
176        # Build the category hash. Note that if we find a "*", we turn on non-category
177        # tracing.
178          for my $category (@categoryData) {          for my $category (@categoryData) {
179                  $Categories{$category} = 1;          if ($category eq '*') {
180                $AllTrace = 1;
181            } else {
182                $Categories{lc $category} = 1;
183            }
184          }          }
185          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
186          # case is the single ">", which requires we clear the file first. After doing      # cases are the single ">", which requires we clear the file first, and the
187          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
188        if ($target =~ m/^\+?>>?/) {
189            if ($target =~ m/^\+/) {
190                $TeeFlag = 1;
191                $target = substr($target, 1);
192            }
193          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
194                  open TRACEFILE, $target;                  open TRACEFILE, $target;
195                  print TRACEFILE Now() . " Tracing initialized.\n";                  print TRACEFILE Now() . " Tracing initialized.\n";
196                  close TRACEFILE;                  close TRACEFILE;
197                  $Destination = ">$target";                  $Destination = ">$target";
198          } else {          } else {
199                $Destination = $target;
200            }
201        } else {
202                  $Destination = uc($target);                  $Destination = uc($target);
203          }          }
204        # Increment the setup counter.
205        $SetupCount++;
206    }
207    
208    =head3 Setups
209    
210    C<< my $count = Tracer::Setups(); >>
211    
212    Return the number of times L</TSetup> has been called.
213    
214    This method allows for the creation of conditional tracing setups where, for example, we
215    may want to set up tracing if nobody else has done it before us.
216    
217    =cut
218    
219    sub Setups {
220        return $SetupCount;
221    }
222    
223    =head3 Open
224    
225    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
226    
227    Open a file.
228    
229    The I<$fileSpec> is essentially the second argument of the PERL C<open>
230    function. The mode is specified using Unix-like shell information. So, for
231    example,
232    
233        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
234    
235    would open for output appended to the specified file, and
236    
237        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
238    
239    would open a pipe that sorts the records written and removes duplicates. Note
240    the use of file handle syntax in the Open call. To use anonymous file handles,
241    code as follows.
242    
243        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
244    
245    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
246    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
247    failed open will throw an exception and the third parameter will be used to construct
248    an error message. If the parameter is omitted, a standard message is constructed
249    using the file spec.
250    
251        Could not open "/usr/spool/news/twitlog"
252    
253    Note that the mode characters are automatically cleaned from the file name.
254    The actual error message from the file system will be captured and appended to the
255    message in any case.
256    
257        Could not open "/usr/spool/news/twitlog": file not found.
258    
259    In some versions of PERL the only error message we get is a number, which
260    corresponds to the C++ C<errno> value.
261    
262        Could not open "/usr/spool/news/twitlog": 6.
263    
264    =over 4
265    
266    =item fileHandle
267    
268    File handle. If this parameter is C<undef>, a file handle will be generated
269    and returned as the value of this method.
270    
271    =item fileSpec
272    
273    File name and mode, as per the PERL C<open> function.
274    
275    =item message (optional)
276    
277    Error message to use if the open fails. If omitted, a standard error message
278    will be generated. In either case, the error information from the file system
279    is appended to the message. To specify a conditional open that does not throw
280    an error if it fails, use C<0>.
281    
282    =item RETURN
283    
284    Returns the name of the file handle assigned to the file, or C<undef> if the
285    open failed.
286    
287    =back
288    
289    =cut
290    
291    sub Open {
292        # Get the parameters.
293        my ($fileHandle, $fileSpec, $message) = @_;
294        # Attempt to open the file.
295        my $rv = open $fileHandle, $fileSpec;
296        # If the open failed, generate an error message.
297        if (! $rv) {
298            # Save the system error message.
299            my $sysMessage = $!;
300            # See if we need a default message.
301            if (!$message) {
302                # Clean any obvious mode characters and leading spaces from the
303                # filename.
304                my ($fileName) = FindNamePart($fileSpec);
305                $message = "Could not open \"$fileName\"";
306            }
307            # Terminate with an error using the supplied message and the
308            # error message from the file system.
309            Confess("$message: $!");
310        }
311        # Return the file handle.
312        return $fileHandle;
313    }
314    
315    =head3 FindNamePart
316    
317    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
318    
319    Extract the portion of a file specification that contains the file name.
320    
321    A file specification is the string passed to an C<open> call. It specifies the file
322    mode and name. In a truly complex situation, it can specify a pipe sequence. This
323    method assumes that the file name is whatever follows the first angle bracket
324    sequence.  So, for example, in the following strings the file name is
325    C</usr/fig/myfile.txt>.
326    
327        >>/usr/fig/myfile.txt
328        </usr/fig/myfile.txt
329        | sort -u > /usr/fig/myfile.txt
330    
331    If the method cannot find a file name using its normal methods, it will return the
332    whole incoming string.
333    
334    =over 4
335    
336    =item fileSpec
337    
338    File specification string from which the file name is to be extracted.
339    
340    =item RETURN
341    
342    Returns a three-element list. The first element contains the file name portion of
343    the specified string, or the whole string if a file name cannot be found via normal
344    methods. The second element contains the start position of the file name portion and
345    the third element contains the length.
346    
347    =back
348    
349    =cut
350    #: Return Type $;
351    sub FindNamePart {
352        # Get the parameters.
353        my ($fileSpec) = @_;
354        # Default to the whole input string.
355        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
356        # Parse out the file name if we can.
357        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
358            $retVal = $2;
359            $len = length $retVal;
360            $pos = (length $fileSpec) - (length $3) - $len;
361        }
362        # Return the result.
363        return ($retVal, $pos, $len);
364    }
365    
366    =head3 OpenDir
367    
368    C<< my @files = OpenDir($dirName, $filtered); >>
369    
370    Open a directory and return all the file names. This function essentially performs
371    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
372    set to TRUE, all filenames beginning with a period (C<.>) will be filtered out of
373    the return list. If the directory does not open, an exception is thrown. So,
374    for example,
375    
376        my @files = OpenDir("/Volumes/fig/contigs", 1);
377    
378    is effectively the same as
379    
380        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
381        my @files = grep { $_ !~ /^\./ } readdir(TMP);
382    
383    Similarly, the following code
384    
385        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs");
386    
387    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
388    automatically throws an error if the directory fails to open.
389    
390    =over 4
391    
392    =item dirName
393    
394    Name of the directory to open.
395    
396    =item filtered
397    
398    TRUE if files whose names begin with a period (C<.>) should be automatically removed
399    from the list, else FALSE.
400    
401    =back
402    
403    =cut
404    #: Return Type @;
405    sub OpenDir {
406        # Get the parameters.
407        my ($dirName, $filtered) = @_;
408        # Declare the return variable.
409        my @retVal;
410        # Open the directory.
411        if (opendir(my $dirHandle, $dirName)) {
412            # The directory opened successfully. Get the appropriate list according to the
413            # strictures of the filter parameter.
414            if ($filtered) {
415                @retVal = grep { $_ !~ /^\./ } readdir $dirHandle;
416            } else {
417                @retVal = readdir $dirHandle;
418            }
419        } else {
420            # Here the directory would not open.
421            Confess("Could not open directory $dirName.");
422        }
423        # Return the result.
424        return @retVal;
425  }  }
426    
427  =head3 SetLevel  =head3 SetLevel
# Line 394  Line 688 
688         warn $message;         warn $message;
689          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
690                  # Write the trace message to an output file.                  # Write the trace message to an output file.
691                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
692                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
693                  close TRACING;                  close TRACING;
694            # If the Tee flag is on, echo it to the standard output.
695            if ($TeeFlag) {
696                print "$formatted\n";
697            }
698          }          }
699  }  }
700    
# Line 439  Line 737 
737                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
738                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
739                          # Here we have no category, so we need to get the calling package.                          # Here we have no category, so we need to get the calling package.
740                # The calling package is normally the first parameter. If it is
741                # omitted, the first parameter will be the tracelevel. So, the
742                # first thing we do is shift the so-called category into the
743                # $traceLevel variable where it belongs.
744                          $traceLevel = $category;                          $traceLevel = $category;
745                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
746              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 450  Line 752 
752                  }                  }
753          # Save the category name.          # Save the category name.
754          $LastCategory = $category;          $LastCategory = $category;
755            # Convert it to lower case before we hash it.
756            $category = lc $category;
757                  # Use the category and tracelevel to compute the result.                  # Use the category and tracelevel to compute the result.
758                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
759      }      }
760          # Return the computed result.          # Return the computed result.
761      return $retVal;      return $retVal;
# Line 537  Line 841 
841    
842  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
843    
844  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
845  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
846  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
847    
848  =over 4  =over 4
849    
# Line 563  Line 867 
867          # Loop through the parameter string, looking for sequences to escape.          # Loop through the parameter string, looking for sequences to escape.
868          while (length $realString > 0) {          while (length $realString > 0) {
869                  # Look for the first sequence to escape.                  # Look for the first sequence to escape.
870                  if ($realString =~ /^(.*?)([ \n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
871                          # 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
872                          # 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.
873                          $retVal .= $1;                          $retVal .= $1;
874                          $realString = substr $realString, (length $2 + length $1);              # Strip the processed section off the real string.
875                          # Encode the escape sequence.              $realString = substr $realString, (length $2) + (length $1);
876                # Get the matched character.
877                          my $char = $2;                          my $char = $2;
878                          $char =~ tr/ \t\n/btn/;              # If we have a CR, we are done.
879                if ($char ne "\r") {
880                    # It's not a CR, so encode the escape sequence.
881                    $char =~ tr/\t\n/tn/;
882                          $retVal .= "\\" . $char;                          $retVal .= "\\" . $char;
883                }
884                  } else {                  } else {
885                          # 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
886                          # transferred unmodified.                          # transferred unmodified.
# Line 587  Line 896 
896    
897  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
898    
899  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
900  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
901    be deleted.
902    
903  =over 4  =over 4
904    
# Line 613  Line 923 
923          # Only proceed if the incoming string is nonempty.          # Only proceed if the incoming string is nonempty.
924          if (defined $codedString) {          if (defined $codedString) {
925                  # 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
926                  # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
927                  # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
928                  while (length $codedString > 0) {                  while (length $codedString > 0) {
929                          # Look for the first escape sequence.                          # Look for the first escape sequence.
930                          if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
931                                  # 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
932                                  # 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.
933                                  $retVal .= $1;                                  $retVal .= $1;
934                                  $codedString = substr $codedString, (2 + length $1);                                  $codedString = substr $codedString, (2 + length $1);
935                                  # Decode the escape sequence.                  # Get the escape value.
936                                  my $char = $2;                                  my $char = $2;
937                                  $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
938                    if ($char ne 'r') {
939                        # Here it's not an 'r', so we convert it.
940                        $char =~ tr/\\tn/\\\t\n/;
941                                  $retVal .= $char;                                  $retVal .= $char;
942                    }
943                          } else {                          } else {
944                                  # 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
945                                  # transferred unmodified.                                  # transferred unmodified.
# Line 761  Line 1075 
1075          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1076          if (!$ok) {          if (!$ok) {
1077                  # If we had an error, trace it. We will automatically return a null value.                  # If we had an error, trace it. We will automatically return a null value.
1078                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1079          } else {          } else {
1080                  # Read the whole file into the return variable, stripping off any terminator                  # Read the whole file into the return variable, stripping off any terminator
1081          # characters.          # characters.
# Line 774  Line 1088 
1088                  # Close it.                  # Close it.
1089                  close INPUTFILE;                  close INPUTFILE;
1090          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(3);  
1091          }          }
1092          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1093      if (wantarray) {      if (wantarray) {
# Line 805  Line 1118 
1118          my ($format) = @_;          my ($format) = @_;
1119          # Create the return variable.          # Create the return variable.
1120          my $retVal = "";          my $retVal = "";
1121        # Only proceed if there is an actual queue.
1122        if (@Queue) {
1123          # Process according to the format.          # Process according to the format.
1124          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1125                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 820  Line 1135 
1135          }          }
1136          # Clear the queue.          # Clear the queue.
1137          @Queue = ();          @Queue = ();
1138        }
1139          # Return the formatted list.          # Return the formatted list.
1140          return $retVal;          return $retVal;
1141  }  }
# Line 828  Line 1144 
1144    
1145  C<< Confess($message); >>  C<< Confess($message); >>
1146    
1147  Trace the call stack and abort the program with the specified message. The stack  Trace the call stack and abort the program with the specified message. When used with
 trace will only appear if the trace level for this package is 1 or more. When used with  
1148  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.
1149  So, for example  So, for example
1150    
# Line 851  Line 1166 
1166          # Get the parameters.          # Get the parameters.
1167          my ($message) = @_;          my ($message) = @_;
1168          # Trace the call stack.          # Trace the call stack.
1169          Cluck($message) if T(1);      Cluck($message);
1170          # Abort the program.          # Abort the program.
1171          croak(">>> $message");          croak(">>> $message");
1172  }  }
# Line 861  Line 1176 
1176  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1177    
1178  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
1179  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.
1180  So, for example  So, for example
1181    
1182  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1020  Line 1335 
1335    
1336  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1337    
1338  Return TRUE if debug mode has been turned on in FIG_Config, else output  Return TRUE if debug mode has been turned on, else output an error
1339  an error page and return FALSE.  page and return FALSE.
1340    
1341  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1342  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1343  from working unless they are explicitly turned on in the configuration  from working unless they are explicitly turned on by creating a password
1344  file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1345  is not turned on, an error web page will be output.  is not turned on, an error web page will be output directing the
1346    user to enter in the correct password.
1347    
1348  =cut  =cut
1349    
1350  sub DebugMode {  sub DebugMode {
1351          # Declare the return variable.          # Declare the return variable.
1352          my $retVal;      my $retVal = 0;
1353          # Check the debug configuration.          # Check the debug configuration.
1354          if ($FIG_Config::debug_mode) {      my $password = CGI::cookie("DebugMode");
1355        my $encrypted = Digest::MD5::md5_hex($password);
1356        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1357                  $retVal = 1;                  $retVal = 1;
1358          } else {          } else {
1359                  # Here debug mode is off, so we generate an error page.                  # Here debug mode is off, so we generate an error page.
# Line 1071  Line 1389 
1389  sub Strip {  sub Strip {
1390          # Get a copy of the parameter string.          # Get a copy of the parameter string.
1391          my ($string) = @_;          my ($string) = @_;
1392          my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1393      # Strip the line terminator characters.      # Strip the line terminator characters.
1394      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1395          # Return the result.          # Return the result.
# Line 1102  Line 1420 
1420    
1421  =item padChar (optional)  =item padChar (optional)
1422    
1423    Character to use for padding. The default is a space.
1424    
1425  =item RETURN  =item RETURN
1426    
1427  Returns a copy of the original string with the spaces added to the specified end so  Returns a copy of the original string with the pad character added to the
1428  that it achieves the desired length.  specified end so that it achieves the desired length.
1429    
1430  =back  =back
1431    
# Line 1137  Line 1457 
1457          return $retVal;          return $retVal;
1458  }  }
1459    
1460    =head3 EOF
1461    
1462    This is a constant that is lexically greater than any useful string.
1463    
1464    =cut
1465    
1466    sub EOF {
1467        return "\xFF\xFF\xFF\xFF\xFF";
1468    }
1469    
1470    =head3 TICK
1471    
1472    C<< my @results = TICK($commandString); >>
1473    
1474    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1475    dot-slash (C<./> will be removed. So, for example, if you were doing
1476    
1477        `./protein.cgi`
1478    
1479    from inside a CGI script, it would work fine in Unix, but would issue an error message
1480    in Windows complaining that C<'.'> is not a valid command. If instead you code
1481    
1482        TICK("./protein.cgi")
1483    
1484    it will work correctly in both environments.
1485    
1486    =over 4
1487    
1488    =item commandString
1489    
1490    The command string to pass to the system.
1491    
1492    =item RETURN
1493    
1494    Returns the standard output from the specified command, as a list.
1495    
1496    =back
1497    
1498    =cut
1499    #: Return Type @;
1500    sub TICK {
1501        # Get the parameters.
1502        my ($commandString) = @_;
1503        # Chop off the dot-slash if this is Windows.
1504        if ($FIG_Config::win_mode) {
1505            $commandString =~ s!^\./!!;
1506        }
1507        # Activate the command and return the result.
1508        return `$commandString`;
1509    }
1510    
1511  1;  1;

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.30

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3