[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.21, Tue Aug 16 20:21:51 2005 UTC
# Line 2  Line 2 
2    
3          require Exporter;          require Exporter;
4          @ISA = ('Exporter');          @ISA = ('Exporter');
5          @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);
6          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
7          use strict;          use strict;
8          use Carp qw(longmess croak);          use Carp qw(longmess croak);
9          use CGI;          use CGI;
10          use FIG_Config;          use FIG_Config;
11      use PageBuilder;      use PageBuilder;
12        use Digest::MD5;
13    
14  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
15    
# Line 20  Line 21 
21  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
22  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
23  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
24  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
25  appear. To generate a trace message, use the following syntax.  appear. To generate a trace message, use the following syntax.
26    
27  C<< Trace($message) if T(errors => 4); >>  C<< Trace($message) if T(errors => 4); >>
# Line 38  Line 39 
39    
40  C<< Trace($message) if T(2); >>  C<< Trace($message) if T(2); >>
41    
42  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
43  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
44  specified as a space-delimited string. Thus  specified as a space-delimited string. Thus
45    
46  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
47    
48  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
49  specifies that messages should be output as HTML paragraphs. The parameters are formatted  specifies that messages should be output as HTML paragraphs.
50  to make it easier to input tracing configuration on a web form.  
51    To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
52    level 3 and writes the output to the standard error output. This sort of thing might be
53    useful in a CGI environment.
54    
55    C<< TSetup('3 *', 'WARN'); >>
56    
57  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
58  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 67 
67  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
68  being used out in the field.  being used out in the field.
69    
70    There is no hard and fast rule on how to use trace levels. The following is therefore only
71    a suggestion.
72    
73    =over 4
74    
75    =item 0 Error
76    
77    Message indicates an error that may lead to incorrect results or that has stopped the
78    application entirely.
79    
80    =item 1 Warning
81    
82    Message indicates something that is unexpected but that probably did not interfere
83    with program execution.
84    
85    =item 2 Notice
86    
87    Message indicates the beginning or end of a major task.
88    
89    =item 3 Information
90    
91    Message indicates a subtask. In the FIG system, a subtask generally relates to a single
92    genome. This would be a big loop that is not expected to execute more than 500 times or so.
93    
94    =item 4 Detail
95    
96    Message indicates a low-level loop iteration.
97    
98    =back
99    
100  =cut  =cut
101    
102  # Declare the configuration variables.  # Declare the configuration variables.
103    
104  my $Destination = "NONE";       # Description of where to send the trace output.  my $Destination = "NONE";       # Description of where to send the trace output.
105    my $TeeFlag = 0;            # TRUE if output is going to a file and to the
106                                # standard output
107  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
108                                                          # hash of active category names                                                          # hash of active category names
109  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
110                                                          # messages                                                          # messages
111  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
112  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
113    my $SetupCount = 0;         # number of times TSetup called
114    my $AllTrace = 0;           # TRUE if we are tracing all categories.
115    
116  =head2 Public Methods  =head2 Public Methods
117    
# Line 93  Line 133 
133    
134  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
135  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
136  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 ">"
137  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
138  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
139    cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
140  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
141  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
142  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 154 
154          my @categoryData = split /\s+/, $categoryList;          my @categoryData = split /\s+/, $categoryList;
155          # Extract the trace level.          # Extract the trace level.
156          $TraceLevel = shift @categoryData;          $TraceLevel = shift @categoryData;
157          # Build the category hash.      # Presume category-based tracing until we learn otherwise.
158        $AllTrace = 0;
159        # Build the category hash. Note that if we find a "*", we turn on non-category
160        # tracing.
161          for my $category (@categoryData) {          for my $category (@categoryData) {
162                  $Categories{$category} = 1;          if ($category eq '*') {
163                $AllTrace = 1;
164            } else {
165                $Categories{lc $category} = 1;
166            }
167          }          }
168          # Now we need to process the destination information. The most important special          # Now we need to process the destination information. The most important special
169          # 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
170          # so, we tack on another ">" sign so that future trace messages are appended.      # "+" prefix which indicates a double echo.
171        if ($target =~ m/^\+?>>?/) {
172            if ($target =~ m/^\+/) {
173                $TeeFlag = 1;
174                $target = substr($target, 1);
175            }
176          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
177                  open TRACEFILE, $target;                  open TRACEFILE, $target;
178                  print TRACEFILE Now() . " Tracing initialized.\n";                  print TRACEFILE Now() . " Tracing initialized.\n";
179                  close TRACEFILE;                  close TRACEFILE;
180                  $Destination = ">$target";                  $Destination = ">$target";
181          } else {          } else {
182                $Destination = $target;
183            }
184        } else {
185                  $Destination = uc($target);                  $Destination = uc($target);
186          }          }
187        # Increment the setup counter.
188        $SetupCount++;
189    }
190    
191    =head3 Setups
192    
193    C<< my $count = Tracer::Setups(); >>
194    
195    Return the number of times L</TSetup> has been called.
196    
197    This method allows for the creation of conditional tracing setups where, for example, we
198    may want to set up tracing if nobody else has done it before us.
199    
200    =cut
201    
202    sub Setups {
203        return $SetupCount;
204    }
205    
206    =head3 Open
207    
208    C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
209    
210    Open a file.
211    
212    The I<$fileSpec> is essentially the second argument of the PERL C<open>
213    function. The mode is specified using Unix-like shell information. So, for
214    example,
215    
216        Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
217    
218    would open for output appended to the specified file, and
219    
220        Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
221    
222    would open a pipe that sorts the records written and removes duplicates. Note
223    the use of file handle syntax in the Open call. To use anonymous file handles,
224    code as follows.
225    
226        my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
227    
228    The I<$message> parameter is used if the open fails. If it is set to C<0>, then
229    the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
230    failed open will throw an exception and the third parameter will be used to construct
231    an error message. If the parameter is omitted, a standard message is constructed
232    using the file spec.
233    
234        Could not open "/usr/spool/news/twitlog"
235    
236    Note that the mode characters are automatically cleaned from the file name.
237    The actual error message from the file system will be captured and appended to the
238    message in any case.
239    
240        Could not open "/usr/spool/news/twitlog": file not found.
241    
242    In some versions of PERL the only error message we get is a number, which
243    corresponds to the C++ C<errno> value.
244    
245        Could not open "/usr/spool/news/twitlog": 6.
246    
247    =over 4
248    
249    =item fileHandle
250    
251    File handle. If this parameter is C<undef>, a file handle will be generated
252    and returned as the value of this method.
253    
254    =item fileSpec
255    
256    File name and mode, as per the PERL C<open> function.
257    
258    =item message (optional)
259    
260    Error message to use if the open fails. If omitted, a standard error message
261    will be generated. In either case, the error information from the file system
262    is appended to the message. To specify a conditional open that does not throw
263    an error if it fails, use C<0>.
264    
265    =item RETURN
266    
267    Returns the name of the file handle assigned to the file, or C<undef> if the
268    open failed.
269    
270    =back
271    
272    =cut
273    
274    sub Open {
275        # Get the parameters.
276        my ($fileHandle, $fileSpec, $message) = @_;
277        # Attempt to open the file.
278        my $rv = open $fileHandle, $fileSpec;
279        # If the open failed, generate an error message.
280        if (! $rv) {
281            # Save the system error message.
282            my $sysMessage = $!;
283            # See if we need a default message.
284            if (!$message) {
285                # Clean any obvious mode characters and leading spaces from the
286                # filename.
287                my ($fileName) = FindNamePart($fileSpec);
288                $message = "Could not open \"$fileName\"";
289            }
290            # Terminate with an error using the supplied message and the
291            # error message from the file system.
292            Confess("$message: $!");
293        }
294        # Return the file handle.
295        return $fileHandle;
296    }
297    
298    =head3 FindNamePart
299    
300    C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
301    
302    Extract the portion of a file specification that contains the file name.
303    
304    A file specification is the string passed to an C<open> call. It specifies the file
305    mode and name. In a truly complex situation, it can specify a pipe sequence. This
306    method assumes that the file name is whatever follows the first angle bracket
307    sequence.  So, for example, in the following strings the file name is
308    C</usr/fig/myfile.txt>.
309    
310        >>/usr/fig/myfile.txt
311        </usr/fig/myfile.txt
312        | sort -u > /usr/fig/myfile.txt
313    
314    If the method cannot find a file name using its normal methods, it will return the
315    whole incoming string.
316    
317    =over 4
318    
319    =item fileSpec
320    
321    File specification string from which the file name is to be extracted.
322    
323    =item RETURN
324    
325    Returns a three-element list. The first element contains the file name portion of
326    the specified string, or the whole string if a file name cannot be found via normal
327    methods. The second element contains the start position of the file name portion and
328    the third element contains the length.
329    
330    =back
331    
332    =cut
333    #: Return Type $;
334    sub FindNamePart {
335        # Get the parameters.
336        my ($fileSpec) = @_;
337        # Default to the whole input string.
338        my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
339        # Parse out the file name if we can.
340        if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
341            $retVal = $2;
342            $len = length $retVal;
343            $pos = (length $fileSpec) - (length $3) - $len;
344        }
345        # Return the result.
346        return ($retVal, $pos, $len);
347    }
348    
349    =head3 OpenDir
350    
351    C<< my @files = OpenDir($dirName, $filtered); >>
352    
353    Open a directory and return all the file names. This function essentially performs
354    the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
355    set to TRUE, all filenames beginning with a period (C<.>) will be filtered out of
356    the return list. If the directory does not open, an exception is thrown. So,
357    for example,
358    
359        my @files = OpenDir("/Volumes/fig/contigs", 1);
360    
361    is effectively the same as
362    
363        opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
364        my @files = grep { $_ !~ /^\./ } readdir(TMP);
365    
366    Similarly, the following code
367    
368        my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs");
369    
370    Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
371    automatically throws an error if the directory fails to open.
372    
373    =over 4
374    
375    =item dirName
376    
377    Name of the directory to open.
378    
379    =item filtered
380    
381    TRUE if files whose names begin with a period (C<.>) should be automatically removed
382    from the list, else FALSE.
383    
384    =back
385    
386    =cut
387    #: Return Type @;
388    sub OpenDir {
389        # Get the parameters.
390        my ($dirName, $filtered) = @_;
391        # Declare the return variable.
392        my @retVal;
393        # Open the directory.
394        if (opendir(my $dirHandle, $dirName)) {
395            # The directory opened successfully. Get the appropriate list according to the
396            # strictures of the filter parameter.
397            if ($filtered) {
398                @retVal = grep { $_ !~ /^\./ } readdir $dirHandle;
399            } else {
400                @retVal = readdir $dirHandle;
401            }
402        } else {
403            # Here the directory would not open.
404            Confess("Could not open directory $dirName.");
405        }
406        # Return the result.
407        return @retVal;
408  }  }
409    
410  =head3 SetLevel  =head3 SetLevel
# Line 394  Line 671 
671         warn $message;         warn $message;
672          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
673                  # Write the trace message to an output file.                  # Write the trace message to an output file.
674                  open TRACING, $Destination;          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
675                  print TRACING "$formatted\n";                  print TRACING "$formatted\n";
676                  close TRACING;                  close TRACING;
677            # If the Tee flag is on, echo it to the standard output.
678            if ($TeeFlag) {
679                print "$formatted\n";
680            }
681          }          }
682  }  }
683    
# Line 439  Line 720 
720                  my ($category, $traceLevel) = @_;                  my ($category, $traceLevel) = @_;
721                  if (!defined $traceLevel) {                  if (!defined $traceLevel) {
722                          # 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.
723                # The calling package is normally the first parameter. If it is
724                # omitted, the first parameter will be the tracelevel. So, the
725                # first thing we do is shift the so-called category into the
726                # $traceLevel variable where it belongs.
727                          $traceLevel = $category;                          $traceLevel = $category;
728                          my ($package, $fileName, $line) = caller;                          my ($package, $fileName, $line) = caller;
729              # If there is no calling package, we default to "main".              # If there is no calling package, we default to "main".
# Line 450  Line 735 
735                  }                  }
736          # Save the category name.          # Save the category name.
737          $LastCategory = $category;          $LastCategory = $category;
738            # Convert it to lower case before we hash it.
739            $category = lc $category;
740                  # Use the category and tracelevel to compute the result.                  # Use the category and tracelevel to compute the result.
741                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
742      }      }
743          # Return the computed result.          # Return the computed result.
744      return $retVal;      return $retVal;
# Line 567  Line 854 
854                          # 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
855                          # 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.
856                          $retVal .= $1;                          $retVal .= $1;
857                          $realString = substr $realString, (length $2 + length $1);              # Strip the processed section off the real string.
858                $realString = substr $realString, (length $2) + (length $1);
859                          # Encode the escape sequence.                          # Encode the escape sequence.
860                          my $char = $2;                          my $char = $2;
861                          $char =~ tr/ \t\n/btn/;                          $char =~ tr/ \t\n/btn/;
# Line 761  Line 1049 
1049          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1050          if (!$ok) {          if (!$ok) {
1051                  # 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.
1052                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1053          } else {          } else {
1054                  # Read the whole file into the return variable, stripping off any terminator                  # Read the whole file into the return variable, stripping off any terminator
1055          # characters.          # characters.
# Line 774  Line 1062 
1062                  # Close it.                  # Close it.
1063                  close INPUTFILE;                  close INPUTFILE;
1064          my $actualLines = @retVal;          my $actualLines = @retVal;
         Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(3);  
1065          }          }
1066          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
1067      if (wantarray) {      if (wantarray) {
# Line 805  Line 1092 
1092          my ($format) = @_;          my ($format) = @_;
1093          # Create the return variable.          # Create the return variable.
1094          my $retVal = "";          my $retVal = "";
1095        # Only proceed if there is an actual queue.
1096        if (@Queue) {
1097          # Process according to the format.          # Process according to the format.
1098          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1099                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 820  Line 1109 
1109          }          }
1110          # Clear the queue.          # Clear the queue.
1111          @Queue = ();          @Queue = ();
1112        }
1113          # Return the formatted list.          # Return the formatted list.
1114          return $retVal;          return $retVal;
1115  }  }
# Line 1025  Line 1315 
1315    
1316  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1317  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1318  from working unless they are explicitly turned on in the configuration  from working unless they are explicitly turned on by creating a password
1319  file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1320  is not turned on, an error web page will be output.  is not turned on, an error web page will be output.
1321    
1322  =cut  =cut
1323    
1324  sub DebugMode {  sub DebugMode {
1325          # Declare the return variable.          # Declare the return variable.
1326          my $retVal;      my $retVal = 0;
1327          # Check the debug configuration.          # Check the debug configuration.
1328          if ($FIG_Config::debug_mode) {      my $password = CGI::cookie("DebugMode");
1329        my $encrypted = Digest::MD5::md5_hex($password);
1330        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1331                  $retVal = 1;                  $retVal = 1;
1332          } else {          } else {
1333                  # Here debug mode is off, so we generate an error page.                  # Here debug mode is off, so we generate an error page.
# Line 1137  Line 1429 
1429          return $retVal;          return $retVal;
1430  }  }
1431    
1432    =head3 TICK
1433    
1434    C<< my @results = TICK($commandString); >>
1435    
1436    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1437    dot-slash (C<./> will be removed. So, for example, if you were doing
1438    
1439        `./protein.cgi`
1440    
1441    from inside a CGI script, it would work fine in Unix, but would issue an error message
1442    in Windows complaining that C<'.'> is not a valid command. If instead you code
1443    
1444        TICK("./protein.cgi")
1445    
1446    it will work correctly in both environments.
1447    
1448    =over 4
1449    
1450    =item commandString
1451    
1452    The command string to pass to the system.
1453    
1454    =item RETURN
1455    
1456    Returns the standard output from the specified command, as a list.
1457    
1458    =back
1459    
1460    =cut
1461    #: Return Type @;
1462    sub TICK {
1463        # Get the parameters.
1464        my ($commandString) = @_;
1465        # Chop off the dot-slash if this is Windows.
1466        if ($FIG_Config::win_mode) {
1467            $commandString =~ s!^\./!!;
1468        }
1469        # Activate the command and return the result.
1470        return `$commandString`;
1471    }
1472    
1473  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3