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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3