[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.12, Thu Jun 23 23:21:09 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 161  Line 162 
162          if ($category eq '*') {          if ($category eq '*') {
163              $AllTrace = 1;              $AllTrace = 1;
164          } else {          } else {
165              $Categories{$category} = 1;              $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
# Line 670  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 734  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 && ($AllTrace || exists $Categories{$category}));          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
742      }      }
# Line 821  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 851  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 871  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 897  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 1045  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 1088  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 1103  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 1111  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 1134  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 1303  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 1385  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 1420  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.12  
changed lines
  Added in v.1.26

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3