[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.34, Fri Jan 6 05:34:21 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);
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 72  Line 89 
89    
90  =over 4  =over 4
91    
92  =item 0 Error  =item Error 0
93    
94  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
95  application entirely.  application entirely.
96    
97  =item 1 Warning  =item Warning 1
98    
99  Message indicates something that is unexpected but that probably did not interfere  Message indicates something that is unexpected but that probably did not interfere
100  with program execution.  with program execution.
101    
102  =item 2 Notice  =item Notice 2
103    
104  Message indicates the beginning or end of a major task.  Message indicates the beginning or end of a major task.
105    
106  =item 3 Information  =item Information 3
107    
108  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
109  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.
110    
111  =item 4 Detail  =item Detail 4
112    
113  Message indicates a low-level loop iteration.  Message indicates a low-level loop iteration.
114    
# Line 157  Line 174 
174      # Presume category-based tracing until we learn otherwise.      # Presume category-based tracing until we learn otherwise.
175      $AllTrace = 0;      $AllTrace = 0;
176      # 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
177      # tracing.      # tracing. We must also clear away any pre-existing data.
178        %Categories = ( main => 1 );
179      for my $category (@categoryData) {      for my $category (@categoryData) {
180          if ($category eq '*') {          if ($category eq '*') {
181              $AllTrace = 1;              $AllTrace = 1;
# Line 188  Line 206 
206      $SetupCount++;      $SetupCount++;
207  }  }
208    
209    =head3 StandardSetup
210    
211    C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, @ARGV); >>
212    
213    This method performs standard command-line parsing and tracing setup. The return
214    values are a hash of the command-line options and a list of the positional
215    parameters. Tracing is automatically set up and the command-line options are
216    validated.
217    
218    This is a complex method that does a lot of grunt work. The parameters can
219    be more easily understood, however, once they are examined individually.
220    
221    The I<categories> parameter is the most obtuse. It is a reference to a list of
222    special-purpose tracing categories. Most tracing categories are PERL package
223    names. So, for example, if you wanted to turn on tracing inside the B<Sprout>,
224    B<ERDB>, and B<SproutLoad> packages, you would specify the categories
225    
226        ["Sprout", "SproutLoad", "ERDB"]
227    
228    This would cause trace messages in the specified three packages to appear in
229    the output. There are threer special tracing categories that are automatically
230    handled by this method. In other words, if you used L</TSetup> you would need
231    to include these categories manually, but if you use this method they are turned
232    on automatically.
233    
234    =over 4
235    
236    =item FIG
237    
238    Turns on trace messages inside the B<FIG> package.
239    
240    =item SQL
241    
242    Traces SQL commands and activity.
243    
244    =item Tracer
245    
246    Traces error messages and call stacks.
247    
248    =back
249    
250    C<SQL> is only turned on if the C<-sql> option is specified in the command line.
251    The trace level is specified using the C<-trace> command-line option. For example,
252    the following command line for C<TransactFeatures> turns on SQL tracing and runs
253    all tracing at level 3.
254    
255        TransactFeatures -trace=3 -sql register ../xacts IDs.tbl
256    
257    Standard tracing is output to the standard output and echoed to the file
258    C<trace.log> in the FIG temporary directory.
259    
260    The default trace level is 3. This dumps out all SQL commands if SQL tracing
261    is turned on and tends to produce one flurry of messages per genome. To get all
262    messages, specify a trace level of 4. For generally quiet output, use 2.
263    
264    The I<options> parameter is a reference to a hash containing the command-line
265    options and their default values. Command-line options may be in the form of switches
266    or keywords. In the case of a switch, the option value is 1 if it is specified and
267    0 if it is not specified. In the case of a keyword, the value is separated from the
268    option name by an equal sign. You can see this last in the command-line example above.
269    
270    An example at this point would help. Consider, for example, the command-line utility
271    C<TransactFeatures>. It accepts a list of positional parameters plus the options
272    C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
273    the following code.
274    
275        my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"],
276                                                          { trace => 3, sql => 0,
277                                                            safe => 0, noAlias => 0,
278                                                            start => ' ', tblFiles => 0},
279                                                        @ARGV);
280    
281    
282    The call to C<ParseCommand> specifies the default values for the options and
283    stores the actual options in a hash that is returned as C<$options>. The
284    positional parameters are returned in C<@parameters>.
285    
286    The following is a sample command line for C<TransactFeatures>.
287    
288        TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
289    
290    In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
291    parameters, and would find themselves in I<@parameters> after executing the
292    above code fragment. The tracing would be set to level 2, and the categories
293    would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,
294    and C<DocUtils> was included because it came in within the first parameter
295    to this method. The I<$options> hash would be
296    
297        { trace => 2, sql => 0, safe => 0,
298          noAlias => 1, start => ' ', tblFiles => 0 }
299    
300    Use of C<StandardSetup> in this way provides a simple way of performing
301    standard tracing setup and command-line parsing. Note that the caller is
302    not even aware of the command-line switches C<-trace> and C<-sql>, which
303    are used by this method to control the tracing. If additional tracing features
304    need to be added in the future, they can be processed by this method without
305    upsetting the command-line utilities.
306    
307    The parameters to this method are as follows.
308    
309    =over 4
310    
311    =item categories
312    
313    Reference to a list of tracing category names. These should be names of
314    packages whose internal workings will need to be debugged to get the
315    command working.
316    
317    =item options
318    
319    Reference to a hash containing the legal options for the current command mapped
320    to their default values. The use can override the defaults by specifying the
321    options as command-line switches prefixed by a hyphen. Tracing-related options
322    may be added to this hash.
323    
324    =item ARGV
325    
326    List of command line parameters, including the option switches, which must
327    precede the positional parameters and be prefixed by a hyphen.
328    
329    =item RETURN
330    
331    Returns a list. The first element of the list is the reference to a hash that
332    maps the command-line option switches to their values. These will either be the
333    default values or overrides specified on the command line. The remaining
334    elements of the list are the position parameters, in order.
335    
336    =back
337    
338    =cut
339    
340    sub StandardSetup {
341        # Get the parameters.
342        my ($categories, $options, @argv) = @_;
343        # Add the tracing options.
344        $options->{trace} = 3;
345        $options->{sql} = 0;
346        # Parse the command line.
347        my ($retOptions, @retParameters) = ParseCommand($options, @argv);
348        # Now we want to set up tracing. First, we need to know if SQL is to
349        # be traced.
350        my @cats = @{$categories};
351        if ($retOptions->{sql}) {
352            push @cats, "SQL";
353        }
354        # Add the default categories.
355        push @cats, "Tracer", "FIG";
356        # Next, we create the category string by prefixing the trace level
357        # and joining the categories.
358        my $cats = join(" ", $options->{trace}, @cats);
359        # Now set up the tracing.
360        TSetup($cats, "+>$FIG_Config::temp/trace.log");
361        # Return the parsed parameters.
362        return ($retOptions, @retParameters);
363    }
364    
365  =head3 Setups  =head3 Setups
366    
367  C<< my $count = Tracer::Setups(); >>  C<< my $count = Tracer::Setups(); >>
# Line 348  Line 522 
522    
523  =head3 OpenDir  =head3 OpenDir
524    
525  C<< my @files = OpenDir($dirName, $filtered); >>  C<< my @files = OpenDir($dirName, $filtered, $flag); >>
526    
527  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
528  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
529  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<$>),
530  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
531  for example,  filtered out of the return list. If the directory does not open and I<$flag> is not
532    set, an exception is thrown. So, for example,
533    
534      my @files = OpenDir("/Volumes/fig/contigs", 1);      my @files = OpenDir("/Volumes/fig/contigs", 1);
535    
536  is effectively the same as  is effectively the same as
537    
538      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");      opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
539      my @files = grep { $_ !~ /^\./ } readdir(TMP);      my @files = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir(TMP);
540    
541  Similarly, the following code  Similarly, the following code
542    
543      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs");      my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs", 0, 1);
544    
545  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
546  automatically throws an error if the directory fails to open.  automatically returns an empty list if the directory fails to open.
547    
548  =over 4  =over 4
549    
# Line 381  Line 556 
556  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
557  from the list, else FALSE.  from the list, else FALSE.
558    
559    =item flag
560    
561    TRUE if a failure to open is okay, else FALSE
562    
563  =back  =back
564    
565  =cut  =cut
566  #: Return Type @;  #: Return Type @;
567  sub OpenDir {  sub OpenDir {
568      # Get the parameters.      # Get the parameters.
569      my ($dirName, $filtered) = @_;      my ($dirName, $filtered, $flag) = @_;
570      # Declare the return variable.      # Declare the return variable.
571      my @retVal;      my @retVal = ();
572      # Open the directory.      # Open the directory.
573      if (opendir(my $dirHandle, $dirName)) {      if (opendir(my $dirHandle, $dirName)) {
574          # The directory opened successfully. Get the appropriate list according to the          # The directory opened successfully. Get the appropriate list according to the
575          # strictures of the filter parameter.          # strictures of the filter parameter.
576          if ($filtered) {          if ($filtered) {
577              @retVal = grep { $_ !~ /^\./ } readdir $dirHandle;              @retVal = grep { $_ !~ /^[\.\$\#]/ && $_ !~ /~$/ } readdir $dirHandle;
578          } else {          } else {
579              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
580          }          }
581      } else {      } elsif (! $flag) {
582          # Here the directory would not open.          # Here the directory would not open and it's considered an error.
583          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
584      }      }
585      # Return the result.      # Return the result.
# Line 824  Line 1003 
1003    
1004  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
1005    
1006  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
1007  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
1008  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  result is to reverse the effect of L</UnEscape>.
1009    
1010  =over 4  =over 4
1011    
# Line 850  Line 1029 
1029      # Loop through the parameter string, looking for sequences to escape.      # Loop through the parameter string, looking for sequences to escape.
1030      while (length $realString > 0) {      while (length $realString > 0) {
1031          # Look for the first sequence to escape.          # Look for the first sequence to escape.
1032          if ($realString =~ /^(.*?)([ \n\t\\])/) {          if ($realString =~ /^(.*?)([\n\t\r\\])/) {
1033              # 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
1034              # 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.
1035              $retVal .= $1;              $retVal .= $1;
1036              # Strip the processed section off the real string.              # Strip the processed section off the real string.
1037              $realString = substr $realString, (length $2) + (length $1);              $realString = substr $realString, (length $2) + (length $1);
1038              # Encode the escape sequence.              # Get the matched character.
1039              my $char = $2;              my $char = $2;
1040              $char =~ tr/ \t\n/btn/;              # If we have a CR, we are done.
1041                if ($char ne "\r") {
1042                    # It's not a CR, so encode the escape sequence.
1043                    $char =~ tr/\t\n/tn/;
1044              $retVal .= "\\" . $char;              $retVal .= "\\" . $char;
1045                }
1046          } else {          } else {
1047              # 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
1048              # transferred unmodified.              # transferred unmodified.
# Line 875  Line 1058 
1058    
1059  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
1060    
1061  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
1062  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
1063    be deleted.
1064    
1065  =over 4  =over 4
1066    
# Line 896  Line 1080 
1080  sub UnEscape {  sub UnEscape {
1081      # Get the parameter.      # Get the parameter.
1082      my ($codedString) = @_;      my ($codedString) = @_;
     Tracer("Coded string is \"$codedString\".") if T(4);  
1083      # Initialize the return variable.      # Initialize the return variable.
1084      my $retVal = "";      my $retVal = "";
1085      # Only proceed if the incoming string is nonempty.      # Only proceed if the incoming string is nonempty.
1086      if (defined $codedString) {      if (defined $codedString) {
1087          # 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
1088          # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
1089          # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
1090          while (length $codedString > 0) {          while (length $codedString > 0) {
1091              # Look for the first escape sequence.              # Look for the first escape sequence.
1092              if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) {
1093                  # Here we found it. The text preceding the sequence is in $1. The sequence                  # Here we found it. The text preceding the sequence is in $1. The sequence
1094                  # itself is in $2. First, move the clear text to the return variable.                  # itself is in $2. First, move the clear text to the return variable.
1095                  $retVal .= $1;                  $retVal .= $1;
1096                  $codedString = substr $codedString, (2 + length $1);                  $codedString = substr $codedString, (2 + length $1);
1097                  # Decode the escape sequence.                  # Get the escape value.
1098                  my $char = $2;                  my $char = $2;
1099                  $char =~ tr/\\btn/\\ \t\n/;                  # If we have a "\r", we are done.
1100                    if ($char ne 'r') {
1101                        # Here it's not an 'r', so we convert it.
1102                        $char =~ tr/\\tn/\\\t\n/;
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 1151  Line 1338 
1338  C<< Assert($condition1, $condition2, ... $conditionN); >>  C<< Assert($condition1, $condition2, ... $conditionN); >>
1339    
1340  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
1341  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.
1342  So, for example  So, for example
1343    
1344  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
# Line 1364  Line 1551 
1551  sub Strip {  sub Strip {
1552      # Get a copy of the parameter string.      # Get a copy of the parameter string.
1553      my ($string) = @_;      my ($string) = @_;
1554      my $retVal = $string;      my $retVal = (defined $string ? $string : "");
1555      # Strip the line terminator characters.      # Strip the line terminator characters.
1556      $retVal =~ s/(\r|\n)+$//g;      $retVal =~ s/(\r|\n)+$//g;
1557      # Return the result.      # Return the result.
# Line 1432  Line 1619 
1619      return $retVal;      return $retVal;
1620  }  }
1621    
1622    =head3 EOF
1623    
1624    This is a constant that is lexically greater than any useful string.
1625    
1626    =cut
1627    
1628    sub EOF {
1629        return "\xFF\xFF\xFF\xFF\xFF";
1630    }
1631    
1632  =head3 TICK  =head3 TICK
1633    
1634  C<< my @results = TICK($commandString); >>  C<< my @results = TICK($commandString); >>

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3