[Bio] / FigKernelPackages / Tracer.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/Tracer.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.73, Tue Oct 3 12:04:50 2006 UTC revision 1.92, Thu Dec 6 13:59:04 2007 UTC
# Line 34  Line 34 
34      use LWP::UserAgent;      use LWP::UserAgent;
35      use Time::HiRes 'gettimeofday';      use Time::HiRes 'gettimeofday';
36      use URI::Escape;      use URI::Escape;
37        use Time::Local;
38    
39  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
40    
# Line 185  Line 186 
186  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing
187  will be configured automatically.  will be configured automatically.
188    
189    NOTE: to configure emergency tracing from the command line instead of the Debugging
190    Control Panel (see below), use the C<trace.pl> script.
191    
192  =head3 Debugging Control Panel  =head3 Debugging Control Panel
193    
194  The debugging control panel provides several tools to assist in development of  The debugging control panel provides several tools to assist in development of
# Line 296  Line 300 
300    
301  =head3 TSetup  =head3 TSetup
302    
303  C<< TSetup($categoryList, $target); >>      TSetup($categoryList, $target);
304    
305  This method is used to specify the trace options. The options are stored as package data  This method is used to specify the trace options. The options are stored as package data
306  and interrogated by the L</Trace> and L</T> methods.  and interrogated by the L</Trace> and L</T> methods.
# Line 370  Line 374 
374    
375  =head3 StandardSetup  =head3 StandardSetup
376    
377  C<< my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV); >>      my ($options, @parameters) = StandardSetup(\@categories, \%options, $parmHelp, @ARGV);
378    
379  This method performs standard command-line parsing and tracing setup. The return  This method performs standard command-line parsing and tracing setup. The return
380  values are a hash of the command-line options and a list of the positional  values are a hash of the command-line options and a list of the positional
# Line 444  Line 448 
448                            noAlias => [0, "do not expect aliases in CHANGE transactions"],                            noAlias => [0, "do not expect aliases in CHANGE transactions"],
449                            start => [' ', "start with this genome"],                            start => [' ', "start with this genome"],
450                            tblFiles => [0, "output TBL files containing the corrected IDs"] },                            tblFiles => [0, "output TBL files containing the corrected IDs"] },
451                          "command transactionDirectory IDfile",                          "<command> <transactionDirectory> <IDfile>",
452                        @ARGV);                        @ARGV);
453    
454    
# Line 456  Line 460 
460    
461      TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl      TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
462    
463    Single and double hyphens are equivalent. So, you could also code the
464    above command as
465    
466        TransactFeatures --trace=2 --noAlias register ../xacts IDs.tbl
467    
468  In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional  In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
469  parameters, and would find themselves in I<@parameters> after executing the  parameters, and would find themselves in I<@parameters> after executing the
470  above code fragment. The tracing would be set to level 2, and the categories  above code fragment. The tracing would be set to level 2, and the categories
# Line 490  Line 499 
499  the tracing key is taken from the C<Tracing> environment variable. If there  the tracing key is taken from the C<Tracing> environment variable. If there
500  is no value for that variable, the tracing key will be computed from the PID.  is no value for that variable, the tracing key will be computed from the PID.
501    
502  Finally, if the special option C<-h> is specified, the option names will  Finally, if the special option C<-help> is specified, the option
503  be traced at level 0 and the program will exit without processing.  names will be traced at level 0 and the program will exit without processing.
504  This provides a limited help capability. For example, if the user enters  This provides a limited help capability. For example, if the user enters
505    
506      TransactFeatures -h      TransactFeatures -help
507    
508  he would see the following output.  he would see the following output.
509    
510      TransactFeatures [options] command transactionDirectory IDfile      TransactFeatures [options] <command> <transactionDirectory> <IDfile>
511          -trace    tracing level (default E)          -trace    tracing level (default E)
512          -sql      trace SQL commands          -sql      trace SQL commands
513          -safe     use database transactions          -safe     use database transactions
# Line 570  Line 579 
579      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
580      # Add the tracing options.      # Add the tracing options.
581      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
582          $options->{trace} = ['E', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
583      }      }
584      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
585      $options->{h} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
586      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
587      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
588      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
# Line 598  Line 607 
607          my $errFileName = "$FIG_Config::temp/err$suffix.log";          my $errFileName = "$FIG_Config::temp/err$suffix.log";
608          open STDOUT, ">$outFileName";          open STDOUT, ">$outFileName";
609          open STDERR, ">$errFileName";          open STDERR, ">$errFileName";
610            # Check for phone support. If we have phone support and a phone number,
611            # we want to turn it on.
612            if ($ENV{PHONE} && defined($FIG_Config::phone)) {
613                $retOptions->{phone} = $ENV{PHONE};
614            }
615      }      }
616      # Now we want to set up tracing. First, we need to know if the user      # Now we want to set up tracing. First, we need to know if the user
617      # wants emergency tracing.      # wants emergency tracing.
# Line 646  Line 660 
660          # Now set up the tracing.          # Now set up the tracing.
661          TSetup("$traceLevel $cats", $traceMode);          TSetup("$traceLevel $cats", $traceMode);
662      }      }
663      # Check for the "h" option. If it is specified, dump the command-line      # Check for the "help" option. If it is specified, dump the command-line
664      # options and exit the program.      # options and exit the program.
665      if ($retOptions->{h}) {      if ($retOptions->{help}) {
666          $0 =~ m#[/\\](\w+)(\.pl)?$#i;          $0 =~ m#[/\\](\w+)(\.pl)?$#i;
667          print "$1 [options] $parmHelp\n";          print "$1 [options] $parmHelp\n";
668          for my $key (sort keys %{$options}) {          for my $key (sort keys %{$options}) {
# Line 661  Line 675 
675          }          }
676          exit(0);          exit(0);
677      }      }
678        # Trace the options, if applicable.
679        if (T(3)) {
680            my @parms = grep { $retOptions->{$_} } keys %{$retOptions};
681            Trace("Selected options: " . join(", ", sort @parms) . ".");
682        }
683      # Return the parsed parameters.      # Return the parsed parameters.
684      return ($retOptions, @retParameters);      return ($retOptions, @retParameters);
685  }  }
686    
687  =head3 Setups  =head3 Setups
688    
689  C<< my $count = Tracer::Setups(); >>      my $count = Tracer::Setups();
690    
691  Return the number of times L</TSetup> has been called.  Return the number of times L</TSetup> has been called.
692    
# Line 682  Line 701 
701    
702  =head3 Open  =head3 Open
703    
704  C<< my $handle = Open($fileHandle, $fileSpec, $message); >>      my $handle = Open($fileHandle, $fileSpec, $message);
705    
706  Open a file.  Open a file.
707    
# Line 774  Line 793 
793    
794  =head3 FindNamePart  =head3 FindNamePart
795    
796  C<< my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec); >>      my ($fileName, $start, $len) = Tracer::FindNamePart($fileSpec);
797    
798  Extract the portion of a file specification that contains the file name.  Extract the portion of a file specification that contains the file name.
799    
# Line 825  Line 844 
844    
845  =head3 OpenDir  =head3 OpenDir
846    
847  C<< my @files = OpenDir($dirName, $filtered, $flag); >>      my @files = OpenDir($dirName, $filtered, $flag);
848    
849  Open a directory and return all the file names. This function essentially performs  Open a directory and return all the file names. This function essentially performs
850  the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is  the functions of an C<opendir> and C<readdir>. If the I<$filtered> parameter is
# Line 891  Line 910 
910    
911  =head3 SetLevel  =head3 SetLevel
912    
913  C<< Tracer::SetLevel($newLevel); >>      Tracer::SetLevel($newLevel);
914    
915  Modify the trace level. A higher trace level will cause more messages to appear.  Modify the trace level. A higher trace level will cause more messages to appear.
916    
# Line 911  Line 930 
930    
931  =head3 Now  =head3 Now
932    
933  C<< my $string = Tracer::Now(); >>      my $string = Tracer::Now();
934    
935  Return a displayable time stamp containing the local time.  Return a displayable time stamp containing the local time.
936    
# Line 931  Line 950 
950      return $value;      return $value;
951  }  }
952    
953    =head3 ParseTraceDate
954    
955        my $time = Tracer::ParseTraceDate($dateString);
956    
957    Convert a date from the trace file into a PERL timestamp.
958    
959    =over 4
960    
961    =item dateString
962    
963    The date string from the trace file. The format of the string is determined by the
964    L</Now> method.
965    
966    =item RETURN
967    
968    Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if
969    the time string is invalid.
970    
971    =back
972    
973    =cut
974    
975    sub ParseTraceDate {
976        # Get the parameters.
977        my ($dateString) = @_;
978        # Declare the return variable.
979        my $retVal;
980        # Parse the date.
981        if ($dateString =~ m#(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)#) {
982            # Create a time object. Note we need to convert the day, month,
983            # and year to a different base. Years count from 1900, and
984            # the internal month value is relocated to January = 0.
985            $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);
986        }
987        # Return the result.
988        return $retVal;
989    }
990    
991  =head3 LogErrors  =head3 LogErrors
992    
993  C<< Tracer::LogErrors($fileName); >>      Tracer::LogErrors($fileName);
994    
995  Route the standard error output to a log file.  Route the standard error output to a log file.
996    
# Line 956  Line 1013 
1013    
1014  =head3 ReadOptions  =head3 ReadOptions
1015    
1016  C<< my %options = Tracer::ReadOptions($fileName); >>      my %options = Tracer::ReadOptions($fileName);
1017    
1018  Read a set of options from a file. Each option is encoded in a line of text that has the  Read a set of options from a file. Each option is encoded in a line of text that has the
1019  format  format
# Line 1017  Line 1074 
1074    
1075  =head3 GetOptions  =head3 GetOptions
1076    
1077  C<< Tracer::GetOptions(\%defaults, \%options); >>      Tracer::GetOptions(\%defaults, \%options);
1078    
1079  Merge a specified set of options into a table of defaults. This method takes two hash references  Merge a specified set of options into a table of defaults. This method takes two hash references
1080  as input and uses the data from the second to update the first. If the second does not exist,  as input and uses the data from the second to update the first. If the second does not exist,
# Line 1026  Line 1083 
1083    
1084  Consider the following example.  Consider the following example.
1085    
1086  C<< my $optionTable = GetOptions({ dbType => 'mySQL', trace => 0 }, $options); >>      my $optionTable = GetOptions({ dbType => 'mySQL', trace => 0 }, $options);
1087    
1088  In this example, the variable B<$options> is expected to contain at most two options-- B<dbType> and  In this example, the variable B<$options> is expected to contain at most two options-- B<dbType> and
1089  B<trace>. The default database type is C<mySQL> and the default trace level is C<0>. If the value of  B<trace>. The default database type is C<mySQL> and the default trace level is C<0>. If the value of
# Line 1034  Line 1091 
1091  the trace level will remain at 0. If B<$options> is undefined, then the database type and trace level  the trace level will remain at 0. If B<$options> is undefined, then the database type and trace level
1092  will remain C<mySQL> and C<0>. If, on the other hand, B<$options> is defined as  will remain C<mySQL> and C<0>. If, on the other hand, B<$options> is defined as
1093    
1094  C<< {databaseType => 'Oracle'} >>      {databaseType => 'Oracle'}
1095    
1096  an error will occur because the B<databaseType> option does not exist.  an error will occur because the B<databaseType> option does not exist.
1097    
# Line 1078  Line 1135 
1135    
1136  =head3 MergeOptions  =head3 MergeOptions
1137    
1138  C<< Tracer::MergeOptions(\%table, \%defaults); >>      Tracer::MergeOptions(\%table, \%defaults);
1139    
1140  Merge default values into a hash table. This method looks at the key-value pairs in the  Merge default values into a hash table. This method looks at the key-value pairs in the
1141  second (default) hash, and if a matching key is not found in the first hash, the default  second (default) hash, and if a matching key is not found in the first hash, the default
# Line 1112  Line 1169 
1169    
1170  =head3 Trace  =head3 Trace
1171    
1172  C<< Trace($message); >>      Trace($message);
1173    
1174  Write a trace message to the target location specified in L</TSetup>. If there has not been  Write a trace message to the target location specified in L</TSetup>. If there has not been
1175  any prior call to B<TSetup>.  any prior call to B<TSetup>.
# Line 1133  Line 1190 
1190      # Get the timestamp.      # Get the timestamp.
1191      my $timeStamp = Now();      my $timeStamp = Now();
1192      # Format the message. Note we strip off any line terminators at the end.      # Format the message. Note we strip off any line terminators at the end.
1193      my $formatted = "[$timeStamp] <$LastCategory>: " . Strip($message);      my $prefix = "[$timeStamp] <$LastCategory>: ";
1194        my $formatted = $prefix . Strip($message);
1195      # Process according to the destination.      # Process according to the destination.
1196      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
1197          # Write the message to the standard output.          # Write the message to the standard output.
# Line 1147  Line 1205 
1205      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
1206          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML and write it to the standard output.
1207          my $escapedMessage = CGI::escapeHTML($message);          my $escapedMessage = CGI::escapeHTML($message);
1208          print "<p>$formatted</p>\n";          print "<p>$timeStamp $LastCategory: $escapedMessage</p>\n";
1209      } elsif ($Destination eq "WARN") {      } elsif ($Destination eq "WARN") {
1210         # Emit the message as a warning.         # Emit the message as a warning.
1211         warn $message;         warn $message;
# Line 1165  Line 1223 
1223    
1224  =head3 T  =head3 T
1225    
1226  C<< my $switch = T($category, $traceLevel); >>      my $switch = T($category, $traceLevel);
1227    
1228      or      or
1229    
1230  C<< my $switch = T($traceLevel); >>      my $switch = T($traceLevel);
1231    
1232  Return TRUE if the trace level is at or above a specified value and the specified category  Return TRUE if the trace level is at or above a specified value and the specified category
1233  is active, else FALSE. If no category is specified, the caller's package name is used.  is active, else FALSE. If no category is specified, the caller's package name is used.
# Line 1212  Line 1270 
1270              if (!$package) {              if (!$package) {
1271                  $category = "main";                  $category = "main";
1272              } else {              } else {
1273                  $category = $package;                  my @cats = split /::/, $package;
1274                    $category = $cats[$#cats];
1275              }              }
1276          }          }
1277          # Save the category name.          # Save the category name.
# Line 1233  Line 1292 
1292    
1293  =head3 ParseCommand  =head3 ParseCommand
1294    
1295  C<< my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList); >>      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);
1296    
1297  Parse a command line consisting of a list of parameters. The initial parameters may be option  Parse a command line consisting of a list of parameters. The initial parameters may be option
1298  specifiers of the form C<->I<option> or C<->I<option>C<=>I<value>. The options are stripped  specifiers of the form C<->I<option> or C<->I<option>C<=>I<value>. The options are stripped
1299  off and merged into a table of default options. The remainder of the command line is  off and merged into a table of default options. The remainder of the command line is
1300  returned as a list of positional arguments. For example, consider the following invocation.  returned as a list of positional arguments. For example, consider the following invocation.
1301    
1302  C<< my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words); >>      my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words);
1303    
1304  In this case, the list @words will be treated as a command line. There are two options available,  In this case, the list @words will be treated as a command line and there are two options available,
1305  B<errors> and B<logFile>. If @words has the following format  B<errors> and B<logFile>. If @words has the following format
1306    
1307  C<< -logFile=error.log apple orange rutabaga >>      -logFile=error.log apple orange rutabaga
1308    
1309  then at the end of the invocation, C<$options> will be  then at the end of the invocation, C<$options> will be
1310    
1311  C<< { errors => 0, logFile => 'error.log' } >>      { errors => 0, logFile => 'error.log' }
1312    
1313  and C<@arguments> will contain  and C<@arguments> will contain
1314    
1315  C<< apple orange rutabaga >>      apple orange rutabaga
1316    
1317  The parser allows for some escape sequences. See L</UnEscape> for a description. There is no  The parser allows for some escape sequences. See L</UnEscape> for a description. There is no
1318  support for quote characters.  support for quote characters. Options can be specified with single or double hyphens.
1319    
1320  =over 4  =over 4
1321    
# Line 1281  Line 1340 
1340      my ($optionTable, @inputList) = @_;      my ($optionTable, @inputList) = @_;
1341      # Process any options in the input list.      # Process any options in the input list.
1342      my %overrides = ();      my %overrides = ();
1343      while ((@inputList > 0) && ($inputList[0] =~ /^-/)) {      while ((@inputList > 0) && ($inputList[0] =~ /^--?/)) {
1344          # Get the current option.          # Get the current option.
1345          my $arg = shift @inputList;          my $arg = shift @inputList;
1346          # Pull out the option name.          # Pull out the option name.
1347          $arg =~ /^-([^=]*)/g;          $arg =~ /^--?([^=]*)/g;
1348          my $name = $1;          my $name = $1;
1349          # Check for an option value.          # Check for an option value.
1350          if ($arg =~ /\G=(.*)$/g) {          if ($arg =~ /\G=(.*)$/g) {
# Line 1309  Line 1368 
1368    
1369  =head3 Escape  =head3 Escape
1370    
1371  C<< my $codedString = Tracer::Escape($realString); >>      my $codedString = Tracer::Escape($realString);
1372    
1373  Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines  Escape a string for use in a command length. Tabs will be replaced by C<\t>, new-lines
1374  replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The  replaced by C<\n>, carriage returns will be deleted, and backslashes will be doubled. The
# Line 1364  Line 1423 
1423    
1424  =head3 UnEscape  =head3 UnEscape
1425    
1426  C<< my $realString = Tracer::UnEscape($codedString); >>      my $realString = Tracer::UnEscape($codedString);
1427    
1428  Replace escape sequences with their actual equivalents. C<\t> will be replaced by  Replace escape sequences with their actual equivalents. C<\t> will be replaced by
1429  a tab, C<\n> by a new-line character, and C<\\> by a backslash. C<\r> codes will  a tab, C<\n> by a new-line character, and C<\\> by a backslash. C<\r> codes will
# Line 1424  Line 1483 
1483    
1484  =head3 ParseRecord  =head3 ParseRecord
1485    
1486  C<< my @fields = Tracer::ParseRecord($line); >>      my @fields = Tracer::ParseRecord($line);
1487    
1488  Parse a tab-delimited data line. The data line is split into field values. Embedded tab  Parse a tab-delimited data line. The data line is split into field values. Embedded tab
1489  and new-line characters in the data line must be represented as C<\t> and C<\n>, respectively.  and new-line characters in the data line must be represented as C<\t> and C<\n>, respectively.
# Line 1469  Line 1528 
1528    
1529  =head3 Merge  =head3 Merge
1530    
1531  C<< my @mergedList = Tracer::Merge(@inputList); >>      my @mergedList = Tracer::Merge(@inputList);
1532    
1533  Sort a list of strings and remove duplicates.  Sort a list of strings and remove duplicates.
1534    
# Line 1517  Line 1576 
1576    
1577  =head3 Percent  =head3 Percent
1578    
1579  C<< my $percent = Tracer::Percent($number, $base); >>      my $percent = Tracer::Percent($number, $base);
1580    
1581  Returns the percent of the base represented by the given number. If the base  Returns the percent of the base represented by the given number. If the base
1582  is zero, returns zero.  is zero, returns zero.
# Line 1555  Line 1614 
1614    
1615  =head3 GetFile  =head3 GetFile
1616    
1617  C<< my @fileContents = Tracer::GetFile($fileName); >>      my @fileContents = Tracer::GetFile($fileName);
1618    
1619      or      or
1620    
1621  C<< my $fileContents = Tracer::GetFile($fileName); >>      my $fileContents = Tracer::GetFile($fileName);
1622    
1623  Return the entire contents of a file. In list context, line-ends are removed and  Return the entire contents of a file. In list context, line-ends are removed and
1624  each line is a list element. In scalar context, line-ends are replaced by C<\n>.  each line is a list element. In scalar context, line-ends are replaced by C<\n>.
# Line 1598  Line 1657 
1657      # Close it.      # Close it.
1658      close $handle;      close $handle;
1659      my $actualLines = @retVal;      my $actualLines = @retVal;
1660        Trace("$actualLines lines read from file $fileName.") if T(File => 2);
1661      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1662      if (wantarray) {      if (wantarray) {
1663          return @retVal;          return @retVal;
# Line 1608  Line 1668 
1668    
1669  =head3 PutFile  =head3 PutFile
1670    
1671  C<< Tracer::PutFile($fileName, \@lines); >>      Tracer::PutFile($fileName, \@lines);
1672    
1673  Write out a file from a list of lines of text.  Write out a file from a list of lines of text.
1674    
# Line 1633  Line 1693 
1693      my ($fileName, $lines) = @_;      my ($fileName, $lines) = @_;
1694      # Open the output file.      # Open the output file.
1695      my $handle = Open(undef, ">$fileName");      my $handle = Open(undef, ">$fileName");
1696        # Count the lines written.
1697      if (ref $lines ne 'ARRAY') {      if (ref $lines ne 'ARRAY') {
1698          # Here we have a scalar, so we write it raw.          # Here we have a scalar, so we write it raw.
1699          print $handle $lines;          print $handle $lines;
1700            Trace("Scalar put to file $fileName.") if T(File => 3);
1701      } else {      } else {
1702          # Write the lines one at a time.          # Write the lines one at a time.
1703            my $count = 0;
1704          for my $line (@{$lines}) {          for my $line (@{$lines}) {
1705              print $handle "$line\n";              print $handle "$line\n";
1706                $count++;
1707          }          }
1708            Trace("$count lines put to file $fileName.") if T(File => 3);
1709      }      }
1710      # Close the output file.      # Close the output file.
1711      close $handle;      close $handle;
# Line 1648  Line 1713 
1713    
1714  =head3 QTrace  =head3 QTrace
1715    
1716  C<< my $data = QTrace($format); >>      my $data = QTrace($format);
1717    
1718  Return the queued trace data in the specified format.  Return the queued trace data in the specified format.
1719    
# Line 1691  Line 1756 
1756    
1757  =head3 Confess  =head3 Confess
1758    
1759  C<< Confess($message); >>      Confess($message);
1760    
1761  Trace the call stack and abort the program with the specified message. When used with  Trace the call stack and abort the program with the specified message. When used with
1762  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.  the OR operator and the L</Assert> method, B<Confess> can function as a debugging assert.
1763  So, for example  So, for example
1764    
1765  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>      Assert($recNum >= 0) || Confess("Invalid record number $recNum.");
1766    
1767  Will abort the program with a stack trace if the value of C<$recNum> is negative.  Will abort the program with a stack trace if the value of C<$recNum> is negative.
1768    
# Line 1714  Line 1779 
1779  sub Confess {  sub Confess {
1780      # Get the parameters.      # Get the parameters.
1781      my ($message) = @_;      my ($message) = @_;
1782        if (! defined($FIG_Config::no_tool_hdr)) {
1783            # Here we have a tool header. Display its length so that the user can adjust the line numbers.
1784            my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";
1785            # Only proceed if the tool header file is actually present.
1786            if (-f $toolHeaderFile) {
1787                my @lines = GetFile($toolHeaderFile);
1788                Trace("Tool header has " . scalar(@lines) . " lines.");
1789            }
1790        }
1791      # Trace the call stack.      # Trace the call stack.
1792      Cluck($message);      Cluck($message);
1793      # Abort the program.      # Abort the program.
# Line 1722  Line 1796 
1796    
1797  =head3 Assert  =head3 Assert
1798    
1799  C<< Assert($condition1, $condition2, ... $conditionN); >>      Assert($condition1, $condition2, ... $conditionN);
1800    
1801  Return TRUE if all the conditions are true. This method can be used in conjunction with  Return TRUE if all the conditions are true. This method can be used in conjunction with
1802  the OR operator and the L</Confess> method as a debugging assert.  the OR operator and the L</Confess> method as a debugging assert.
1803  So, for example  So, for example
1804    
1805  C<< Assert($recNum >= 0) || Confess("Invalid record number $recNum."); >>      Assert($recNum >= 0) || Confess("Invalid record number $recNum.");
1806    
1807  Will abort the program with a stack trace if the value of C<$recNum> is negative.  Will abort the program with a stack trace if the value of C<$recNum> is negative.
1808    
# Line 1746  Line 1820 
1820    
1821  =head3 Cluck  =head3 Cluck
1822    
1823  C<< Cluck($message); >>      Cluck($message);
1824    
1825  Trace the call stack. Note that for best results, you should qualify the call with a  Trace the call stack. Note that for best results, you should qualify the call with a
1826  trace condition. For example,  trace condition. For example,
1827    
1828  C<< Cluck("Starting record parse.") if T(3); >>      Cluck("Starting record parse.") if T(3);
1829    
1830  will only trace the stack if the trace level for the package is 3 or more.  will only trace the stack if the trace level for the package is 3 or more.
1831    
# Line 1780  Line 1854 
1854    
1855  =head3 Min  =head3 Min
1856    
1857  C<< my $min = Min($value1, $value2, ... $valueN); >>      my $min = Min($value1, $value2, ... $valueN);
1858    
1859  Return the minimum argument. The arguments are treated as numbers.  Return the minimum argument. The arguments are treated as numbers.
1860    
# Line 1813  Line 1887 
1887    
1888  =head3 Max  =head3 Max
1889    
1890  C<< my $max = Max($value1, $value2, ... $valueN); >>      my $max = Max($value1, $value2, ... $valueN);
1891    
1892  Return the maximum argument. The arguments are treated as numbers.  Return the maximum argument. The arguments are treated as numbers.
1893    
# Line 1846  Line 1920 
1920    
1921  =head3 AddToListMap  =head3 AddToListMap
1922    
1923  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>      Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN);
1924    
1925  Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list  Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list
1926  is created for the key. Otherwise, the new value is pushed onto the list.  is created for the key. Otherwise, the new value is pushed onto the list.
# Line 1882  Line 1956 
1956    
1957  =head3 DebugMode  =head3 DebugMode
1958    
1959  C<< if (Tracer::DebugMode) { ...code... } >>      if (Tracer::DebugMode) { ...code... }
1960    
1961  Return TRUE if debug mode has been turned on, else abort.  Return TRUE if debug mode has been turned on, else abort.
1962    
# Line 1912  Line 1986 
1986    
1987  =head3 Strip  =head3 Strip
1988    
1989  C<< my $string = Tracer::Strip($line); >>      my $string = Tracer::Strip($line);
1990    
1991  Strip all line terminators off a string. This is necessary when dealing with files  Strip all line terminators off a string. This is necessary when dealing with files
1992  that may have been transferred back and forth several times among different  that may have been transferred back and forth several times among different
# Line 1944  Line 2018 
2018    
2019  =head3 Pad  =head3 Pad
2020    
2021  C<< my $paddedString = Tracer::Pad($string, $len, $left, $padChar); >>      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);
2022    
2023  Pad a string to a specified length. The pad character will be a  Pad a string to a specified length. The pad character will be a
2024  space, and the padding will be on the right side unless specified  space, and the padding will be on the right side unless specified
# Line 2015  Line 2089 
2089    
2090  =head3 TICK  =head3 TICK
2091    
2092  C<< my @results = TICK($commandString); >>      my @results = TICK($commandString);
2093    
2094  Perform a back-tick operation on a command. If this is a Windows environment, any leading  Perform a back-tick operation on a command. If this is a Windows environment, any leading
2095  dot-slash (C<./> will be removed. So, for example, if you were doing  dot-slash (C<./> will be removed. So, for example, if you were doing
# Line 2056  Line 2130 
2130    
2131  =head3 ScriptSetup  =head3 ScriptSetup
2132    
2133  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>      my ($cgi, $varHash) = ScriptSetup($noTrace);
2134    
2135  Perform standard tracing and debugging setup for scripts. The value returned is  Perform standard tracing and debugging setup for scripts. The value returned is
2136  the CGI object followed by a pre-built variable hash.  the CGI object followed by a pre-built variable hash. At the end of the script,
2137    the client should call L</ScriptFinish> to output the web page.
2138    
2139  The C<Trace> form parameter is used to determine whether or not tracing is active and  This method calls L</ETracing> to configure tracing, which allows the tracing
2140  which trace modules (other than C<Tracer> itself) should be turned on. Specifying  to be configured via the emergency tracing form on the debugging control panel.
 the C<CGI> trace module will trace parameter and environment information. Parameters are  
 traced at level 3 and environment variables at level 4. To trace to a file instead of to  
 the web page, set C<TF> to 1. At the end of the script, the client should call  
 L</ScriptFinish> to output the web page.  
   
 In some situations, it is not practical to invoke tracing via form parameters. For this  
 situation, you can turn on emergency tracing from the debugging control panel.  
2141  Tracing will then be turned on automatically for all programs that use the L</ETracing>  Tracing will then be turned on automatically for all programs that use the L</ETracing>
2142  method, which includes every program that uses this method or L</StandardSetup>.  method, which includes every program that uses this method or L</StandardSetup>.
2143    
# Line 2104  Line 2172 
2172    
2173  =head3 ETracing  =head3 ETracing
2174    
2175  C<< ETracing($parameter); >>      ETracing($parameter);
2176    
2177  Set up emergency tracing. Emergency tracing is tracing that is turned  Set up emergency tracing. Emergency tracing is tracing that is turned
2178  on automatically for any program that calls this method. The emergency  on automatically for any program that calls this method. The emergency
# Line 2185  Line 2253 
2253    
2254  =head3 EmergencyFileName  =head3 EmergencyFileName
2255    
2256  C<< my $fileName = Tracer::EmergencyFileName($tkey); >>      my $fileName = Tracer::EmergencyFileName($tkey);
2257    
2258  Return the emergency tracing file name. This is the file that specifies  Return the emergency tracing file name. This is the file that specifies
2259  the tracing information.  the tracing information.
# Line 2213  Line 2281 
2281    
2282  =head3 EmergencyFileTarget  =head3 EmergencyFileTarget
2283    
2284  C<< my $fileName = Tracer::EmergencyFileTarget($tkey); >>      my $fileName = Tracer::EmergencyFileTarget($tkey);
2285    
2286  Return the emergency tracing target file name. This is the file that receives  Return the emergency tracing target file name. This is the file that receives
2287  the tracing output for file-based tracing.  the tracing output for file-based tracing.
# Line 2241  Line 2309 
2309    
2310  =head3 EmergencyTracingDest  =head3 EmergencyTracingDest
2311    
2312  C<< my $dest = Tracer::EmergencyTracingDest($tkey, $myDest); >>      my $dest = Tracer::EmergencyTracingDest($tkey, $myDest);
2313    
2314  This method converts an emergency tracing destination to a real  This method converts an emergency tracing destination to a real
2315  tracing destination. The main difference is that if the  tracing destination. The main difference is that if the
2316  destination is C<FILE> or C<APPEND>, we convert it to file  destination is C<FILE> or C<APPEND>, we convert it to file
2317  output.  output. If the destination is C<DUAL>, we convert it to file
2318    and standard output.
2319    
2320  =over 4  =over 4
2321    
# Line 2270  Line 2339 
2339      # Get the parameters.      # Get the parameters.
2340      my ($tkey, $myDest) = @_;      my ($tkey, $myDest) = @_;
2341      # Declare the return variable.      # Declare the return variable.
2342      my $retVal;      my $retVal = $myDest;
2343      # Process according to the destination value.      # Process according to the destination value.
2344      if ($myDest eq 'FILE') {      if ($myDest eq 'FILE') {
2345          $retVal = ">" . EmergencyFileTarget($tkey);          $retVal = ">" . EmergencyFileTarget($tkey);
2346      } elsif ($myDest eq 'APPEND') {      } elsif ($myDest eq 'APPEND') {
2347          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
2348      } else {      } elsif ($myDest eq 'DUAL') {
2349          $retVal = $myDest;          $retVal = "+>" . EmergencyFileTarget($tkey);
2350      }      }
2351      # Return the result.      # Return the result.
2352      return $retVal;      return $retVal;
# Line 2285  Line 2354 
2354    
2355  =head3 Emergency  =head3 Emergency
2356    
2357  C<< Emergency($key, $hours, $dest, $level, @modules); >>      Emergency($key, $hours, $dest, $level, @modules);
2358    
2359  Turn on emergency tracing. This method can only be invoked over the web and is  Turn on emergency tracing. This method is normally invoked over the web from
2360  should not be called if debug mode is off. The caller specifies the duration of the  a debugging console, but it can also be called by the C<trace.pl> script.
2361  emergency in hours, the desired tracing destination, the trace level,  The caller specifies the duration of the emergency in hours, the desired tracing
2362  and a list of the trace modules to activate. For the length of the duration, when a  destination, the trace level, and a list of the trace modules to activate.
2363  program in an environment with the specified tracing key active invokes a Sprout  For the length of the duration, when a program in an environment with the
2364  CGI script, tracing will be turned on automatically. See L</TSetup> for more  specified tracing key active invokes a Sprout CGI script, tracing will be
2365  about tracing setup and L</ETracing> for more about emergency tracing.  turned on automatically. See L</TSetup> for more about tracing setup and
2366    L</ETracing> for more about emergency tracing.
2367    
2368  =over 4  =over 4
2369    
# Line 2333  Line 2403 
2403    
2404  =head3 EmergencyKey  =head3 EmergencyKey
2405    
2406  C<< my $tkey = EmergencyKey($parameter); >>      my $tkey = EmergencyKey($parameter);
2407    
2408  Return the Key to be used for emergency tracing. This could be an IP address,  Return the Key to be used for emergency tracing. This could be an IP address,
2409   a session ID, or a user name, depending on the environment.   a session ID, or a user name, depending on the environment.
# Line 2385  Line 2455 
2455    
2456  =head3 TraceParms  =head3 TraceParms
2457    
2458  C<< Tracer::TraceParms($cgi); >>      Tracer::TraceParms($cgi);
2459    
2460  Trace the CGI parameters at trace level CGI => 3 and the environment variables  Trace the CGI parameters at trace level CGI => 3 and the environment variables
2461  at level CGI => 4.  at level CGI => 4.
# Line 2427  Line 2497 
2497    
2498  =head3 ScriptFinish  =head3 ScriptFinish
2499    
2500  C<< ScriptFinish($webData, $varHash); >>      ScriptFinish($webData, $varHash);
2501    
2502  Output a web page at the end of a script. Either the string to be output or the  Output a web page at the end of a script. Either the string to be output or the
2503  name of a template file can be specified. If the second parameter is omitted,  name of a template file can be specified. If the second parameter is omitted,
# Line 2529  Line 2599 
2599    
2600  =head3 Insure  =head3 Insure
2601    
2602  C<< Insure($dirName); >>      Insure($dirName, $chmod);
2603    
2604  Insure a directory is present.  Insure a directory is present.
2605    
# Line 2539  Line 2609 
2609    
2610  Name of the directory to check. If it does not exist, it will be created.  Name of the directory to check. If it does not exist, it will be created.
2611    
2612    =item chmod (optional)
2613    
2614    Security privileges to be given to the directory if it is created.
2615    
2616  =back  =back
2617    
2618  =cut  =cut
2619    
2620  sub Insure {  sub Insure {
2621      my ($dirName) = @_;      my ($dirName, $chmod) = @_;
2622      if (! -d $dirName) {      if (! -d $dirName) {
2623          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(2);
2624          eval { mkpath $dirName; };          eval {
2625                mkpath $dirName;
2626                # If we have permissions specified, set them here.
2627                if (defined($chmod)) {
2628                    chmod $chmod, $dirName;
2629                }
2630            };
2631          if ($@) {          if ($@) {
2632              Confess("Error creating $dirName: $@");              Confess("Error creating $dirName: $@");
2633          }          }
# Line 2556  Line 2636 
2636    
2637  =head3 ChDir  =head3 ChDir
2638    
2639  C<< ChDir($dirName); >>      ChDir($dirName);
2640    
2641  Change to the specified directory.  Change to the specified directory.
2642    
# Line 2575  Line 2655 
2655      if (! -d $dirName) {      if (! -d $dirName) {
2656          Confess("Cannot change to directory $dirName: no such directory.");          Confess("Cannot change to directory $dirName: no such directory.");
2657      } else {      } else {
2658          Trace("Changing to directory $dirName.") if T(4);          Trace("Changing to directory $dirName.") if T(File => 4);
2659          my $okFlag = chdir $dirName;          my $okFlag = chdir $dirName;
2660          if (! $okFlag) {          if (! $okFlag) {
2661              Confess("Error switching to directory $dirName.");              Confess("Error switching to directory $dirName.");
# Line 2585  Line 2665 
2665    
2666  =head3 SendSMS  =head3 SendSMS
2667    
2668  C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>      my $msgID = Tracer::SendSMS($phoneNumber, $msg);
2669    
2670  Send a text message to a phone number using Clickatell. The FIG_Config file must contain the  Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2671  user name, password, and API ID for the relevant account in the hash reference variable  user name, password, and API ID for the relevant account in the hash reference variable
# Line 2662  Line 2742 
2742    
2743  =head3 CommaFormat  =head3 CommaFormat
2744    
2745  C<< my $formatted = Tracer::CommaFormat($number); >>      my $formatted = Tracer::CommaFormat($number);
2746    
2747  Insert commas into a number.  Insert commas into a number.
2748    
# Line 2697  Line 2777 
2777  }  }
2778  =head3 SetPermissions  =head3 SetPermissions
2779    
2780  C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>      Tracer::SetPermissions($dirName, $group, $mask, %otherMasks);
2781    
2782  Set the permissions for a directory and all the files and folders inside it.  Set the permissions for a directory and all the files and folders inside it.
2783  In addition, the group ownership will be changed to the specified value.  In addition, the group ownership will be changed to the specified value.
# Line 2754  Line 2834 
2834          my $gid = getgrnam($group);          my $gid = getgrnam($group);
2835          # Get the mask for tracing.          # Get the mask for tracing.
2836          my $traceMask = sprintf("%04o", $mask) . "($mask)";          my $traceMask = sprintf("%04o", $mask) . "($mask)";
2837          Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);          Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(File => 2);
2838          my $fixCount = 0;          my $fixCount = 0;
2839          my $lookCount = 0;          my $lookCount = 0;
2840          # @dirs will be a stack of directories to be processed.          # @dirs will be a stack of directories to be processed.
# Line 2769  Line 2849 
2849              if ($dir =~ m!/([^/]+)$!) {              if ($dir =~ m!/([^/]+)$!) {
2850                  $simpleName = $1;                  $simpleName = $1;
2851              }              }
2852              Trace("Simple directory name for $dir is $simpleName.") if T(4);              Trace("Simple directory name for $dir is $simpleName.") if T(File => 4);
2853              # Search for a match.              # Search for a match.
2854              my $match = 0;              my $match = 0;
2855              my $i;              my $i;
# Line 2794  Line 2874 
2874                      Trace("Checking member $thisMem.") if T(4);                      Trace("Checking member $thisMem.") if T(4);
2875                      $lookCount++;                      $lookCount++;
2876                      if ($lookCount % 1000 == 0) {                      if ($lookCount % 1000 == 0) {
2877                          Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);                          Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(File => 3);
2878                      }                      }
2879                      # Fix the group.                      # Fix the group.
2880                      chown -1, $gid, $thisMem;                      chown -1, $gid, $thisMem;
# Line 2821  Line 2901 
2901                  }                  }
2902              }              }
2903          }          }
2904          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(File => 2);
2905      };      };
2906      # Check for an error.      # Check for an error.
2907      if ($@) {      if ($@) {
# Line 2831  Line 2911 
2911    
2912  =head3 CompareLists  =head3 CompareLists
2913    
2914  C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);
2915    
2916  Compare two lists of tuples, and return a hash analyzing the differences. The lists  Compare two lists of tuples, and return a hash analyzing the differences. The lists
2917  are presumed to be sorted alphabetically by the value in the $keyIndex column.  are presumed to be sorted alphabetically by the value in the $keyIndex column.
# Line 2898  Line 2978 
2978    
2979  =head3 GetLine  =head3 GetLine
2980    
2981  C<< my @data = Tracer::GetLine($handle); >>      my @data = Tracer::GetLine($handle);
2982    
2983  Read a line of data from a tab-delimited file.  Read a line of data from a tab-delimited file.
2984    
# Line 2924  Line 3004 
3004      my ($handle) = @_;      my ($handle) = @_;
3005      # Declare the return variable.      # Declare the return variable.
3006      my @retVal = ();      my @retVal = ();
3007        Trace("File position is " . tell($handle) . ". EOF flag is " . eof($handle) . ".") if T(File => 4);
3008      # Read from the file.      # Read from the file.
3009      my $line = <$handle>;      my $line = <$handle>;
3010      # Only proceed if we found something.      # Only proceed if we found something.
3011      if (defined $line) {      if (defined $line) {
3012          # Remove the new-line.          # Remove the new-line. We are a bit over-cautious here because the file may be coming in via an
3013          chomp $line;          # upload control and have a nonstandard EOL combination.
3014            $line =~ s/(\r|\n)+$//;
3015            # Here we do some fancy tracing to help in debugging complicated EOL marks.
3016            if (T(File => 4)) {
3017                my $escapedLine = $line;
3018                $escapedLine =~ s/\n/\\n/g;
3019                $escapedLine =~ s/\r/\\r/g;
3020                $escapedLine =~ s/\t/\\t/g;
3021                Trace("Line read: -->$escapedLine<--");
3022            }
3023          # If the line is empty, return a single empty string; otherwise, parse          # If the line is empty, return a single empty string; otherwise, parse
3024          # it into fields.          # it into fields.
3025          if ($line eq "") {          if ($line eq "") {
# Line 2937  Line 3027 
3027          } else {          } else {
3028              push @retVal, split /\t/,$line;              push @retVal, split /\t/,$line;
3029          }          }
3030        } else {
3031            # Trace the reason the read failed.
3032            Trace("End of file: $!") if T(File => 3);
3033      }      }
3034      # Return the result.      # Return the result.
3035      return @retVal;      return @retVal;
# Line 2944  Line 3037 
3037    
3038  =head3 PutLine  =head3 PutLine
3039    
3040  C<< Tracer::PutLine($handle, \@fields); >>      Tracer::PutLine($handle, \@fields, $eol);
3041    
3042  Write a line of data to a tab-delimited file. The specified field values will be  Write a line of data to a tab-delimited file. The specified field values will be
3043  output in tab-separated form, with a trailing new-line.  output in tab-separated form, with a trailing new-line.
# Line 2959  Line 3052 
3052    
3053  List of field values.  List of field values.
3054    
3055    =item eol (optional)
3056    
3057    End-of-line character (default is "\n").
3058    
3059  =back  =back
3060    
3061  =cut  =cut
3062    
3063  sub PutLine {  sub PutLine {
3064      # Get the parameters.      # Get the parameters.
3065      my ($handle, $fields) = @_;      my ($handle, $fields, $eol) = @_;
3066      # Write the data.      # Write the data.
3067      print $handle join("\t", @{$fields}) . "\n";      print $handle join("\t", @{$fields}) . ($eol || "\n");
3068  }  }
3069    
3070  =head3 GenerateURL  =head3 GenerateURL
3071    
3072  C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >>      my $queryUrl = Tracer::GenerateURL($page, %parameters);
3073    
3074  Generate a GET-style URL for the specified page with the specified parameter  Generate a GET-style URL for the specified page with the specified parameter
3075  names and values. The values will be URL-escaped automatically. So, for  names and values. The values will be URL-escaped automatically. So, for
# Line 2982  Line 3079 
3079    
3080  would return  would return
3081    
3082      form.cgi?type=1&string=%22high%20pass%22%20or%20highway      form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3083    
3084  =over 4  =over 4
3085    
# Line 3012  Line 3109 
3109      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
3110      # If the list is nonempty, tack it on.      # If the list is nonempty, tack it on.
3111      if (@parmList) {      if (@parmList) {
3112          $retVal .= "?" . join("&", @parmList);          $retVal .= "?" . join(";", @parmList);
3113      }      }
3114      # Return the result.      # Return the result.
3115      return $retVal;      return $retVal;
3116  }  }
3117    
3118    =head3 ApplyURL
3119    
3120        Tracer::ApplyURL($table, $target, $url);
3121    
3122    Run through a two-dimensional table (or more accurately, a list of lists), converting the
3123    I<$target> column to HTML text having a hyperlink to a URL in the I<$url> column. The
3124    URL column will be deleted by this process and the target column will be HTML-escaped.
3125    
3126    This provides a simple way to process the results of a database query into something
3127    displayable by combining a URL with text.
3128    
3129    =over 4
3130    
3131    =item table
3132    
3133    Reference to a list of lists. The elements in the containing list will be updated by
3134    this method.
3135    
3136    =item target
3137    
3138    The index of the column to be converted into HTML.
3139    
3140    =item url
3141    
3142    The index of the column containing the URL. Note that the URL must have a recognizable
3143    C<http:> at the beginning.
3144    
3145    =back
3146    
3147    =cut
3148    
3149    sub ApplyURL {
3150        # Get the parameters.
3151        my ($table, $target, $url) = @_;
3152        # Loop through the table.
3153        for my $row (@{$table}) {
3154            # Apply the URL to the target cell.
3155            $row->[$target] = CombineURL($row->[$target], $row->[$url]);
3156            # Delete the URL from the row.
3157            delete $row->[$url];
3158        }
3159    }
3160    
3161    =head3 CombineURL
3162    
3163        my $combinedHtml = Tracer::CombineURL($text, $url);
3164    
3165    This method will convert the specified text into HTML hyperlinked to the specified
3166    URL. The hyperlinking will only take place if the URL looks legitimate: that is, it
3167    is defined and begins with an C<http:> header.
3168    
3169    =over 4
3170    
3171    =item text
3172    
3173    Text to return. This will be HTML-escaped automatically.
3174    
3175    =item url
3176    
3177    A URL to be hyperlinked to the text. If it does not look like a URL, then the text
3178    will be returned without any hyperlinking.
3179    
3180    =item RETURN
3181    
3182    Returns the original text, HTML-escaped, with the URL hyperlinked to it. If the URL
3183    doesn't look right, the HTML-escaped text will be returned without any further
3184    modification.
3185    
3186    =back
3187    
3188    =cut
3189    
3190    sub CombineURL {
3191        # Get the parameters.
3192        my ($text, $url) = @_;
3193        # Declare the return variable.
3194        my $retVal = CGI::escapeHTML($text);
3195        # Verify the URL.
3196        if (defined($url) && $url =~ m!http://!i) {
3197            # It's good, so we apply it to the text.
3198            $retVal = "<a href=\"$url\">$retVal</a>";
3199        }
3200        # Return the result.
3201        return $retVal;
3202    }
3203    
3204    
3205  1;  1;

Legend:
Removed from v.1.73  
changed lines
  Added in v.1.92

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3