[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.6, Mon Mar 7 02:01:51 2005 UTC revision 1.9, Wed May 4 03:05:12 2005 UTC
# Line 3  Line 3 
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);
6          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape);          @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;
11        use PageBuilder;
12    
13  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
14    
# Line 42  Line 44 
44    
45  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>  C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
46    
47  sets the trace level to 3, activated 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 idea is to make it easier to  specifies that messages should be output as HTML paragraphs. The parameters are formatted
49  input tracing configuration on a web form.  to make it easier to input tracing configuration on a web form.
50    
51  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
52  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 69  Line 71 
71  my $TraceLevel = 0;                     # trace level; a higher trace level produces more  my $TraceLevel = 0;                     # trace level; a higher trace level produces more
72                                                          # messages                                                          # messages
73  my @Queue = ();                         # queued list of trace messages.  my @Queue = ();                         # queued list of trace messages.
74    my $LastCategory = "main";  # name of the last category interrogated
75    
76  =head2 Public Methods  =head2 Public Methods
77    
# Line 370  Line 373 
373          my ($message) = @_;          my ($message) = @_;
374          # Get the timestamp.          # Get the timestamp.
375          my $timeStamp = Now();          my $timeStamp = Now();
376          # Format the message.          # Format the message. Note we strip off any line terminators at the end.
377          my $formatted = "$timeStamp $message";          my $formatted = "$timeStamp <$LastCategory>: " . Strip($message);
378          # Process according to the destination.          # Process according to the destination.
379          if ($Destination eq "TEXT") {          if ($Destination eq "TEXT") {
380                  # Write the message to the standard output.                  # Write the message to the standard output.
# Line 445  Line 448 
448                                  $category = $package;                                  $category = $package;
449                          }                          }
450                  }                  }
451                  # Use the package and tracelevel to compute the result.          # Save the category name.
452            $LastCategory = $category;
453                    # Use the category and tracelevel to compute the result.
454                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});                  $retVal = ($traceLevel <= $TraceLevel && exists $Categories{$category});
455      }      }
456          # Return the computed result.          # Return the computed result.
# Line 528  Line 533 
533          return ($optionTable, @retVal);          return ($optionTable, @retVal);
534  }  }
535    
536    =head3 Escape
537    
538    C<< my $codedString = Tracer::Escape($realString); >>
539    
540    Escape a string for use in a command length. Spaces will be replaced by C<\b>,
541    tabs replaced by C<\t>, new-lines replaced by C<\n>, and backslashes will be
542    doubled. The effect is to exactly reverse the effect of L</UnEscape>.
543    
544    =over 4
545    
546    =item realString
547    
548    String to escape.
549    
550    =item RETURN
551    
552    Escaped equivalent of the real string.
553    
554    =back
555    
556    =cut
557    
558    sub Escape {
559            # Get the parameter.
560            my ($realString) = @_;
561            # Initialize the return variable.
562            my $retVal = "";
563            # Loop through the parameter string, looking for sequences to escape.
564            while (length $realString > 0) {
565                    # Look for the first sequence to escape.
566                    if ($realString =~ /^(.*?)([ \n\t\\])/) {
567                            # Here we found it. The text preceding the sequence is in $1. The sequence
568                            # itself is in $2. First, move the clear text to the return variable.
569                            $retVal .= $1;
570                            $realString = substr $realString, (length $2 + length $1);
571                            # Encode the escape sequence.
572                            my $char = $2;
573                            $char =~ tr/ \t\n/btn/;
574                            $retVal .= "\\" . $char;
575                    } else {
576                            # Here there are no more escape sequences. The rest of the string is
577                            # transferred unmodified.
578                            $retVal .= $realString;
579                            $realString = "";
580                    }
581            }
582            # Return the result.
583            return $retVal;
584    }
585    
586  =head3 UnEscape  =head3 UnEscape
587    
588  C<< my $realString = Tracer::UnEscape($codedString); >>  C<< my $realString = Tracer::UnEscape($codedString); >>
# Line 555  Line 610 
610          my ($codedString) = @_;          my ($codedString) = @_;
611          # Initialize the return variable.          # Initialize the return variable.
612          my $retVal = "";          my $retVal = "";
613            # Only proceed if the incoming string is nonempty.
614            if (defined $codedString) {
615          # 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
616          # translating because it causes problems with the escaped slash. ("\\b" becomes          # translating because it causes problems with the escaped slash. ("\\b" becomes
617          # "\ " no matter what we do.)          # "\ " no matter what we do.)
# Line 576  Line 633 
633                          $codedString = "";                          $codedString = "";
634                  }                  }
635          }          }
636            }
637          # Return the result.          # Return the result.
638          return $retVal;          return $retVal;
639  }  }
# Line 705  Line 763 
763                  # 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.
764                  Trace("Could not open \"$fileName\" for input.") if T(0);                  Trace("Could not open \"$fileName\" for input.") if T(0);
765          } else {          } else {
766                  # Read the whole file into the return variable, stripping off an terminator                  # Read the whole file into the return variable, stripping off any terminator
767          # characters.          # characters.
768          my $lineCount = 0;          my $lineCount = 0;
769                  while (my $line = <INPUTFILE>) {                  while (my $line = <INPUTFILE>) {
770              $lineCount++;              $lineCount++;
771              $line =~ s/(\r|\n)+$//g;              $line = Strip($line);
772                          push @retVal, $line;                          push @retVal, $line;
773                  }                  }
774                  # Close it.                  # Close it.
775                  close INPUTFILE;                  close INPUTFILE;
776          my $actualLines = @retVal;          my $actualLines = @retVal;
777          Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(0);          Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(3);
778          }          }
779          # Return the file's contents in the desired format.          # Return the file's contents in the desired format.
780      if (wantarray) {      if (wantarray) {
# Line 958  Line 1016 
1016      }      }
1017  }  }
1018    
1019    =head3 DebugMode
1020    
1021    C<< if (Tracer::DebugMode) { ...code... } >>
1022    
1023    Return TRUE if debug mode has been turned on in FIG_Config, else output
1024    an error page and return FALSE.
1025    
1026    Certain CGI scripts are too dangerous to exist in the production
1027    environment. This method provides a simple way to prevent them
1028    from working unless they are explicitly turned on in the configuration
1029    file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode
1030    is not turned on, an error web page will be output.
1031    
1032    =cut
1033    
1034    sub DebugMode {
1035            # Declare the return variable.
1036            my $retVal;
1037            # Check the debug configuration.
1038            if ($FIG_Config::debug_mode) {
1039                    $retVal = 1;
1040            } else {
1041                    # Here debug mode is off, so we generate an error page.
1042            my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");
1043                    print $pageString;
1044            }
1045            # Return the determination indicator.
1046            return $retVal;
1047    }
1048    
1049    =head3 Strip
1050    
1051    C<< my $string = Tracer::Strip($line); >>
1052    
1053    Strip all line terminators off a string. This is necessary when dealing with files
1054    that may have been transferred back and forth several times among different
1055    operating environments.
1056    
1057    =over 4
1058    
1059    =item line
1060    
1061    Line of text to be stripped.
1062    
1063    =item RETURN
1064    
1065    The same line of text with all the line-ending characters chopped from the end.
1066    
1067    =back
1068    
1069    =cut
1070    
1071    sub Strip {
1072            # Get a copy of the parameter string.
1073            my ($string) = @_;
1074            my $retVal = $string;
1075        # Strip the line terminator characters.
1076        $retVal =~ s/(\r|\n)+$//g;
1077            # Return the result.
1078            return $retVal;
1079    }
1080    
1081    =head3 Pad
1082    
1083    C<< my $paddedString = Tracer::Pad($string, $len, $left, $padChar); >>
1084    
1085    Pad a string to a specified length. The pad character will be a
1086    space, and the padding will be on the right side unless specified
1087    in the third parameter.
1088    
1089    =over 4
1090    
1091    =item string
1092    
1093    String to be padded.
1094    
1095    =item len
1096    
1097    Desired length of the padded string.
1098    
1099    =item left (optional)
1100    
1101    TRUE if the string is to be left-padded; otherwise it will be padded on the right.
1102    
1103    =item padChar (optional)
1104    
1105    =item RETURN
1106    
1107    Returns a copy of the original string with the spaces added to the specified end so
1108    that it achieves the desired length.
1109    
1110    =back
1111    
1112    =cut
1113    
1114    sub Pad {
1115            # Get the parameters.
1116            my ($string, $len, $left, $padChar) = @_;
1117            # Compute the padding character.
1118            if (! defined $padChar) {
1119                    $padChar = " ";
1120            }
1121            # Compute the number of spaces needed.
1122            my $needed = $len - length $string;
1123            # Copy the string into the return variable.
1124            my $retVal = $string;
1125            # Only proceed if padding is needed.
1126            if ($needed > 0) {
1127                    # Create the pad string.
1128                    my $pad = $padChar x $needed;
1129                    # Affix it to the return value.
1130                    if ($left) {
1131                            $retVal = $pad . $retVal;
1132                    } else {
1133                            $retVal .= $pad;
1134                    }
1135            }
1136            # Return the result.
1137            return $retVal;
1138    }
1139    
1140  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3