[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.10, Thu Jun 9 05:36:30 2005 UTC revision 1.23, Tue Sep 13 05:36:12 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 Open);      @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 45  Line 46 
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  a little clumsily, but it makes them easier to input on a web form or in a query URL.  
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 104  Line 110 
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 146  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          # cases are the single ">", which requires we clear the file first, and the          # cases are the single ">", which requires we clear the file first, and the
# Line 169  Line 184 
184          } else {          } 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  =head3 Open
207    
208  C<< my $handle = Open($fileHandle, $fileSpec, $message); >>  C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
209    
210  Open a file and throw an exception if the open fails.  Open a file.
211    
212  The I<$fileSpec> is essentially the second argument of the PERL C<open>  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  function. The mode is specified using Unix-like shell information. So, for
# Line 188  Line 220 
220          Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");          Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
221    
222  would open a pipe that sorts the records written and removes duplicates. Note  would open a pipe that sorts the records written and removes duplicates. Note
223  that the file handle is specified as a string. Note the use of file handle  the use of file handle syntax in the Open call. To use anonymous file handles,
224  syntax in the Open call. To use anonymous file handles, code as follows.  code as follows.
225    
226          my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");          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 to construct an error message.  The I<$message> parameter is used if the open fails. If it is set to C<0>, then
229  If the parameter is omitted, a standard message is constructed using the file spec.  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"          Could not open "/usr/spool/news/twitlog"
235    
# Line 209  Line 244 
244    
245          Could not open "/usr/spool/news/twitlog": 6.          Could not open "/usr/spool/news/twitlog": 6.
246    
 This method has no provision for passing back error information. Its purpose is  
 to simplify the standard coding practice of opening files and killing the process  
 if the open doesn't work. If the trace level for C<Tracer> is set to level 1,  
 it will automatically show a stack trace as well.  
   
247  =over 4  =over 4
248    
249  =item fileHandle  =item fileHandle
# Line 229  Line 259 
259    
260  Error message to use if the open fails. If omitted, a standard error message  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  will be generated. In either case, the error information from the file system
262  is appended to the message.  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  =item RETURN
266    
267  Returns the name of the file handle assigned to the file.  Returns the name of the file handle assigned to the file, or C<undef> if the
268    open failed.
269    
270  =back  =back
271    
# Line 248  Line 280 
280          if (! $rv) {          if (! $rv) {
281                  # Save the system error message.                  # Save the system error message.
282                  my $sysMessage = $!;                  my $sysMessage = $!;
283            # See if we need a default message.
284            if (!$message) {
285                  # Clean any obvious mode characters and leading spaces from the                  # Clean any obvious mode characters and leading spaces from the
286                  # filename.                  # filename.
287                  $fileSpec =~ s/^(<|>*)\s*//;              my ($fileName) = FindNamePart($fileSpec);
288                  if (!$message) {              $message = "Could not open \"$fileName\"";
                         $message = "Could not open \"$fileSpec\"";  
289                  }                  }
290                  # Terminate with an error using the supplied message and the                  # Terminate with an error using the supplied message and the
291                  # error message from the file system.                  # error message from the file system.
# Line 262  Line 295 
295          return $fileHandle;          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
411    
412  C<< Tracer::SetLevel($newLevel); >>  C<< Tracer::SetLevel($newLevel); >>
# Line 526  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.                  # If the Tee flag is on, echo it to the standard output.
# Line 575  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 586  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 703  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 744  Line 896 
896  sub UnEscape {  sub UnEscape {
897          # Get the parameter.          # Get the parameter.
898          my ($codedString) = @_;          my ($codedString) = @_;
899        Tracer("Coded string is \"$codedString\".") if T(4);
900          # Initialize the return variable.          # Initialize the return variable.
901          my $retVal = "";          my $retVal = "";
902          # Only proceed if the incoming string is nonempty.          # Only proceed if the incoming string is nonempty.
# Line 897  Line 1050 
1050          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
1051          if (!$ok) {          if (!$ok) {
1052                  # 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.
1053                  Trace("Could not open \"$fileName\" for input.") if T(0);          Trace("Could not open \"$fileName\" for input: $!") if T(0);
1054          } else {          } else {
1055                  # Read the whole file into the return variable, stripping off any terminator                  # Read the whole file into the return variable, stripping off any terminator
1056          # characters.          # characters.
# Line 940  Line 1093 
1093          my ($format) = @_;          my ($format) = @_;
1094          # Create the return variable.          # Create the return variable.
1095          my $retVal = "";          my $retVal = "";
1096        # Only proceed if there is an actual queue.
1097        if (@Queue) {
1098          # Process according to the format.          # Process according to the format.
1099          if ($format =~ m/^HTML$/i) {          if ($format =~ m/^HTML$/i) {
1100                  # Convert the queue into an HTML list.                  # Convert the queue into an HTML list.
# Line 955  Line 1110 
1110          }          }
1111          # Clear the queue.          # Clear the queue.
1112          @Queue = ();          @Queue = ();
1113        }
1114          # Return the formatted list.          # Return the formatted list.
1115          return $retVal;          return $retVal;
1116  }  }
# Line 963  Line 1119 
1119    
1120  C<< Confess($message); >>  C<< Confess($message); >>
1121    
1122  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  
1123  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.
1124  So, for example  So, for example
1125    
# Line 986  Line 1141 
1141          # Get the parameters.          # Get the parameters.
1142          my ($message) = @_;          my ($message) = @_;
1143          # Trace the call stack.          # Trace the call stack.
1144          Cluck($message) if T(1);      Cluck($message);
1145          # Abort the program.          # Abort the program.
1146          croak(">>> $message");          croak(">>> $message");
1147  }  }
# Line 1155  Line 1310 
1310    
1311  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1312    
1313  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
1314  an error page and return FALSE.  page and return FALSE.
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 directing the
1321    user to enter in the correct password.
1322    
1323  =cut  =cut
1324    
1325  sub DebugMode {  sub DebugMode {
1326          # Declare the return variable.          # Declare the return variable.
1327          my $retVal;      my $retVal = 0;
1328          # Check the debug configuration.          # Check the debug configuration.
1329          if ($FIG_Config::debug_mode) {      my $password = CGI::cookie("DebugMode");
1330        my $encrypted = Digest::MD5::md5_hex($password);
1331        if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1332                  $retVal = 1;                  $retVal = 1;
1333          } else {          } else {
1334                  # Here debug mode is off, so we generate an error page.                  # Here debug mode is off, so we generate an error page.
# Line 1237  Line 1395 
1395    
1396  =item padChar (optional)  =item padChar (optional)
1397    
1398    Character to use for padding. The default is a space.
1399    
1400  =item RETURN  =item RETURN
1401    
1402  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
1403  that it achieves the desired length.  specified end so that it achieves the desired length.
1404    
1405  =back  =back
1406    
# Line 1272  Line 1432 
1432          return $retVal;          return $retVal;
1433  }  }
1434    
1435    =head3 TICK
1436    
1437    C<< my @results = TICK($commandString); >>
1438    
1439    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1440    dot-slash (C<./> will be removed. So, for example, if you were doing
1441    
1442        `./protein.cgi`
1443    
1444    from inside a CGI script, it would work fine in Unix, but would issue an error message
1445    in Windows complaining that C<'.'> is not a valid command. If instead you code
1446    
1447        TICK("./protein.cgi")
1448    
1449    it will work correctly in both environments.
1450    
1451    =over 4
1452    
1453    =item commandString
1454    
1455    The command string to pass to the system.
1456    
1457    =item RETURN
1458    
1459    Returns the standard output from the specified command, as a list.
1460    
1461    =back
1462    
1463    =cut
1464    #: Return Type @;
1465    sub TICK {
1466        # Get the parameters.
1467        my ($commandString) = @_;
1468        # Chop off the dot-slash if this is Windows.
1469        if ($FIG_Config::win_mode) {
1470            $commandString =~ s!^\./!!;
1471        }
1472        # Activate the command and return the result.
1473        return `$commandString`;
1474    }
1475    
1476  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3