Parent Directory
| 
Revision Log
Fixed tracing so that the category is no longer case-sensitive.
package Tracer;
require Exporter;
@ISA = ('Exporter');
@EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir);
@EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
use strict;
use Carp qw(longmess croak);
use CGI;
use FIG_Config;
use PageBuilder;
=head1 Tracing and Debugging Helpers
=head2 Introduction
This package provides simple tracing for debugging and reporting purposes. To use it simply call the
L</TSetup> method to set the options and call L</Trace> to write out trace messages. Each trace
message has a I<trace level> and I<category> associated with it. In addition, the tracing package itself
has a list of categories and a single trace level set by the B<TSetup> method. Only messages whose trace
level is less than or equal to this package's trace level and whose category is activated will
be written. Thus, a higher trace level on a message indicates that the message
is less likely to be seen. A higher trace level passed to B<TSetup> means more trace messages will
appear. To generate a trace message, use the following syntax.
C<< Trace($message) if T(errors => 4); >>
This statement will produce a trace message if the trace level is 4 or more and the C<errors>
category is active. Note that the special category C<main> is always active, so
C<< Trace($message) if T(main => 4); >>
will trace if the trace level is 4 or more.
If the category name is the same as the package name, all you need is the number. So, if the
following call is made in the B<Sprout> package, it will appear if the C<Sprout> category is
active and the trace level is 2 or more.
C<< Trace($message) if T(2); >>
To set up tracing, you call the L</TSetup> method. The method takes as input a trace level, a list
of category names, and a set of options. The trace level and list of category names are
specified as a space-delimited string. Thus
C<< TSetup('3 errors Sprout ERDB', 'HTML'); >>
sets the trace level to 3, activates the C<errors>, C<Sprout>, and C<ERDB> categories, and
specifies that messages should be output as HTML paragraphs.
To turn on tracing for ALL categories, use an asterisk. The call below sets every category to
level 3 and writes the output to the standard error output. This sort of thing might be
useful in a CGI environment.
C<< TSetup('3 *', 'WARN'); >>
In addition to HTML and file output for trace messages, you can specify that the trace messages
be queued. The messages can then be retrieved by calling the L</QTrace> method. This approach
is useful if you are building a web page. Instead of having the trace messages interspersed with
the page output, they can be gathered together and displayed at the end of the page. This makes
it easier to debug page formatting problems.
Finally, you can specify that all trace messages be emitted as warnings.
The flexibility of tracing makes it superior to simple use of directives like C<die> and C<warn>.
Tracer calls can be left in the code with minimal overhead and then turned on only when needed.
Thus, debugging information is available and easily retrieved even when the application is
being used out in the field.
There is no hard and fast rule on how to use trace levels. The following is therefore only
a suggestion.
=over 4
=item 0 Error
Message indicates an error that may lead to incorrect results or that has stopped the
application entirely.
=item 1 Warning
Message indicates something that is unexpected but that probably did not interfere
with program execution.
=item 2 Notice
Message indicates the beginning or end of a major task.
=item 3 Information
Message indicates a subtask. In the FIG system, a subtask generally relates to a single
genome. This would be a big loop that is not expected to execute more than 500 times or so.
=item 4 Detail
Message indicates a low-level loop iteration.
=back
=cut
# Declare the configuration variables.
my $Destination = "NONE"; # Description of where to send the trace output.
my $TeeFlag = 0; # TRUE if output is going to a file and to the
# standard output
my %Categories = ( main => 1 );
# hash of active category names
my $TraceLevel = 0; # trace level; a higher trace level produces more
# messages
my @Queue = (); # queued list of trace messages.
my $LastCategory = "main"; # name of the last category interrogated
my $SetupCount = 0; # number of times TSetup called
my $AllTrace = 0; # TRUE if we are tracing all categories.
=head2 Public Methods
=head3 TSetup
C<< TSetup($categoryList, $target); >>
This method is used to specify the trace options. The options are stored as package data
and interrogated by the L</Trace> and L</T> methods.
=over 4
=item categoryList
A string specifying the trace level and the categories to be traced, separated by spaces.
The trace level must come first.
=item target
The destination for the trace output. To send the trace output to a file, specify the file
name preceded by a ">" symbol. If a double symbol is used (">>"), then the data is appended
to the file. Otherwise the file is cleared before tracing begins. Precede the first ">"
symbol with a C<+> to echo output to a file AND to the standard output. In addition to
sending the trace messages to a file, you can specify a special destination. C<HTML> will
cause tracing to the standard output with each line formatted as an HTML paragraph. C<TEXT>
will cause tracing to the standard output as ordinary text. C<ERROR> will cause trace
messages to be sent to the standard error output as ordinary text. C<QUEUE> will cause trace
messages to be stored in a queue for later retrieval by the L</QTrace> method. C<WARN> will
cause trace messages to be emitted as warnings using the B<warn> directive. C<NONE> will
cause tracing to be suppressed.
=back
=cut
sub TSetup {
# Get the parameters.
my ($categoryList, $target) = @_;
# Parse the category list.
my @categoryData = split /\s+/, $categoryList;
# Extract the trace level.
$TraceLevel = shift @categoryData;
# Presume category-based tracing until we learn otherwise.
$AllTrace = 0;
# Build the category hash. Note that if we find a "*", we turn on non-category
# tracing.
for my $category (@categoryData) {
if ($category eq '*') {
$AllTrace = 1;
} else {
$Categories{lc $category} = 1;
}
}
# Now we need to process the destination information. The most important special
# cases are the single ">", which requires we clear the file first, and the
# "+" prefix which indicates a double echo.
if ($target =~ m/^\+?>>?/) {
if ($target =~ m/^\+/) {
$TeeFlag = 1;
$target = substr($target, 1);
}
if ($target =~ m/^>[^>]/) {
open TRACEFILE, $target;
print TRACEFILE Now() . " Tracing initialized.\n";
close TRACEFILE;
$Destination = ">$target";
} else {
$Destination = $target;
}
} else {
$Destination = uc($target);
}
# Increment the setup counter.
$SetupCount++;
}
=head3 Setups
C<< my $count = Tracer::Setups(); >>
Return the number of times L</TSetup> has been called.
This method allows for the creation of conditional tracing setups where, for example, we
may want to set up tracing if nobody else has done it before us.
=cut
sub Setups {
return $SetupCount;
}
=head3 Open
C<< my $handle = Open($fileHandle, $fileSpec, $message); >>
Open a file.
The I<$fileSpec> is essentially the second argument of the PERL C<open>
function. The mode is specified using Unix-like shell information. So, for
example,
Open(\*LOGFILE, '>>/usr/spool/news/twitlog', "Could not open twit log.");
would open for output appended to the specified file, and
Open(\*DATASTREAM, "| sort -u >$outputFile", "Could not open $outputFile.");
would open a pipe that sorts the records written and removes duplicates. Note
the use of file handle syntax in the Open call. To use anonymous file handles,
code as follows.
my $logFile = Open(undef, '>>/usr/spool/news/twitlog', "Could not open twit log.");
The I<$message> parameter is used if the open fails. If it is set to C<0>, then
the open returns TRUE if successful and FALSE if an error occurred. Otherwise, a
failed open will throw an exception and the third parameter will be used to construct
an error message. If the parameter is omitted, a standard message is constructed
using the file spec.
Could not open "/usr/spool/news/twitlog"
Note that the mode characters are automatically cleaned from the file name.
The actual error message from the file system will be captured and appended to the
message in any case.
Could not open "/usr/spool/news/twitlog": file not found.
In some versions of PERL the only error message we get is a number, which
corresponds to the C++ C<errno> value.
Could not open "/usr/spool/news/twitlog": 6.
=over 4
=item fileHandle
File handle. If this parameter is C<undef>, a file handle will be generated
and returned as the value of this method.
=item fileSpec
File name and mode, as per the PERL C<open> function.
=item message (optional)
Error message to use if the open fails. If omitted, a standard error message
will be generated. In either case, the error information from the file system
is appended to the message. To specify a conditional open that does not throw
an error if it fails, use C<0>.
=item RETURN
Returns the name of the file handle assigned to the file, or C<undef> if the
open failed.
=back
=cut
sub Open {
# Get the parameters.
my ($fileHandle, $fileSpec, $message) = @_;
# Attempt to open the file.
my $rv = open $fileHandle, $fileSpec;
# If the open failed, generate an error message.
if (! $rv) {
# Save the system error message.
my $sysMessage = $!;
# See if we need a default message.
if (!$message) {
# Clean any obvious mode characters and leading spaces from the
# filename.
my ($fileName) = FindNamePart($fileSpec);
$message = "Could not open \"$fileName\"";
}
# Terminate with an error using the supplied message and the
# error message from the file system.
Confess("$message: $!");
}
# Return the file handle.
return $fileHandle;
}
=head3 FindNamePart
C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>
Extract the portion of a file specification that contains the file name.
A file specification is the string passed to an C<open> call. It specifies the file
mode and name. In a truly complex situation, it can specify a pipe sequence. This
method assumes that the file name is whatever follows the first angle bracket
sequence. So, for example, in the following strings the file name is
C</usr/fig/myfile.txt>.
>>/usr/fig/myfile.txt
</usr/fig/myfile.txt
| sort -u > /usr/fig/myfile.txt
If the method cannot find a file name using its normal methods, it will return the
whole incoming string.
=over 4
=item fileSpec
File specification string from which the file name is to be extracted.
=item RETURN
Returns a three-element list. The first element contains the file name portion of
the specified string, or the whole string if a file name cannot be found via normal
methods. The second element contains the start position of the file name portion and
the third element contains the length.
=back
=cut
#: Return Type $;
sub FindNamePart {
# Get the parameters.
my ($fileSpec) = @_;
# Default to the whole input string.
my ($retVal, $pos, $len) = ($fileSpec, 0, length $fileSpec);
# Parse out the file name if we can.
if ($fileSpec =~ m/(<|>>?)(.+?)(\s*)$/) {
$retVal = $2;
$len = length $retVal;
$pos = (length $fileSpec) - (length $3) - $len;
}
# Return the result.
return ($retVal, $pos, $len);
}
=head3 OpenDir
C<< my @files = OpenDir($dirName, $filtered); >>
Open a directory and return all the file names. This function essentially performs
the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
set to TRUE, all filenames beginning with a period (C<.>) will be filtered out of
the return list. If the directory does not open, an exception is thrown. So,
for example,
my @files = OpenDir("/Volumes/fig/contigs", 1);
is effectively the same as
opendir(TMP, "/Volumes/fig/contigs") || Confess("Could not open /Volumes/fig/contigs.");
my @files = grep { $_ !~ /^\./ } readdir(TMP);
Similarly, the following code
my @files = grep { $_ =~ /^\d/ } OpenDir("/Volumes/fig/orgs");
Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and
automatically throws an error if the directory fails to open.
=over 4
=item dirName
Name of the directory to open.
=item filtered
TRUE if files whose names begin with a period (C<.>) should be automatically removed
from the list, else FALSE.
=back
=cut
#: Return Type @;
sub OpenDir {
# Get the parameters.
my ($dirName, $filtered) = @_;
# Declare the return variable.
my @retVal;
# Open the directory.
if (opendir(my $dirHandle, $dirName)) {
# The directory opened successfully. Get the appropriate list according to the
# strictures of the filter parameter.
if ($filtered) {
@retVal = grep { $_ !~ /^\./ } readdir $dirHandle;
} else {
@retVal = readdir $dirHandle;
}
} else {
# Here the directory would not open.
Confess("Could not open directory $dirName.");
}
# Return the result.
return @retVal;
}
=head3 SetLevel
C<< Tracer::SetLevel($newLevel); >>
Modify the trace level. A higher trace level will cause more messages to appear.
=over 4
=item newLevel
Proposed new trace level.
=back
=cut
sub SetLevel {
$TraceLevel = $_[0];
}
=head3 Now
C<< my $string = Tracer::Now(); >>
Return a displayable time stamp containing the local time.
=cut
sub Now {
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
my $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .
_p2($hour) . ":" . _p2($min) . ":" . _p2($sec);
return $retVal;
}
# Pad a number to 2 digits.
sub _p2 {
my ($value) = @_;
$value = "0$value" if ($value < 10);
return $value;
}
=head3 LogErrors
C<< Tracer::LogErrors($fileName); >>
Route the standard error output to a log file.
=over 4
=item fileName
Name of the file to receive the error output.
=back
=cut
sub LogErrors {
# Get the file name.
my ($fileName) = @_;
# Open the file as the standard error output.
open STDERR, '>', $fileName;
}
=head3 ReadOptions
C<< my %options = Tracer::ReadOptions($fileName); >>
Read a set of options from a file. Each option is encoded in a line of text that has the
format
I<optionName>C<=>I<optionValue>C<; >I<comment>
The option name must consist entirely of letters, digits, and the punctuation characters
C<.> and C<_>, and is case sensitive. Blank lines and lines in which the first nonblank
character is a semi-colon will be ignored. The return hash will map each option name to
the corresponding option value.
=over 4
=item fileName
Name of the file containing the option data.
=item RETURN
Returns a hash mapping the option names specified in the file to their corresponding option
value.
=back
=cut
sub ReadOptions {
# Get the parameters.
my ($fileName) = @_;
# Open the file.
(open CONFIGFILE, "<$fileName") || Confess("Could not open option file $fileName.");
# Count the number of records read.
my ($records, $comments) = 0;
# Create the return hash.
my %retVal = ();
# Loop through the file, accumulating key-value pairs.
while (my $line = <CONFIGFILE>) {
# Denote we've read a line.
$records++;
# Determine the line type.
if ($line =~ /^\s*[\n\r]/) {
# A blank line is a comment.
$comments++;
} elsif ($line =~ /^\s*([A-Za-z0-9_\.]+)=([^;]*);/) {
# Here we have an option assignment.
retVal{$1} = $2;
} elsif ($line =~ /^\s*;/) {
# Here we have a text comment.
$comments++;
} else {
# Here we have an invalid line.
Trace("Invalid option statement in record $records.") if T(0);
}
}
# Return the hash created.
return %retVal;
}
=head3 GetOptions
C<< Tracer::GetOptions(\%defaults, \%options); >>
Merge a specified set of options into a table of defaults. This method takes two hash references
as input and uses the data from the second to update the first. If the second does not exist,
there will be no effect. An error will be thrown if one of the entries in the second hash does not
exist in the first.
Consider the following example.
C<< my $optionTable = GetOptions({ dbType => 'mySQL', trace => 0 }, $options); >>
In this example, the variable B<$options> is expected to contain at most two options-- B<dbType> and
B<trace>. The default database type is C<mySQL> and the default trace level is C<0>. If the value of
B<$options> is C<< {dbType => 'Oracle'} >>, then the database type will be changed to C<Oracle> and
the trace level will remain at 0. If B<$options> is undefined, then the database type and trace level
will remain C<mySQL> and C<0>. If, on the other hand, B<$options> is defined as
C<< {databaseType => 'Oracle'} >>
an error will occur because the B<databaseType> option does not exist.
=over 4
=item defaults
Table of default option values.
=item options
Table of overrides, if any.
=item RETURN
Returns a reference to the default table passed in as the first parameter.
=back
=cut
sub GetOptions {
# Get the parameters.
my ($defaults, $options) = @_;
# Check for overrides.
if ($options) {
# Loop through the overrides.
while (my ($option, $setting) = each %{$options}) {
# Insure this override exists.
if (!exists $defaults->{$option}) {
croak "Unrecognized option $option encountered.";
} else {
# Apply the override.
$defaults->{$option} = $setting;
}
}
}
# Return the merged table.
return $defaults;
}
=head3 MergeOptions
C<< Tracer::MergeOptions(\%table, \%defaults); >>
Merge default values into a hash table. This method looks at the key-value pairs in the
second (default) hash, and if a matching key is not found in the first hash, the default
pair is copied in. The process is similar to L</GetOptions>, but there is no error-
checking and no return value.
=over 4
=item table
Hash table to be updated with the default values.
=item defaults
Default values to be merged into the first hash table if they are not already present.
=back
=cut
sub MergeOptions {
# Get the parameters.
my ($table, $defaults) = @_;
# Loop through the defaults.
while (my ($key, $value) = each %{$defaults}) {
if (!exists $table->{$key}) {
$table->{$key} = $value;
}
}
}
=head3 Trace
C<< Trace($message); >>
Write a trace message to the target location specified in L</TSetup>. If there has not been
any prior call to B<TSetup>.
=over 4
=item message
Message to write.
=back
=cut
sub Trace {
# Get the parameters.
my ($message) = @_;
# Get the timestamp.
my $timeStamp = Now();
# Format the message. Note we strip off any line terminators at the end.
my $formatted = "$timeStamp <$LastCategory>: " . Strip($message);
# Process according to the destination.
if ($Destination eq "TEXT") {
# Write the message to the standard output.
print "$formatted\n";
} elsif ($Destination eq "ERROR") {
# Write the message to the error output.
print STDERR "$formatted\n";
} elsif ($Destination eq "QUEUE") {
# Push the message into the queue.
push @Queue, "$formatted";
} elsif ($Destination eq "HTML") {
# Convert the message to HTML and write it to the standard output.
my $escapedMessage = CGI::escapeHTML($message);
print "<p>$formatted</p>\n";
} elsif ($Destination eq "WARN") {
# Emit the message as a warning.
warn $message;
} elsif ($Destination =~ m/^>>/) {
# Write the trace message to an output file.
open TRACING, $Destination;
print TRACING "$formatted\n";
close TRACING;
# If the Tee flag is on, echo it to the standard output.
if ($TeeFlag) {
print "$formatted\n";
}
}
}
=head3 T
C<< my $switch = T($category, $traceLevel); >>
or
C<< my $switch = T($traceLevel); >>
Return TRUE if the trace level is at or above a specified value and the specified category
is active, else FALSE. If no category is specified, the caller's package name is used.
=over 4
=item category
Category to which the message belongs. If not specified, the caller's package name is
used.
=item traceLevel
Relevant tracing level.
=item RETURN
TRUE if a message at the specified trace level would appear in the trace, else FALSE.
=back
=cut
sub T {
# Declare the return variable.
my $retVal = 0;
# Only proceed if tracing is turned on.
if ($Destination ne "NONE") {
# Get the parameters.
my ($category, $traceLevel) = @_;
if (!defined $traceLevel) {
# Here we have no category, so we need to get the calling package.
# The calling package is normally the first parameter. If it is
# omitted, the first parameter will be the tracelevel. So, the
# first thing we do is shift the so-called category into the
# $traceLevel variable where it belongs.
$traceLevel = $category;
my ($package, $fileName, $line) = caller;
# If there is no calling package, we default to "main".
if (!$package) {
$category = "main";
} else {
$category = $package;
}
}
# Save the category name.
$LastCategory = $category;
# Convert it to lower case before we hash it.
$category = lc $category;
# Use the category and tracelevel to compute the result.
$retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));
}
# Return the computed result.
return $retVal;
}
=head3 ParseCommand
C<< my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList); >>
Parse a command line consisting of a list of parameters. The initial parameters may be option
specifiers of the form C<->I<option> or C<->I<option>C<=>I<value>. The options are stripped
off and merged into a table of default options. The remainder of the command line is
returned as a list of positional arguments. For example, consider the following invocation.
C<< my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words); >>
In this case, the list @words will be treated as a command line. There are two options available,
B<errors> and B<logFile>. If @words has the following format
C<< -logFile=error.log apple orange rutabaga >>
then at the end of the invocation, C<$options> will be
C<< { errors => 0, logFile => 'error.log' } >>
and C<@arguments> will contain
C<< apple orange rutabaga >>
The parser allows for some escape sequences. See L</UnEscape> for a description. There is no
support for quote characters.
=over 4
=item optionTable
Table of default options.
=item inputList
List of words on the command line.
=item RETURN
Returns a reference to the option table and a list of the positional arguments.
=back
=cut
sub ParseCommand {
# Get the parameters.
my ($optionTable, @inputList) = @_;
# Process any options in the input list.
my %overrides = ();
while ((@inputList > 0) && ($inputList[0] =~ /^-/)) {
# Get the current option.
my $arg = shift @inputList;
# Pull out the option name.
$arg =~ /^-([^=]*)/g;
my $name = $1;
# Check for an option value.
if ($arg =~ /\G=(.*)$/g) {
# Here we have a value for the option.
$overrides{$name} = UnEscape($1);
} else {
# Here there is no value, so we use 1.
$overrides{$name} = 1;
}
}
# Merge the options into the defaults.
GetOptions($optionTable, \%overrides);
# Translate the remaining parameters.
my @retVal = ();
for my $inputParm (@inputList) {
push @retVal, UnEscape($inputParm);
}
# Return the results.
return ($optionTable, @retVal);
}
=head3 Escape
C<< my $codedString = Tracer::Escape($realString); >>
Escape a string for use in a command length. Spaces will be replaced by C<\b>,
tabs replaced by C<\t>, new-lines replaced by C<\n>, and backslashes will be
doubled. The effect is to exactly reverse the effect of L</UnEscape>.
=over 4
=item realString
String to escape.
=item RETURN
Escaped equivalent of the real string.
=back
=cut
sub Escape {
# Get the parameter.
my ($realString) = @_;
# Initialize the return variable.
my $retVal = "";
# Loop through the parameter string, looking for sequences to escape.
while (length $realString > 0) {
# Look for the first sequence to escape.
if ($realString =~ /^(.*?)([ \n\t\\])/) {
# Here we found it. The text preceding the sequence is in $1. The sequence
# itself is in $2. First, move the clear text to the return variable.
$retVal .= $1;
$realString = substr $realString, (length $2 + length $1);
# Encode the escape sequence.
my $char = $2;
$char =~ tr/ \t\n/btn/;
$retVal .= "\\" . $char;
} else {
# Here there are no more escape sequences. The rest of the string is
# transferred unmodified.
$retVal .= $realString;
$realString = "";
}
}
# Return the result.
return $retVal;
}
=head3 UnEscape
C<< my $realString = Tracer::UnEscape($codedString); >>
Replace escape sequences with their actual equivalents. C<\b> will be replaced by a space,
C<\t> by a tab, C<\n> by a new-line character, and C<\\> by a back-slash.
=over 4
=item codedString
String to un-escape.
=item RETURN
Returns a copy of the original string with the escape sequences converted to their actual
values.
=back
=cut
sub UnEscape {
# Get the parameter.
my ($codedString) = @_;
# Initialize the return variable.
my $retVal = "";
# Only proceed if the incoming string is nonempty.
if (defined $codedString) {
# Loop through the parameter string, looking for escape sequences. We can't do
# translating because it causes problems with the escaped slash. ("\\b" becomes
# "\ " no matter what we do.)
while (length $codedString > 0) {
# Look for the first escape sequence.
if ($codedString =~ /^(.*?)\\(\\|b|n|t)/) {
# Here we found it. The text preceding the sequence is in $1. The sequence
# itself is in $2. First, move the clear text to the return variable.
$retVal .= $1;
$codedString = substr $codedString, (2 + length $1);
# Decode the escape sequence.
my $char = $2;
$char =~ tr/\\btn/\\ \t\n/;
$retVal .= $char;
} else {
# Here there are no more escape sequences. The rest of the string is
# transferred unmodified.
$retVal .= $codedString;
$codedString = "";
}
}
}
# Return the result.
return $retVal;
}
=head3 ParseRecord
C<< my @fields = Tracer::ParseRecord($line); >>
Parse a tab-delimited data line. The data line is split into field values. Embedded tab
and new-line characters in the data line must be represented as C<\t> and C<\n>, respectively.
These will automatically be converted.
=over 4
=item line
Line of data containing the tab-delimited fields.
=item RETURN
Returns a list of the fields found in the data line.
=back
=cut
sub ParseRecord {
# Get the parameter.
my ($line) = @_;
# Remove the trailing new-line, if any.
chomp $line;
# Split the line read into pieces using the tab character.
my @retVal = split /\t/, $line;
# Trim and fix the escapes in each piece.
for my $value (@retVal) {
# Trim leading whitespace.
$value =~ s/^\s+//;
# Trim trailing whitespace.
$value =~ s/\s+$//;
# Delete the carriage returns.
$value =~ s/\r//g;
# Convert the escapes into their real values.
$value =~ s/\\t/"\t"/ge;
$value =~ s/\\n/"\n"/ge;
}
# Return the result.
return @retVal;
}
=head3 Merge
C<< my @mergedList = Tracer::Merge(@inputList); >>
Sort a list of strings and remove duplicates.
=over 4
=item inputList
List of scalars to sort and merge.
=item RETURN
Returns a list containing the same elements sorted in ascending order with duplicates
removed.
=back
=cut
sub Merge {
# Get the input list in sort order.
my @inputList = sort @_;
# Only proceed if the list has at least two elements.
if (@inputList > 1) {
# Now we want to move through the list splicing out duplicates.
my $i = 0;
while ($i < @inputList) {
# Get the current entry.
my $thisEntry = $inputList[$i];
# Find out how many elements duplicate the current entry.
my $j = $i + 1;
my $dup1 = $i + 1;
while ($j < @inputList && $inputList[$j] eq $thisEntry) { $j++; };
# If the number is nonzero, splice out the duplicates found.
if ($j > $dup1) {
splice @inputList, $dup1, $j - $dup1;
}
# Now the element at position $dup1 is different from the element before it
# at position $i. We push $i forward one position and start again.
$i++;
}
}
# Return the merged list.
return @inputList;
}
=head3 GetFile
C<< my @fileContents = Tracer::GetFile($fileName); >>
Return the entire contents of a file.
=over 4
=item fileName
Name of the file to read.
=item RETURN
In a list context, returns the entire file as a list with the line terminators removed.
In a scalar context, returns the entire file as a string.
=back
=cut
sub GetFile {
# Get the parameters.
my ($fileName) = @_;
# Declare the return variable.
my @retVal = ();
# Open the file for input.
my $ok = open INPUTFILE, "<$fileName";
if (!$ok) {
# If we had an error, trace it. We will automatically return a null value.
Trace("Could not open \"$fileName\" for input.") if T(0);
} else {
# Read the whole file into the return variable, stripping off any terminator
# characters.
my $lineCount = 0;
while (my $line = <INPUTFILE>) {
$lineCount++;
$line = Strip($line);
push @retVal, $line;
}
# Close it.
close INPUTFILE;
my $actualLines = @retVal;
}
# Return the file's contents in the desired format.
if (wantarray) {
return @retVal;
} else {
return join "\n", @retVal;
}
}
=head3 QTrace
C<< my $data = QTrace($format); >>
Return the queued trace data in the specified format.
=over 4
=item format
C<html> to format the data as an HTML list, C<text> to format it as straight text.
=back
=cut
sub QTrace {
# Get the parameter.
my ($format) = @_;
# Create the return variable.
my $retVal = "";
# Process according to the format.
if ($format =~ m/^HTML$/i) {
# Convert the queue into an HTML list.
$retVal = "<ul>\n";
for my $line (@Queue) {
my $escapedLine = CGI::escapeHTML($line);
$retVal .= "<li>$escapedLine</li>\n";
}
$retVal .= "</ul>\n";
} elsif ($format =~ m/^TEXT$/i) {
# Convert the queue into a list of text lines.
$retVal = join("\n", @Queue) . "\n";
}
# Clear the queue.
@Queue = ();
# Return the formatted list.
return $retVal;
}
=head3 Confess
C<< Confess($message); >>
Trace the call stack and abort the program with the specified message. The stack
trace will only appear if the trace level for this package is 1 or more. When used with
the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.
So, for example
C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
Will abort the program with a stack trace if the value of C<$recNum> is negative.
=over 4
=item message
Message to include in the trace.
=back
=cut
sub Confess {
# Get the parameters.
my ($message) = @_;
# Trace the call stack.
Cluck($message) if T(1);
# Abort the program.
croak(">>> $message");
}
=head3 Assert
C<< Assert($condition1, $condition2, ... $conditionN); >>
Return TRUE if all the conditions are true. This method can be used in conjunction with
the OR operator and the L</Confess> method, B<Assert> can function as a debugging assert.
So, for example
C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>
Will abort the program with a stack trace if the value of C<$recNum> is negative.
=cut
sub Assert {
my $retVal = 1;
LOOP: for my $condition (@_) {
if (! $condition) {
$retVal = 0;
last LOOP;
}
}
return $retVal;
}
=head3 Cluck
C<< Cluck($message); >>
Trace the call stack. Note that for best results, you should qualify the call with a
trace condition. For example,
C<< Cluck("Starting record parse.") if T(3); >>
will only trace the stack if the trace level for the package is 3 or more.
=over 4
=item message
Message to include in the trace.
=back
=cut
sub Cluck {
# Get the parameters.
my ($message) = @_;
# Trace what's happening.
Trace("Stack trace for event: $message");
my $confession = longmess($message);
# Convert the confession to a series of trace messages. Note we skip any
# messages relating to calls into Tracer.
for my $line (split /\s*\n/, $confession) {
Trace($line) if ($line !~ /Tracer\.pm/);
}
}
=head3 Min
C<< my $min = Min($value1, $value2, ... $valueN); >>
Return the minimum argument. The arguments are treated as numbers.
=over 4
=item $value1, $value2, ... $valueN
List of numbers to compare.
=item RETURN
Returns the lowest number in the list.
=back
=cut
sub Min {
# Get the parameters. Note that we prime the return value with the first parameter.
my ($retVal, @values) = @_;
# Loop through the remaining parameters, looking for the lowest.
for my $value (@values) {
if ($value < $retVal) {
$retVal = $value;
}
}
# Return the minimum found.
return $retVal;
}
=head3 Max
C<< my $max = Max($value1, $value2, ... $valueN); >>
Return the maximum argument. The arguments are treated as numbers.
=over 4
=item $value1, $value2, ... $valueN
List of numbers to compare.
=item RETURN
Returns the highest number in the list.
=back
=cut
sub Max {
# Get the parameters. Note that we prime the return value with the first parameter.
my ($retVal, @values) = @_;
# Loop through the remaining parameters, looking for the highest.
for my $value (@values) {
if ($value > $retVal) {
$retVal = $value;
}
}
# Return the maximum found.
return $retVal;
}
=head3 AddToListMap
C<< Tracer::AddToListMap(\%hash, $key, $value); >>
Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list
is created for the key. Otherwise, the new value is pushed onto the list.
=over 4
=item hash
Reference to the target hash.
=item key
Key for which the value is to be added.
=item value
Value to add to the key's value list.
=back
=cut
sub AddToListMap {
# Get the parameters.
my ($hash, $key, $value) = @_;
# Process according to whether or not the key already has a value.
if (! exists $hash->{$key}) {
$hash->{$key} = [$value];
} else {
push @{$hash->{$key}}, $value;
}
}
=head3 DebugMode
C<< if (Tracer::DebugMode) { ...code... } >>
Return TRUE if debug mode has been turned on in FIG_Config, else output
an error page and return FALSE.
Certain CGI scripts are too dangerous to exist in the production
environment. This method provides a simple way to prevent them
from working unless they are explicitly turned on in the configuration
file by setting C<$FIG_Config::debug_mode> to 1. If debugging mode
is not turned on, an error web page will be output.
=cut
sub DebugMode {
# Declare the return variable.
my $retVal;
# Check the debug configuration.
if ($FIG_Config::debug_mode) {
$retVal = 1;
} else {
# Here debug mode is off, so we generate an error page.
my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");
print $pageString;
}
# Return the determination indicator.
return $retVal;
}
=head3 Strip
C<< my $string = Tracer::Strip($line); >>
Strip all line terminators off a string. This is necessary when dealing with files
that may have been transferred back and forth several times among different
operating environments.
=over 4
=item line
Line of text to be stripped.
=item RETURN
The same line of text with all the line-ending characters chopped from the end.
=back
=cut
sub Strip {
# Get a copy of the parameter string.
my ($string) = @_;
my $retVal = $string;
# Strip the line terminator characters.
$retVal =~ s/(\r|\n)+$//g;
# Return the result.
return $retVal;
}
=head3 Pad
C<< my $paddedString = Tracer::Pad($string, $len, $left, $padChar); >>
Pad a string to a specified length. The pad character will be a
space, and the padding will be on the right side unless specified
in the third parameter.
=over 4
=item string
String to be padded.
=item len
Desired length of the padded string.
=item left (optional)
TRUE if the string is to be left-padded; otherwise it will be padded on the right.
=item padChar (optional)
=item RETURN
Returns a copy of the original string with the spaces added to the specified end so
that it achieves the desired length.
=back
=cut
sub Pad {
# Get the parameters.
my ($string, $len, $left, $padChar) = @_;
# Compute the padding character.
if (! defined $padChar) {
$padChar = " ";
}
# Compute the number of spaces needed.
my $needed = $len - length $string;
# Copy the string into the return variable.
my $retVal = $string;
# Only proceed if padding is needed.
if ($needed > 0) {
# Create the pad string.
my $pad = $padChar x $needed;
# Affix it to the return value.
if ($left) {
$retVal = $pad . $retVal;
} else {
$retVal .= $pad;
}
}
# Return the result.
return $retVal;
}
1;
| MCS Webmaster | ViewVC Help |
| Powered by ViewVC 1.0.3 |