[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.3, Mon Jan 24 07:05:56 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);          @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 52  Line 54 
54  the page output, they can be gathered together and displayed at the end of the page. This makes  the page output, they can be gathered together and displayed at the end of the page. This makes
55  it easier to debug page formatting problems.  it easier to debug page formatting problems.
56    
57    Finally, you can specify that all trace messages be emitted as warnings.
58    
59  The flexibility of tracing makes it superior to simple use of directives like C<die> and C<warn>.  The flexibility of tracing makes it superior to simple use of directives like C<die> and C<warn>.
60  Tracer calls can be left in the code with minimal overhead and then turned on only when needed.  Tracer calls can be left in the code with minimal overhead and then turned on only when needed.
61  Thus, debugging information is available and easily retrieved even when the application is  Thus, debugging information is available and easily retrieved even when the application is
# Line 67  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 89  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 XX special destinations. 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<QUEUE> will cause trace messages  will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace
100  to be stored in a queue for later retrieval by the L</QTrace> method. C<NONE> will cause  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace
101  tracing to be suppressed.  messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
102    cause trace messages to be emitted as warnings using the B<warn> directive.  C<NONE> will
103    cause tracing to be suppressed.
104    
105  =back  =back
106    
# Line 123  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 168  Line 195 
195          open STDERR, '>', $fileName;          open STDERR, '>', $fileName;
196  }  }
197    
198    =head3 ReadOptions
199    
200    C<< my %options = Tracer::ReadOptions($fileName); >>
201    
202    Read a set of options from a file. Each option is encoded in a line of text that has the
203    format
204    
205    I<optionName>C<=>I<optionValue>C<; >I<comment>
206    
207    The option name must consist entirely of letters, digits, and the punctuation characters
208    C<.> and C<_>, and is case sensitive. Blank lines and lines in which the first nonblank
209    character is a semi-colon will be ignored. The return hash will map each option name to
210    the corresponding option value.
211    
212    =over 4
213    
214    =item fileName
215    
216    Name of the file containing the option data.
217    
218    =item RETURN
219    
220    Returns a hash mapping the option names specified in the file to their corresponding option
221    value.
222    
223    =back
224    
225    =cut
226    
227    sub ReadOptions {
228            # Get the parameters.
229            my ($fileName) = @_;
230            # Open the file.
231            (open CONFIGFILE, "<$fileName") || Confess("Could not open option file $fileName.");
232            # Count the number of records read.
233            my ($records, $comments) = 0;
234            # Create the return hash.
235            my %retVal = ();
236            # Loop through the file, accumulating key-value pairs.
237            while (my $line = <CONFIGFILE>) {
238                    # Denote we've read a line.
239                    $records++;
240                    # Determine the line type.
241                    if ($line =~ /^\s*[\n\r]/) {
242                            # A blank line is a comment.
243                            $comments++;
244                    } elsif ($line =~ /^\s*([A-Za-z0-9_\.]+)=([^;]*);/) {
245                            # Here we have an option assignment.
246                            retVal{$1} = $2;
247                    } elsif ($line =~ /^\s*;/) {
248                            # Here we have a text comment.
249                            $comments++;
250                    } else {
251                            # Here we have an invalid line.
252                            Trace("Invalid option statement in record $records.") if T(0);
253                    }
254            }
255            # Return the hash created.
256            return %retVal;
257    }
258    
259  =head3 GetOptions  =head3 GetOptions
260    
261  C<< Tracer::GetOptions(\%defaults, \%options); >>  C<< Tracer::GetOptions(\%defaults, \%options); >>
# Line 285  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. Note we strip off any line terminators at the end.
377            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.
381                  print "$timeStamp $message\n";                  print "$formatted\n";
382            } elsif ($Destination eq "ERROR") {
383                    # Write the message to the error output.
384                    print STDERR "$formatted\n";
385          } elsif ($Destination eq "QUEUE") {          } elsif ($Destination eq "QUEUE") {
386                  # Push the message into the queue.                  # Push the message into the queue.
387                  push @Queue, "$timeStamp $message";                  push @Queue, "$formatted";
388          } elsif ($Destination eq "HTML") {          } elsif ($Destination eq "HTML") {
389                  # Convert the message to HTML and write it to the standard output.                  # Convert the message to HTML and write it to the standard output.
390                  my $escapedMessage = CGI::escapeHTML($message);                  my $escapedMessage = CGI::escapeHTML($message);
391                  print "<p>$timeStamp $message</p>\n";                  print "<p>$formatted</p>\n";
392        } elsif ($Destination eq "WARN") {
393           # Emit the message as a warning.
394           warn $message;
395          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
396                  # Write the trace message to an output file.                  # Write the trace message to an output file.
397                  open TRACING, $Destination;                  open TRACING, $Destination;
398                  print TRACING "$timeStamp $message\n";                  print TRACING "$formatted\n";
399                  close TRACING;                  close TRACING;
400          }          }
401  }  }
# Line 352  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 435  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 462  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 483  Line 633 
633                          $codedString = "";                          $codedString = "";
634                  }                  }
635          }          }
636            }
637          # Return the result.          # Return the result.
638          return $retVal;          return $retVal;
639  }  }
# Line 582  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 594  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 605  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 669  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 691  Line 853 
853          # Trace the call stack.          # Trace the call stack.
854          Cluck($message) if T(1);          Cluck($message) if T(1);
855          # Abort the program.          # Abort the program.
856          die $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
# Line 718  Line 904 
904  sub Cluck {  sub Cluck {
905          # Get the parameters.          # Get the parameters.
906          my ($message) = @_;          my ($message) = @_;
907        # Trace what's happening.
908        Trace("Stack trace for event: $message");
909          my $confession = longmess($message);          my $confession = longmess($message);
910          # Convert the confession to a series of trace messages.          # Convert the confession to a series of trace messages. Note we skip any
911        # messages relating to calls into Tracer.
912          for my $line (split /\s*\n/, $confession) {          for my $line (split /\s*\n/, $confession) {
913                  Trace($line);                  Trace($line) if ($line !~ /Tracer\.pm/);
914            }
915    }
916    
917    =head3 Min
918    
919    C<< my $min = Min($value1, $value2, ... $valueN); >>
920    
921    Return the minimum argument. The arguments are treated as numbers.
922    
923    =over 4
924    
925    =item $value1, $value2, ... $valueN
926    
927    List of numbers to compare.
928    
929    =item RETURN
930    
931    Returns the lowest number in the list.
932    
933    =back
934    
935    =cut
936    
937    sub Min {
938            # Get the parameters. Note that we prime the return value with the first parameter.
939            my ($retVal, @values) = @_;
940            # Loop through the remaining parameters, looking for the lowest.
941            for my $value (@values) {
942                    if ($value < $retVal) {
943                            $retVal = $value;
944                    }
945            }
946            # Return the minimum found.
947            return $retVal;
948    }
949    
950    =head3 Max
951    
952    C<< my $max = Max($value1, $value2, ... $valueN); >>
953    
954    Return the maximum argument. The arguments are treated as numbers.
955    
956    =over 4
957    
958    =item $value1, $value2, ... $valueN
959    
960    List of numbers to compare.
961    
962    =item RETURN
963    
964    Returns the highest number in the list.
965    
966    =back
967    
968    =cut
969    
970    sub Max {
971            # Get the parameters. Note that we prime the return value with the first parameter.
972            my ($retVal, @values) = @_;
973            # Loop through the remaining parameters, looking for the highest.
974            for my $value (@values) {
975                    if ($value > $retVal) {
976                            $retVal = $value;
977                    }
978          }          }
979            # Return the maximum found.
980            return $retVal;
981  }  }
982    
983    =head3 AddToListMap
984    
985    C<< Tracer::AddToListMap(\%hash, $key, $value); >>
986    
987    Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list
988    is created for the key. Otherwise, the new value is pushed onto the list.
989    
990    =over 4
991    
992    =item hash
993    
994    Reference to the target hash.
995    
996    =item key
997    
998    Key for which the value is to be added.
999    
1000    =item value
1001    
1002    Value to add to the key's value list.
1003    
1004    =back
1005    
1006    =cut
1007    
1008    sub AddToListMap {
1009        # Get the parameters.
1010        my ($hash, $key, $value) = @_;
1011        # Process according to whether or not the key already has a value.
1012        if (! exists $hash->{$key}) {
1013            $hash->{$key} = [$value];
1014        } else {
1015            push @{$hash->{$key}}, $value;
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.3  
changed lines
  Added in v.1.9

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3