[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.5, Fri Feb 25 18:38:49 2005 UTC revision 1.9, Wed May 4 03:05: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);          @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 91  Line 94 
94  The destination for the trace output. To send the trace output to a file, specify the file  The destination for the trace output. To send the trace output to a file, specify the file
95  name preceded by a ">" symbol. If a double symbol is used (">>"), then the data is appended  name preceded by a ">" symbol. If a double symbol is used (">>"), then the data is appended
96  to the file. Otherwise the file is cleared before tracing begins. In addition to sending  to the file. Otherwise the file is cleared before tracing begins. In addition to sending
97  the trace messages to a file, you can specify a special destination. C<HTML> will  the trace messages to a file, you can specify a special destination. C<HTML> will cause
98  cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>  tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
99  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace
100  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace
101  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will cause  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
102  trace messages to be emitted as warnings using the B<warn> directive.  C<NONE> will cause  cause trace messages to be emitted as warnings using the B<warn> directive.  C<NONE> will
103  tracing to be suppressed.  cause tracing to be suppressed.
104    
105  =back  =back
106    
# Line 127  Line 130 
130          }          }
131  }  }
132    
133    =head3 SetLevel
134    
135    C<< Tracer::SetLevel($newLevel); >>
136    
137    Modify the trace level. A higher trace level will cause more messages to appear.
138    
139    =over 4
140    
141    =item newLevel
142    
143    Proposed new trace level.
144    
145    =back
146    
147    =cut
148    
149    sub SetLevel {
150        $TraceLevel = $_[0];
151    }
152    
153  =head3 Now  =head3 Now
154    
155  C<< my $string = Tracer::Now(); >>  C<< my $string = Tracer::Now(); >>
# Line 350  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 425  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 508  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 535  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 556  Line 633 
633                          $codedString = "";                          $codedString = "";
634                  }                  }
635          }          }
636            }
637          # Return the result.          # Return the result.
638          return $retVal;          return $retVal;
639  }  }
# Line 655  Line 733 
733    
734  =head3 GetFile  =head3 GetFile
735    
736  C<< my $fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
737    
738  Return the entire contents of a file.  Return the entire contents of a file.
739    
# Line 667  Line 745 
745    
746  =item RETURN  =item RETURN
747    
748  Returns the entire file as a single string. If an error occurs, will return  In a list context, returns the entire file as a list with the line terminators removed.
749  an empty string.  In a scalar context, returns the entire file as a string.
750    
751  =back  =back
752    
# Line 678  Line 756 
756          # Get the parameters.          # Get the parameters.
757          my ($fileName) = @_;          my ($fileName) = @_;
758          # Declare the return variable.          # Declare the return variable.
759          my $retVal = "";          my @retVal = ();
760          # Open the file for input.          # Open the file for input.
761          my $ok = open INPUTFILE, "<$fileName";          my $ok = open INPUTFILE, "<$fileName";
762          if (!$ok) {          if (!$ok) {
763                  # If we had an error, trace it. We will automatically return a null string.                  # If we had an error, trace it. We will automatically return a null value.
764                  Trace(0, "Could not open \"$fileName\" for input.");                  Trace("Could not open \"$fileName\" for input.") if T(0);
765          } else {          } else {
766                  # Read the whole file into the return variable.                  # Read the whole file into the return variable, stripping off any terminator
767                  while (<INPUTFILE>) {          # characters.
768                          $retVal .= $_;          my $lineCount = 0;
769                    while (my $line = <INPUTFILE>) {
770                $lineCount++;
771                $line = Strip($line);
772                            push @retVal, $line;
773                  }                  }
774                  # Close it.                  # Close it.
775                  close INPUTFILE;                  close INPUTFILE;
776            my $actualLines = @retVal;
777            Trace("$lineCount lines read from $fileName. $actualLines processed.") if T(3);
778            }
779            # Return the file's contents in the desired format.
780        if (wantarray) {
781                return @retVal;
782        } else {
783            return join "\n", @retVal;
784          }          }
         # Return the file's contents.  
         return $retVal;  
785  }  }
786    
787  =head3 QTrace  =head3 QTrace
# Line 742  Line 830 
830    
831  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. The stack
832  trace will only appear if the trace level for this package is 1 or more. When used with  trace will only appear if the trace level for this package is 1 or more. When used with
833  the OR operator, this method can function as a debugging assert. So, for example  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.
834    So, for example
835    
836  C<< ($recNum >= 0) || Confess("Invalid record number $recNum."); >>  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
837    
838  Will abort the program with a stack trace if the value of C<$recNum> is negative.  Will abort the program with a stack trace if the value of C<$recNum> is negative.
839    
# Line 767  Line 856 
856          croak(">>> $message");          croak(">>> $message");
857  }  }
858    
859    =head3 Assert
860    
861    C<< Assert($condition1, $condition2, ... $conditionN); >>
862    
863    Return TRUE if all the conditions are true. This method can be used in conjunction with
864    the OR operator and the L</Confess> method, B<Assert> can function as a debugging assert.
865    So, for example
866    
867    C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
868    
869    Will abort the program with a stack trace if the value of C<$recNum> is negative.
870    
871    =cut
872    sub Assert {
873        my $retVal = 1;
874        LOOP: for my $condition (@_) {
875            if (! $condition) {
876                $retVal = 0;
877                last LOOP;
878            }
879        }
880        return $retVal;
881    }
882    
883  =head3 Cluck  =head3 Cluck
884    
885  C<< Cluck($message); >>  C<< Cluck($message); >>
# Line 903  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.5  
changed lines
  Added in v.1.9

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3