[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.11, Mon Jun 13 09:34:52 2005 UTC revision 1.26, Wed Sep 14 13:09:53 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 OpenDir);      @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 105  Line 111 
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  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 147  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 657  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 706  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 717  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 804  Line 824 
824    
825  C<< my $codedString = Tracer::Escape($realString); >>  C<< my $codedString = Tracer::Escape($realString); >>
826    
827  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
828  tabs replaced by C<\t>, new-lines replaced by C<\n>, and backslashes will be  replaced by C<\n>, and backslashes will be doubled. The effect is to exactly reverse the
829  doubled. The effect is to exactly reverse the effect of L</UnEscape>.  effect of L</UnEscape>.
830    
831  =over 4  =over 4
832    
# Line 834  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/tn/;
862                          $retVal .= "\\" . $char;                          $retVal .= "\\" . $char;
863                  } else {                  } else {
864                          # 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
# Line 854  Line 875 
875    
876  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
877    
878  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
879  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 back-slash.
880    
881  =over 4  =over 4
882    
# Line 880  Line 901 
901          # Only proceed if the incoming string is nonempty.          # Only proceed if the incoming string is nonempty.
902          if (defined $codedString) {          if (defined $codedString) {
903                  # 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
904                  # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\t" becomes
905                  # "\ " no matter what we do.)          # "\<tab>" no matter what we do.)
906                  while (length $codedString > 0) {                  while (length $codedString > 0) {
907                          # Look for the first escape sequence.                          # Look for the first escape sequence.
908                          if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {              if ($codedString =~ /^(.*?)\\(\\|n|t)/) {
909                                  # 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
910                                  # 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.
911                                  $retVal .= $1;                                  $retVal .= $1;
912                                  $codedString = substr $codedString, (2 + length $1);                                  $codedString = substr $codedString, (2 + length $1);
913                                  # Decode the escape sequence.                                  # Decode the escape sequence.
914                                  my $char = $2;                                  my $char = $2;
915                                  $char =~ tr/\\btn/\\ \t\n/;                  $char =~ tr/\\tn/\\\t\n/;
916                                  $retVal .= $char;                                  $retVal .= $char;
917                          } else {                          } else {
918                                  # 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
# Line 1028  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 1071  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 1086  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 1094  Line 1118 
1118    
1119  C<< Confess($message); >>  C<< Confess($message); >>
1120    
1121  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  
1122  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.
1123  So, for example  So, for example
1124    
# Line 1117  Line 1140 
1140          # Get the parameters.          # Get the parameters.
1141          my ($message) = @_;          my ($message) = @_;
1142          # Trace the call stack.          # Trace the call stack.
1143          Cluck($message) if T(1);      Cluck($message);
1144          # Abort the program.          # Abort the program.
1145          croak(">>> $message");          croak(">>> $message");
1146  }  }
# Line 1286  Line 1309 
1309    
1310  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1311    
1312  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
1313  an error page and return FALSE.  page and return FALSE.
1314    
1315  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1316  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1317  from working unless they are explicitly turned on in the configuration  from working unless they are explicitly turned on by creating a password
1318  file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1319  is not turned on, an error web page will be output.  is not turned on, an error web page will be output directing the
1320    user to enter in the correct password.
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 1368  Line 1394 
1394    
1395  =item padChar (optional)  =item padChar (optional)
1396    
1397    Character to use for padding. The default is a space.
1398    
1399  =item RETURN  =item RETURN
1400    
1401  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
1402  that it achieves the desired length.  specified end so that it achieves the desired length.
1403    
1404  =back  =back
1405    
# Line 1403  Line 1431 
1431          return $retVal;          return $retVal;
1432  }  }
1433    
1434    =head3 TICK
1435    
1436    C<< my @results = TICK($commandString); >>
1437    
1438    Perform a back-tick operation on a command. If this is a Windows environment, any leading
1439    dot-slash (C<./> will be removed. So, for example, if you were doing
1440    
1441        `./protein.cgi`
1442    
1443    from inside a CGI script, it would work fine in Unix, but would issue an error message
1444    in Windows complaining that C<'.'> is not a valid command. If instead you code
1445    
1446        TICK("./protein.cgi")
1447    
1448    it will work correctly in both environments.
1449    
1450    =over 4
1451    
1452    =item commandString
1453    
1454    The command string to pass to the system.
1455    
1456    =item RETURN
1457    
1458    Returns the standard output from the specified command, as a list.
1459    
1460    =back
1461    
1462    =cut
1463    #: Return Type @;
1464    sub TICK {
1465        # Get the parameters.
1466        my ($commandString) = @_;
1467        # Chop off the dot-slash if this is Windows.
1468        if ($FIG_Config::win_mode) {
1469            $commandString =~ s!^\./!!;
1470        }
1471        # Activate the command and return the result.
1472        return `$commandString`;
1473    }
1474    
1475  1;  1;

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.26

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3