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 package, it will appear if the C category is active and the trace level is 2 or more. C<< Trace($message) if T(2); >> To set up tracing, you call the C 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, activated the C, C, and C categories, and specifies that messages should be output as HTML paragraphs. The idea is to make it easier to input tracing configuration on a web form. 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 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 and C. 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. =cut # Declare the configuration variables. my $Destination = "NONE"; # Description of where to send the trace 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. =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 and L 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. In addition to sending the trace messages to a file, you can specify a special destination. C will cause tracing to the standard output with each line formatted as an HTML paragraph. C will cause tracing to the standard output as ordinary text. C will cause trace messages to be stored in a queue for later retrieval by the L method. C will cause trace messages to be emitted as warnings using the B directive. C 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; # Build the category hash. for my $category (@categoryData) { $Categories{$category} = 1; } # Now we need to process the destination information. The most important special # case is the single ">", which requires we clear the file first. After doing # so, we tack on another ">" sign so that future trace messages are appended. if ($target =~ m/^>[^>]/) { open TRACEFILE, $target; print TRACEFILE Now() . " Tracing initialized.\n"; close TRACEFILE; $Destination = ">$target"; } else { $Destination = uc($target); } } =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 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 and B. The default database type is C 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 and the trace level will remain at 0. If B<$options> is undefined, then the database type and trace level will remain C and C<0>. If, on the other hand, B<$options> is defined as C<< {databaseType => 'Oracle'} >> an error will occur because the B 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, 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. If there has not been any prior call to B. =over 4 =item message Message to write. =back =cut sub Trace { # Get the parameters. my ($message) = @_; # Get the timestamp. my $timeStamp = Now(); # Process according to the destination. if ($Destination eq "TEXT") { # Write the message to the standard output. print "$timeStamp $message\n"; } elsif ($Destination eq "QUEUE") { # Push the message into the queue. push @Queue, "$timeStamp $message"; } elsif ($Destination eq "HTML") { # Convert the message to HTML and write it to the standard output. my $escapedMessage = CGI::escapeHTML($message); print "

$timeStamp $message

\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 "$timeStamp $message\n"; close TRACING; } } =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. $traceLevel = $category; my ($package, $fileName, $line) = caller; # If there is no calling package, we default to "main". if (!$package) { $category = "main"; } else { $category = $package; } } # Use the package and tracelevel to compute the result. $retVal = ($traceLevel <= $TraceLevel && 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