[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.4, Thu Jan 27 00:32:17 2005 UTC revision 1.5, Fri Feb 25 18:38:49 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);
6          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape);          @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape);
7          use strict;          use strict;
8          use Carp qw(longmess croak);          use Carp qw(longmess croak);
# Line 93  Line 93 
93  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
94  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
95  cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>  cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
96  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
97  to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will cause  messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace
98    messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will cause
99  trace messages to be emitted as warnings using the B<warn> directive.  C<NONE> will cause  trace messages to be emitted as warnings using the B<warn> directive.  C<NONE> will cause
100  tracing to be suppressed.  tracing to be suppressed.
101    
# Line 171  Line 172 
172          open STDERR, '>', $fileName;          open STDERR, '>', $fileName;
173  }  }
174    
175    =head3 ReadOptions
176    
177    C<< my %options = Tracer::ReadOptions($fileName); >>
178    
179    Read a set of options from a file. Each option is encoded in a line of text that has the
180    format
181    
182    I<optionName>C<=>I<optionValue>C<; >I<comment>
183    
184    The option name must consist entirely of letters, digits, and the punctuation characters
185    C<.> and C<_>, and is case sensitive. Blank lines and lines in which the first nonblank
186    character is a semi-colon will be ignored. The return hash will map each option name to
187    the corresponding option value.
188    
189    =over 4
190    
191    =item fileName
192    
193    Name of the file containing the option data.
194    
195    =item RETURN
196    
197    Returns a hash mapping the option names specified in the file to their corresponding option
198    value.
199    
200    =back
201    
202    =cut
203    
204    sub ReadOptions {
205            # Get the parameters.
206            my ($fileName) = @_;
207            # Open the file.
208            (open CONFIGFILE, "<$fileName") || Confess("Could not open option file $fileName.");
209            # Count the number of records read.
210            my ($records, $comments) = 0;
211            # Create the return hash.
212            my %retVal = ();
213            # Loop through the file, accumulating key-value pairs.
214            while (my $line = <CONFIGFILE>) {
215                    # Denote we've read a line.
216                    $records++;
217                    # Determine the line type.
218                    if ($line =~ /^\s*[\n\r]/) {
219                            # A blank line is a comment.
220                            $comments++;
221                    } elsif ($line =~ /^\s*([A-Za-z0-9_\.]+)=([^;]*);/) {
222                            # Here we have an option assignment.
223                            retVal{$1} = $2;
224                    } elsif ($line =~ /^\s*;/) {
225                            # Here we have a text comment.
226                            $comments++;
227                    } else {
228                            # Here we have an invalid line.
229                            Trace("Invalid option statement in record $records.") if T(0);
230                    }
231            }
232            # Return the hash created.
233            return %retVal;
234    }
235    
236  =head3 GetOptions  =head3 GetOptions
237    
238  C<< Tracer::GetOptions(\%defaults, \%options); >>  C<< Tracer::GetOptions(\%defaults, \%options); >>
# Line 288  Line 350 
350          my ($message) = @_;          my ($message) = @_;
351          # Get the timestamp.          # Get the timestamp.
352          my $timeStamp = Now();          my $timeStamp = Now();
353            # Format the message.
354            my $formatted = "$timeStamp $message";
355          # Process according to the destination.          # Process according to the destination.
356          if ($Destination eq "TEXT") {          if ($Destination eq "TEXT") {
357                  # Write the message to the standard output.                  # Write the message to the standard output.
358                  print "$timeStamp $message\n";                  print "$formatted\n";
359            } elsif ($Destination eq "ERROR") {
360                    # Write the message to the error output.
361                    print STDERR "$formatted\n";
362          } elsif ($Destination eq "QUEUE") {          } elsif ($Destination eq "QUEUE") {
363                  # Push the message into the queue.                  # Push the message into the queue.
364                  push @Queue, "$timeStamp $message";                  push @Queue, "$formatted";
365          } elsif ($Destination eq "HTML") {          } elsif ($Destination eq "HTML") {
366                  # Convert the message to HTML and write it to the standard output.                  # Convert the message to HTML and write it to the standard output.
367                  my $escapedMessage = CGI::escapeHTML($message);                  my $escapedMessage = CGI::escapeHTML($message);
368                  print "<p>$timeStamp $message</p>\n";                  print "<p>$formatted</p>\n";
369      } elsif ($Destination eq "WARN") {      } elsif ($Destination eq "WARN") {
370         # Emit the message as a warning.         # Emit the message as a warning.
371         warn $message;         warn $message;
372          } elsif ($Destination =~ m/^>>/) {          } elsif ($Destination =~ m/^>>/) {
373                  # Write the trace message to an output file.                  # Write the trace message to an output file.
374                  open TRACING, $Destination;                  open TRACING, $Destination;
375                  print TRACING "$timeStamp $message\n";                  print TRACING "$formatted\n";
376                  close TRACING;                  close TRACING;
377          }          }
378  }  }
# Line 697  Line 764 
764          # Trace the call stack.          # Trace the call stack.
765          Cluck($message) if T(1);          Cluck($message) if T(1);
766          # Abort the program.          # Abort the program.
767          die $message;          croak(">>> $message");
768  }  }
769    
770  =head3 Cluck  =head3 Cluck
# Line 724  Line 791 
791  sub Cluck {  sub Cluck {
792          # Get the parameters.          # Get the parameters.
793          my ($message) = @_;          my ($message) = @_;
794        # Trace what's happening.
795        Trace("Stack trace for event: $message");
796          my $confession = longmess($message);          my $confession = longmess($message);
797          # Convert the confession to a series of trace messages.          # Convert the confession to a series of trace messages. Note we skip any
798        # messages relating to calls into Tracer.
799          for my $line (split /\s*\n/, $confession) {          for my $line (split /\s*\n/, $confession) {
800                  Trace($line);                  Trace($line) if ($line !~ /Tracer\.pm/);
801          }          }
802  }  }
803    
804    =head3 Min
805    
806    C<< my $min = Min($value1, $value2, ... $valueN); >>
807    
808    Return the minimum argument. The arguments are treated as numbers.
809    
810    =over 4
811    
812    =item $value1, $value2, ... $valueN
813    
814    List of numbers to compare.
815    
816    =item RETURN
817    
818    Returns the lowest number in the list.
819    
820    =back
821    
822    =cut
823    
824    sub Min {
825            # Get the parameters. Note that we prime the return value with the first parameter.
826            my ($retVal, @values) = @_;
827            # Loop through the remaining parameters, looking for the lowest.
828            for my $value (@values) {
829                    if ($value < $retVal) {
830                            $retVal = $value;
831                    }
832            }
833            # Return the minimum found.
834            return $retVal;
835    }
836    
837    =head3 Max
838    
839    C<< my $max = Max($value1, $value2, ... $valueN); >>
840    
841    Return the maximum argument. The arguments are treated as numbers.
842    
843    =over 4
844    
845    =item $value1, $value2, ... $valueN
846    
847    List of numbers to compare.
848    
849    =item RETURN
850    
851    Returns the highest number in the list.
852    
853    =back
854    
855    =cut
856    
857    sub Max {
858            # Get the parameters. Note that we prime the return value with the first parameter.
859            my ($retVal, @values) = @_;
860            # Loop through the remaining parameters, looking for the highest.
861            for my $value (@values) {
862                    if ($value > $retVal) {
863                            $retVal = $value;
864                    }
865            }
866            # Return the maximum found.
867            return $retVal;
868    }
869    
870    =head3 AddToListMap
871    
872    C<< Tracer::AddToListMap(\%hash, $key, $value); >>
873    
874    Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list
875    is created for the key. Otherwise, the new value is pushed onto the list.
876    
877    =over 4
878    
879    =item hash
880    
881    Reference to the target hash.
882    
883    =item key
884    
885    Key for which the value is to be added.
886    
887    =item value
888    
889    Value to add to the key's value list.
890    
891    =back
892    
893    =cut
894    
895    sub AddToListMap {
896        # Get the parameters.
897        my ($hash, $key, $value) = @_;
898        # Process according to whether or not the key already has a value.
899        if (! exists $hash->{$key}) {
900            $hash->{$key} = [$value];
901        } else {
902            push @{$hash->{$key}}, $value;
903        }
904    }
905    
906  1;  1;

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3