Parent Directory
| 
Revision Log
Added the ability to write a raw string in the PutFile method.
# # Copyright (c) 2003-2006 University of Chicago and Fellowship # for Interpretations of Genomes. All Rights Reserved. # # This file is part of the SEED Toolkit. # # The SEED Toolkit is free software. You can redistribute # it and/or modify it under the terms of the SEED Toolkit # Public License. # # You should have received a copy of the SEED Toolkit Public License # along with this program; if not write to the University of Chicago # at info@ci.uchicago.edu or the Fellowship for Interpretation of # Genomes at veronika@thefig.info or download a copy from # http://www.theseed.org/LICENSE.TXT. # package Tracer; require Exporter; @ISA = ('Exporter'); @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup ScriptSetup ScriptFinish Insure ChDir); @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape); use strict; use Carp qw(longmess croak); use CGI; use Cwd; use FIG_Config; use PageBuilder; use Digest::MD5; use File::Basename; use File::Path; use File::stat; use LWP::UserAgent; use Time::HiRes 'gettimeofday'; use URI::Escape; =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 Error 0 Message indicates an error that may lead to incorrect results or that has stopped the application entirely. =item Warning 1 Message indicates something that is unexpected but that probably did not interfere with program execution. =item Notice 2 Message indicates the beginning or end of a major task. =item Information 3 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 Detail 4 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. We must also clear away any pre-existing data. %Categories = ( main => 1 ); 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 StandardSetup C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >> This method performs standard command-line parsing and tracing setup. The return values are a hash of the command-line options and a list of the positional parameters. Tracing is automatically set up and the command-line options are validated. This is a complex method that does a lot of grunt work. The parameters can be more easily understood, however, once they are examined individually. The I<categories> parameter is the most obtuse. It is a reference to a list of special-purpose tracing categories. Most tracing categories are PERL package names. So, for example, if you wanted to turn on tracing inside the B<Sprout>, B<ERDB>, and B<SproutLoad> packages, you would specify the categories ["Sprout", "SproutLoad", "ERDB"] This would cause trace messages in the specified three packages to appear in the output. There are threer special tracing categories that are automatically handled by this method. In other words, if you used L</TSetup> you would need to include these categories manually, but if you use this method they are turned on automatically. =over 4 =item FIG Turns on trace messages inside the B<FIG> package. =item SQL Traces SQL commands and activity. =item Tracer Traces error messages and call stacks. =back C<SQL> is only turned on if the C<-sql> option is specified in the command line. The trace level is specified using the C<-trace> command-line option. For example, the following command line for C<TransactFeatures> turns on SQL tracing and runs all tracing at level 3. TransactFeatures -trace=3 -sql register ../xacts IDs.tbl Standard tracing is output to the standard output and echoed to the file C<trace>I<$$>C<.log> in the FIG temporary directory, where I<$$> is the process ID. You can also specify the C<user> parameter to put a user ID instead of a process ID in the trace file name. So, for example The default trace level is 2. To get all messages, specify a trace level of 4. For a genome-by-genome update, use 3. TransactFeatures -trace=3 -sql -user=Bruce register ../xacts IDs.tbl would send the trace output to C<traceBruce.log> in the temporary directory. The I<options> parameter is a reference to a hash containing the command-line options, their default values, and an explanation of what they mean. Command-line options may be in the form of switches or keywords. In the case of a switch, the option value is 1 if it is specified and 0 if it is not specified. In the case of a keyword, the value is separated from the option name by an equal sign. You can see this last in the command-line example above. You can specify a different default trace level by setting C<$options->{trace}> prior to calling this method. An example at this point would help. Consider, for example, the command-line utility C<TransactFeatures>. It accepts a list of positional parameters plus the options C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute the following code. my ($options, @parameters) = Tracer::StandardSetup(["DocUtils"], { safe => [0, "use database transactions"], noAlias => [0, "do not expect aliases in CHANGE transactions"], start => [' ', "start with this genome"], tblFiles => [0, "output TBL files containing the corrected IDs"] }, "command transactionDirectory IDfile", @ARGV); The call to C<ParseCommand> specifies the default values for the options and stores the actual options in a hash that is returned as C<$options>. The positional parameters are returned in C<@parameters>. The following is a sample command line for C<TransactFeatures>. TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional parameters, and would find themselves in I<@parameters> after executing the above code fragment. The tracing would be set to level 2, and the categories would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard, and C<DocUtils> was included because it came in within the first parameter to this method. The I<$options> hash would be { trace => 2, sql => 0, safe => 0, noAlias => 1, start => ' ', tblFiles => 0 } Use of C<StandardSetup> in this way provides a simple way of performing standard tracing setup and command-line parsing. Note that the caller is not even aware of the command-line switches C<-trace> and C<-sql>, which are used by this method to control the tracing. If additional tracing features need to be added in the future, they can be processed by this method without upsetting the command-line utilities. If the C<background> option is specified on the command line, then the standard and error outputs will be directed to files in the temporary directory, using the same suffix as the trace file. So, if the command line specified -user=Bruce -background then the trace output would go to C<traceBruce.log>, the standard output to C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to simplify starting a command in the background. Finally, if the special option C<-h> is specified, the option names will be traced at level 0 and the program will exit without processing. This provides a limited help capability. For example, if the user enters TransactFeatures -h he would see the following output. TransactFeatures [options] command transactionDirectory IDfile -trace tracing level (default 2) -sql trace SQL commands -safe use database transactions -noAlias do not expect aliases in CHANGE transactions -start start with this genome -tblFiles output TBL files containing the corrected IDs The caller has the option of modifying the tracing scheme by placing a value for C<trace> in the incoming options hash. The default value can be overridden, or the tracing to the standard output can be turned off by suffixing a minus sign to the trace level. So, for example, { trace => [0, "tracing level (default 0)"], ... would set the default trace level to 0 instead of 2, while { trace => ["2-", "tracing level (default 2)"], ... would leave the default at 2, but trace only to the log file, not to the standard output. The parameters to this method are as follows. =over 4 =item categories Reference to a list of tracing category names. These should be names of packages whose internal workings will need to be debugged to get the command working. =item options Reference to a hash containing the legal options for the current command mapped to their default values and descriptions. The user can override the defaults by specifying the options as command-line switches prefixed by a hyphen. Tracing-related options may be added to this hash. If the C<-h> option is specified on the command line, the option descriptions will be used to explain the options. To turn off tracing to the standard output, add a minus sign to the value for C<trace> (see above). =item parmHelp A string that vaguely describes the positional parameters. This is used if the user specifies the C<-h> option. =item argv List of command line parameters, including the option switches, which must precede the positional parameters and be prefixed by a hyphen. =item RETURN Returns a list. The first element of the list is the reference to a hash that maps the command-line option switches to their values. These will either be the default values or overrides specified on the command line. The remaining elements of the list are the position parameters, in order. =back =cut sub StandardSetup { # Get the parameters. my ($categories, $options, $parmHelp, @argv) = @_; # Add the tracing options. if (! exists $options->{trace}) { $options->{trace} = [2, "tracing level"]; } $options->{sql} = [0, "turn on SQL tracing"]; $options->{h} = [0, "display command-line options"]; $options->{user} = [$$, "trace log file name suffix"]; $options->{background} = [0, "spool standard and error output"]; # Create a parsing hash from the options hash. The parsing hash # contains the default values rather than the default value # and the description. While we're at it, we'll memorize the # length of the longest option name. my $longestName = 0; my %parseOptions = (); for my $key (keys %{$options}) { if (length $key > $longestName) { $longestName = length $key; } $parseOptions{$key} = $options->{$key}->[0]; } # Parse the command line. my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv); # Get the logfile suffix. my $suffix = $retOptions->{user}; # Check for background mode. if ($retOptions->{background}) { my $outFileName = "$FIG_Config::temp/out$suffix.log"; my $errFileName = "$FIG_Config::temp/err$suffix.log"; open STDOUT, ">$outFileName"; open STDERR, ">$errFileName"; } # Now we want to set up tracing. First, we need to know if SQL is to # be traced. my @cats = @{$categories}; if ($retOptions->{sql}) { push @cats, "SQL"; } # Add the default categories. push @cats, "Tracer", "FIG"; # Next, we create the category string by joining the categories. my $cats = join(" ", @cats); # Check to determine whether or not the caller wants to turn off tracing # to the standard output. my $traceLevel = $retOptions->{trace}; my $textOKFlag = 1; if ($traceLevel =~ /^(.)-/) { $traceLevel = $1; $textOKFlag = 0; } # Now we set up the trace mode. my $traceMode; # Verify that we can open a file in the FIG temporary directory. my $traceFileName = "$FIG_Config::temp/trace$suffix.log"; if (open TESTTRACE, ">$traceFileName") { # Here we can trace to a file. $traceMode = ">$traceFileName"; if ($textOKFlag) { # Echo to standard output if the text-OK flag is set. $traceMode = "+$traceMode"; } # Close the test file. close TESTTRACE; } else { # Here we can't trace to a file. We trace to the standard output if it's # okay, and the error log otherwise. if ($textOKFlag) { $traceMode = "TEXT"; } else { $traceMode = "WARN"; } } # Now set up the tracing. TSetup("$traceLevel $cats", $traceMode); # Check for the "h" option. If it is specified, dump the command-line # options and exit the program. if ($retOptions->{h}) { $0 =~ m#[/\\](\w+)(\.pl)?$#i; Trace("$1 [options] $parmHelp") if T(0); for my $key (sort keys %{$options}) { my $name = Pad($key, $longestName, 0, ' '); my $desc = $options->{$key}->[1]; if ($options->{$key}->[0]) { $desc .= " (default " . $options->{$key}->[0] . ")"; } Trace(" $name $desc") if T(0); } exit(0); } # Return the parsed parameters. return ($retOptions, @retParameters); } =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, $flag); >> 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<.>), dollar sign (C<$>), or pound sign (C<#>) and all filenames ending with a tilde C<~>) will be filtered out of the return list. If the directory does not open and I<$flag> is not set, 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", 0, 1); Returns the names of all files in C</Volumes/fig/orgs> that begin with digits and automatically returns an empty list 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. =item flag TRUE if a failure to open is okay, else FALSE =back =cut #: Return Type @; sub OpenDir { # Get the parameters. my ($dirName, $filtered, $flag) = @_; # 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; } } elsif (! $flag) { # Here the directory would not open and it's considered an error. 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) || die "Tracing open for \"$Destination\" failed: $!"; 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. if (ref $traceLevel) { Confess("Bad trace level."); } elsif (ref $TraceLevel) { Confess("Bad trace config."); } $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. Tabs will be replaced by C<\t>, new-lines replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The result is to 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\r\\])/) { # 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; # Strip the processed section off the real string. $realString = substr $realString, (length $2) + (length $1); # Get the matched character. my $char = $2; # If we have a CR, we are done. if ($char ne "\r") { # It's not a CR, so encode the escape sequence. $char =~ tr/\t\n/tn/; $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<\t> will be replaced by a tab, C<\n> by a new-line character, and C<\\> by a backslash. C<\r> codes will be deleted. =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. ("\\t" becomes # "\<tab>" no matter what we do.) while (length $codedString > 0) { # Look for the first escape sequence. if ($codedString =~ /^(.*?)\\(\\|n|t|r)/) { # 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); # Get the escape value. my $char = $2; # If we have a "\r", we are done. if ($char ne 'r') { # Here it's not an 'r', so we convert it. $char =~ tr/\\tn/\\\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 Percent C<< my $percent = Tracer::Percent($number, $base); >> Returns the percent of the base represented by the given number. If the base is zero, returns zero. =over 4 =item number Percent numerator. =item base Percent base. =item RETURN Returns the percentage of the base represented by the numerator. =back =cut sub Percent { # Get the parameters. my ($number, $base) = @_; # Declare the return variable. my $retVal = 0; # Compute the percent. if ($base != 0) { $retVal = $number * 100 / $base; } # Return the result. return $retVal; } =head3 GetFile C<< my @fileContents = Tracer::GetFile($fileName); >> or C<< my $fileContents = Tracer::GetFile($fileName); >> Return the entire contents of a file. In list context, line-ends are removed and each line is a list element. In scalar context, line-ends are replaced by C<\n>. =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. If an error occurs opening the file, an empty list will be returned. =back =cut sub GetFile { # Get the parameters. my ($fileName) = @_; # Declare the return variable. my @retVal = (); # Open the file for input. my $handle = Open(undef, "<$fileName"); # Read the whole file into the return variable, stripping off any terminator # characters. my $lineCount = 0; while (my $line = <$handle>) { $lineCount++; $line = Strip($line); push @retVal, $line; } # Close it. close $handle; my $actualLines = @retVal; # Return the file's contents in the desired format. if (wantarray) { return @retVal; } else { return join "\n", @retVal; } } =head3 PutFile C<< Tracer::PutFile($fileName, \@lines); >> Write out a file from a list of lines of text. =over 4 =item fileName Name of the output file. =item lines Reference to a list of text lines. The lines will be written to the file in order, with trailing new-line characters. Alternatively, may be a string, in which case the string will be written without modification. =back =cut sub PutFile { # Get the parameters. my ($fileName, $lines) = @_; # Open the output file. my $handle = Open(undef, ">$fileName"); if (ref $lines ne 'ARRAY') { # Here we have a scalar, so we write it raw. print $handle $lines; } else { # Write the lines one at a time. for my $line (@{$lines}) { print $handle "$line\n"; } } # Close the output file. close $handle; } =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 = ""; # Only proceed if there is an actual queue. if (@Queue) { # 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. 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); # 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 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, $value1, $value2, ... valueN); >> 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 value1, value2, ... valueN List of values to add to the key's value list. =back =cut sub AddToListMap { # Get the parameters. my ($hash, $key, @values) = @_; # Process according to whether or not the key already has a value. if (! exists $hash->{$key}) { $hash->{$key} = [@values]; } else { push @{$hash->{$key}}, @values; } } =head3 DebugMode C<< if (Tracer::DebugMode) { ...code... } >> Return TRUE if debug mode has been turned on, 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 by creating a password cookie via the B<SetPassword> script. If debugging mode is not turned on, an error web page will be output directing the user to enter in the correct password. =cut sub DebugMode { # Declare the return variable. my $retVal = 0; # Check the debug configuration. my $password = CGI::cookie("DebugMode"); my $encrypted = Digest::MD5::md5_hex($password); if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") { $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 = (defined $string ? $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) Character to use for padding. The default is a space. =item RETURN Returns a copy of the original string with the pad character 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; } =head3 EOF This is a constant that is lexically greater than any useful string. =cut sub EOF { return "\xFF\xFF\xFF\xFF\xFF"; } =head3 TICK C<< my @results = TICK($commandString); >> Perform a back-tick operation on a command. If this is a Windows environment, any leading dot-slash (C<./> will be removed. So, for example, if you were doing `./protein.cgi` from inside a CGI script, it would work fine in Unix, but would issue an error message in Windows complaining that C<'.'> is not a valid command. If instead you code TICK("./protein.cgi") it will work correctly in both environments. =over 4 =item commandString The command string to pass to the system. =item RETURN Returns the standard output from the specified command, as a list. =back =cut #: Return Type @; sub TICK { # Get the parameters. my ($commandString) = @_; # Chop off the dot-slash if this is Windows. if ($FIG_Config::win_mode) { $commandString =~ s!^\./!!; } # Activate the command and return the result. return `$commandString`; } =head3 ScriptSetup C<< my ($query, $varHash) = ScriptSetup(); >> Perform standard tracing and debugging setup for scripts. The value returned is the CGI object followed by a pre-built variable hash. The C<Trace> query parameter is used to determine whether or not tracing is active and which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying the C<CGI> trace module will trace parameter and environment information. Parameters are traced at level 3 and environment variables at level 4. At the end of the script, the client should call L</ScriptFinish> to output the web page. =cut sub ScriptSetup { # Get the CGI query object. my $query = CGI->new(); # Check for tracing. Set it up if the user asked for it. if ($query->param('Trace')) { # Set up tracing. my $ttype = ($query->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE"); TSetup($query->param('Trace') . " FIG Tracer", $ttype); # Trace the parameter and environment data. TraceParms($query); } else { # Here tracing is to be turned off. All we allow is errors traced into the # error log. TSetup("0", "WARN"); } # Create the variable hash. my $varHash = { DebugData => '' }; # Return the query object and variable hash. return ($query, $varHash); } =head3 TraceParms C<< Tracer::TraceParms($query); >> Trace the CGI parameters at trace level CGI => 3 and the environment variables at level CGI => 4. =over 4 =item query CGI query object containing the parameters to trace. =back =cut sub TraceParms { # Get the parameters. my ($query) = @_; if (T(CGI => 3)) { # Here we want to trace the parameter data. my @names = $query->param; for my $parmName (sort @names) { # Note we skip "Trace", which is for our use only. if ($parmName ne 'Trace') { my @values = $query->param($parmName); Trace("CGI: $parmName = " . join(", ", @values)); } } } if (T(CGI => 4)) { # Here we want the environment data too. for my $envName (sort keys %ENV) { Trace("ENV: $envName = $ENV{$envName}"); } } } =head3 ScriptFinish C<< ScriptFinish($webData, $varHash); >> Output a web page at the end of a script. Either the string to be output or the name of a template file can be specified. If the second parameter is omitted, it is assumed we have a string to be output; otherwise, it is assumed we have the name of a template file. The template should have the variable C<DebugData> specified in any form that invokes a standard script. If debugging mode is turned on, a form field will be put in that allows the user to enter tracing data. Trace messages will be placed immediately before the terminal C<BODY> tag in the output, formatted as a list. A typical standard script would loook like the following. BEGIN { # Print the HTML header. print "CONTENT-TYPE: text/html\n\n"; } use Tracer; use CGI; use FIG; # ... more uses ... my ($query, $varHash) = ScriptSetup(); eval { # ... get data from $query, put it in $varHash ... }; if ($@) { Trace("Script Error: $@") if T(0); } ScriptFinish("Html/MyTemplate.html", $varHash); The idea here is that even if the script fails, you'll see trace messages and useful output. =over 4 =item webData A string containing either the full web page to be written to the output or the name of a template file from which the page is to be constructed. If the name of a template file is specified, then the second parameter must be present; otherwise, it must be absent. =item varHash (optional) If specified, then a reference to a hash mapping variable names for a template to their values. The template file will be read into memory, and variable markers will be replaced by data in this hash reference. =back =cut sub ScriptFinish { # Get the parameters. my ($webData, $varHash) = @_; # Check for a template file situation. my $outputString; if (defined $varHash) { # Here we have a template file. We need to determine the template type. my $template; if ($FIG_Config::template_url && $webData =~ /\.php$/) { $template = "$FIG_Config::template_url/$webData"; } else { $template = "<<$webData"; } $outputString = PageBuilder::Build($template, $varHash, "Html"); } else { # Here the user gave us a raw string. $outputString = $webData; } # Check for trace messages. if ($Destination eq "QUEUE") { # We have trace messages, so we want to put them at the end of the body. This # is either at the end of the whole string or at the beginning of the BODY # end-tag. my $pos = length $outputString; if ($outputString =~ m#</body>#gi) { $pos = (pos $outputString) - 7; } substr $outputString, $pos, 0, QTrace('Html'); } # Write the output string. print $outputString; } =head3 Insure C<< Insure($dirName); >> Insure a directory is present. =over 4 =item dirName Name of the directory to check. If it does not exist, it will be created. =back =cut sub Insure { my ($dirName) = @_; if (! -d $dirName) { Trace("Creating $dirName directory.") if T(2); eval { mkpath $dirName; }; if ($@) { Confess("Error creating $dirName: $@"); } } } =head3 ChDir C<< ChDir($dirName); >> Change to the specified directory. =over 4 =item dirName Name of the directory to which we want to change. =back =cut sub ChDir { my ($dirName) = @_; if (! -d $dirName) { Confess("Cannot change to directory $dirName: no such directory."); } else { Trace("Changing to directory $dirName.") if T(4); my $okFlag = chdir $dirName; if (! $okFlag) { Confess("Error switching to directory $dirName."); } } } =head3 SendSMS C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >> Send a text message to a phone number using Clickatell. The FIG_Config file must contain the user name, password, and API ID for the relevant account in the hash reference variable I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID is C<2561022>, then the FIG_Config file must contain $phone = { user => 'BruceTheHumanPet', password => 'silly', api_id => '2561022' }; The original purpose of this method was to insure Bruce would be notified immediately when the Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately when you call this method. The message ID will be returned if successful, and C<undef> if an error occurs. =over 4 =item phoneNumber Phone number to receive the message, in international format. A United States phone number would be prefixed by "1". A British phone number would be prefixed by "44". =item msg Message to send to the specified phone. =item RETURN Returns the message ID if successful, and C<undef> if the message could not be sent. =back =cut sub SendSMS { # Get the parameters. my ($phoneNumber, $msg) = @_; # Declare the return variable. If we do not change it, C<undef> will be returned. my $retVal; # Only proceed if we have phone support. if (! defined $FIG_Config::phone) { Trace("Phone support not present in FIG_Config.") if T(1); } else { # Get the phone data. my $parms = $FIG_Config::phone; # Get the Clickatell URL. my $url = "http://api.clickatell.com/http/"; # Create the user agent. my $ua = LWP::UserAgent->new; # Request a Clickatell session. my $resp = $ua->post("$url/sendmsg", { user => $parms->{user}, password => $parms->{password}, api_id => $parms->{api_id}, to => $phoneNumber, text => $msg}); # Check for an error. if (! $resp->is_success) { Trace("Alert failed.") if T(1); } else { # Get the message ID. my $rstring = $resp->content; if ($rstring =~ /^ID:\s+(.*)$/) { $retVal = $1; } else { Trace("Phone attempt failed with $rstring") if T(1); } } } # Return the result. return $retVal; } =head3 CommaFormat C<< my $formatted = Tracer::CommaFormat($number); >> Insert commas into a number. =over 4 =item number A sequence of digits. =item RETURN Returns the same digits with commas strategically inserted. =back =cut sub CommaFormat { # Get the parameters. my ($number) = @_; # Pad the length up to a multiple of three. my $padded = "$number"; $padded = " " . $padded while length($padded) % 3 != 0; # This is a fancy PERL trick. The parentheses in the SPLIT pattern # cause the delimiters to be included in the output stream. The # GREP removes the empty strings in between the delimiters. my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded)); # Clean out the spaces. $retVal =~ s/ //g; # Return the result. return $retVal; } =head3 SetPermissions C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >> Set the permissions for a directory and all the files and folders inside it. In addition, the group ownership will be changed to the specified value. This method is more vulnerable than most to permission and compatability problems, so it does internal error recovery. =over 4 =item dirName Name of the directory to process. =item group Name of the group to be assigned. =item mask Permission mask. Bits that are C<1> in this mask will be ORed into the permission bits of any file or directory that does not already have them set to 1. =item otherMasks Map of search patterns to permission masks. If a directory name matches one of the patterns, that directory and all its members and subdirectories will be assigned the new pattern. For example, the following would assign 01664 to most files, but would use 01777 for directories named C<tmp>. Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777); The list is ordered, so the following would use 0777 for C<tmp1> and 0666 for C<tmp>, C<tmp2>, or C<tmp3>. Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777, '^tmp' => 0666); Note that the pattern matches are all case-insensitive, and only directory names are matched, not file names. =back =cut sub SetPermissions { # Get the parameters. my ($dirName, $group, $mask, @otherMasks) = @_; # Set up for error recovery. eval { # Switch to the specified directory. ChDir($dirName); # Get the group ID. my $gid = getgrnam($group); # Get the mask for tracing. my $traceMask = sprintf("%04o", $mask) . "($mask)"; Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2); my $fixCount = 0; my $lookCount = 0; # @dirs will be a stack of directories to be processed. my @dirs = (getcwd()); while (scalar(@dirs) > 0) { # Get the current directory. my $dir = pop @dirs; # Check for a match to one of the specified directory names. To do # that, we need to pull the individual part of the name off of the # whole path. my $simpleName = $dir; if ($dir =~ m!/([^/]+)$!) { $simpleName = $1; } Trace("Simple directory name for $dir is $simpleName.") if T(4); # Search for a match. my $match = 0; my $i; for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) { my $pattern = $otherMasks[$i]; if ($simpleName =~ /$pattern/i) { $match = 1; } } # Check for a match. Note we use $i-1 because the loop added 2 # before terminating due to the match. if ($match && $otherMasks[$i-1] != $mask) { # This directory matches one of the incoming patterns, and it's # a different mask, so we process it recursively with that mask. SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks); } else { # Here we can process normally. Get all of the non-hidden members. my @submems = OpenDir($dir, 1); for my $submem (@submems) { # Get the full name. my $thisMem = "$dir/$submem"; Trace("Checking member $thisMem.") if T(4); $lookCount++; if ($lookCount % 1000 == 0) { Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3); } # Fix the group. chown -1, $gid, $thisMem; # Insure this member is not a symlink. if (! -l $thisMem) { # Get its info. my $fileInfo = stat $thisMem; # Only proceed if we got the info. Otherwise, it's a hard link # and we want to skip it anyway. if ($fileInfo) { my $fileMode = $fileInfo->mode; if (($fileMode & $mask) != $mask) { # Fix this member. $fileMode |= $mask; chmod $fileMode, $thisMem; $fixCount++; } # If it's a subdirectory, stack it. if (-d $thisMem) { push @dirs, $thisMem; } } } } } } Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2); }; # Check for an error. if ($@) { Confess("SetPermissions error: $@"); } } =head3 CompareLists C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >> Compare two lists of tuples, and return a hash analyzing the differences. The lists are presumed to be sorted alphabetically by the value in the $keyIndex column. The return value contains a list of items that are only in the new list (inserted) and only in the old list (deleted). =over 4 =item newList Reference to a list of new tuples. =item oldList Reference to a list of old tuples. =item keyIndex (optional) Index into each tuple of its key field. The default is 0. =item RETURN Returns a 2-tuple consisting of a reference to the list of items that are only in the new list (inserted) followed by a reference to the list of items that are only in the old list (deleted). =back =cut sub CompareLists { # Get the parameters. my ($newList, $oldList, $keyIndex) = @_; if (! defined $keyIndex) { $keyIndex = 0; } # Declare the return variables. my ($inserted, $deleted) = ([], []); # Loop through the two lists simultaneously. my ($newI, $oldI) = (0, 0); my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList}); while ($newI < $newN || $oldI < $oldN) { # Get the current object in each list. Note that if one # of the lists is past the end, we'll get undef. my $newItem = $newList->[$newI]; my $oldItem = $oldList->[$oldI]; if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) { # The old item is not in the new list, so mark it deleted. push @{$deleted}, $oldItem; $oldI++; } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) { # The new item is not in the old list, so mark it inserted. push @{$inserted}, $newItem; $newI++; } else { # The item is in both lists, so push forward. $oldI++; $newI++; } } # Return the result. return ($inserted, $deleted); } =head3 GetLine C<< my @data = Tracer::GetLine($handle); >> Read a line of data from a tab-delimited file. =over 4 =item handle Open file handle from which to read. =item RETURN Returns a list of the fields in the record read. The fields are presumed to be tab-delimited. If we are at the end of the file, then an empty list will be returned. If an empty line is read, a single list item consisting of a null string will be returned. =back =cut sub GetLine { # Get the parameters. my ($handle) = @_; # Declare the return variable. my @retVal = (); # Read from the file. my $line = <$handle>; # Only proceed if we found something. if (defined $line) { # Remove the new-line. chomp $line; # If the line is empty, return a single empty string; otherwise, parse # it into fields. if ($line eq "") { push @retVal, ""; } else { push @retVal, split /\t/,$line; } } # Return the result. return @retVal; } =head3 PutLine C<< Tracer::PutLine($handle, \@fields); >> Write a line of data to a tab-delimited file. The specified field values will be output in tab-separated form, with a trailing new-line. =over 4 =item handle Output file handle. =item fields List of field values. =back =cut sub PutLine { # Get the parameters. my ($handle, $fields) = @_; # Write the data. print $handle join("\t", @{$fields}) . "\n"; } =head3 GenerateURL C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >> Generate a GET-style URL for the specified page with the specified parameter names and values. The values will be URL-escaped automatically. So, for example Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway") would return form.cgi?type=1&string=%22high%20pass%22%20or%20highway =over 4 =item page Page URL. =item parameters Hash mapping parameter names to parameter values. =item RETURN Returns a GET-style URL that goes to the specified page and passes in the specified parameters and values. =back =cut sub GenerateURL { # Get the parameters. my ($page, %parameters) = @_; # Prime the return variable with the page URL. my $retVal = $page; # Loop through the parameters, creating parameter elements in a list. my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters; # If the list is nonempty, tack it on. if (@parmList) { $retVal .= "?" . join("&", @parmList); } # Return the result. return $retVal; } 1;
| MCS Webmaster | ViewVC Help |
| Powered by ViewVC 1.0.3 |