[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.39, Fri Feb 24 19:45:29 2006 UTC revision 1.70, Mon Oct 2 04:41:46 2006 UTC
# Line 19  Line 19 
19    
20      require Exporter;      require Exporter;
21      @ISA = ('Exporter');      @ISA = ('Exporter');
22      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup ScriptSetup ScriptFinish Insure);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyIP ScriptSetup ScriptFinish Insure ChDir Emergency);
23      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
24      use strict;      use strict;
25      use Carp qw(longmess croak);      use Carp qw(longmess croak);
26      use CGI;      use CGI;
27        use Cwd;
28      use FIG_Config;      use FIG_Config;
29      use PageBuilder;      use PageBuilder;
30      use Digest::MD5;      use Digest::MD5;
31      use File::Basename;      use File::Basename;
32      use File::Path;      use File::Path;
33        use File::stat;
34        use LWP::UserAgent;
35        use Time::HiRes 'gettimeofday';
36        use URI::Escape;
37    
38  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
39    
# Line 116  Line 121 
121    
122  =back  =back
123    
124    The format of trace messages is important because some utilities analyze trace files.
125    The time stamp is between square brackets, the module name between angle brackets,
126    a colon (C<:>), and the message text after that. If the square brackets or angle
127    brackets are missing, then the trace management utilities assume that they
128    are encountering a set of pre-formatted lines.
129    
130  =cut  =cut
131    
132  # Declare the configuration variables.  # Declare the configuration variables.
# Line 195  Line 206 
206          }          }
207          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
208              open TRACEFILE, $target;              open TRACEFILE, $target;
209              print TRACEFILE Now() . " Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";
210              close TRACEFILE;              close TRACEFILE;
211              $Destination = ">$target";              $Destination = ">$target";
212          } else {          } else {
# Line 228  Line 239 
239      ["Sprout", "SproutLoad", "ERDB"]      ["Sprout", "SproutLoad", "ERDB"]
240    
241  This would cause trace messages in the specified three packages to appear in  This would cause trace messages in the specified three packages to appear in
242  the output. There are threer special tracing categories that are automatically  the output. There are two special tracing categories that are automatically
243  handled by this method. In other words, if you used L</TSetup> you would need  handled by this method. In other words, if you used L</TSetup> you would need
244  to include these categories manually, but if you use this method they are turned  to include these categories manually, but if you use this method they are turned
245  on automatically.  on automatically.
246    
247  =over 4  =over 4
248    
 =item FIG  
   
 Turns on trace messages inside the B<FIG> package.  
   
249  =item SQL  =item SQL
250    
251  Traces SQL commands and activity.  Traces SQL commands and activity.
# Line 275  Line 282 
282  of a keyword, the value is separated from the option name by an equal sign. You  of a keyword, the value is separated from the option name by an equal sign. You
283  can see this last in the command-line example above.  can see this last in the command-line example above.
284    
285    You can specify a different default trace level by setting C<$options->{trace}>
286    prior to calling this method.
287    
288  An example at this point would help. Consider, for example, the command-line utility  An example at this point would help. Consider, for example, the command-line utility
289  C<TransactFeatures>. It accepts a list of positional parameters plus the options  C<TransactFeatures>. It accepts a list of positional parameters plus the options
290  C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute  C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
# Line 300  Line 310 
310  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
311  parameters, and would find themselves in I<@parameters> after executing the  parameters, and would find themselves in I<@parameters> after executing the
312  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
313  would be C<FIG>, C<Tracer>, and <DocUtils>. C<FIG> and C<Tracer> are standard,  would be C<Tracer>, and <DocUtils>. C<Tracer> is standard,
314  and C<DocUtils> was included because it came in within the first parameter  and C<DocUtils> was included because it came in within the first parameter
315  to this method. The I<$options> hash would be  to this method. The I<$options> hash would be
316    
# Line 314  Line 324 
324  need to be added in the future, they can be processed by this method without  need to be added in the future, they can be processed by this method without
325  upsetting the command-line utilities.  upsetting the command-line utilities.
326    
327    If the C<background> option is specified on the command line, then the
328    standard and error outputs will be directed to files in the temporary
329    directory, using the same suffix as the trace file. So, if the command
330    line specified
331    
332        -user=Bruce -background
333    
334    then the trace output would go to C<traceBruce.log>, the standard output to
335    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
336    simplify starting a command in the background.
337    
338  Finally, if the special option C<-h> is specified, the option names will  Finally, if the special option C<-h> is specified, the option names will
339  be traced at level 0 and the program will exit without processing.  be traced at level 0 and the program will exit without processing.
340  This provides a limited help capability. For example, if the user enters  This provides a limited help capability. For example, if the user enters
# Line 330  Line 351 
351          -start    start with this genome          -start    start with this genome
352          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
353    
354    The caller has the option of modifying the tracing scheme by placing a value
355    for C<trace> in the incoming options hash. The default value can be overridden,
356    or the tracing to the standard output can be turned off by suffixing a minus
357    sign to the trace level. So, for example,
358    
359        { trace => [0, "tracing level (default 0)"],
360           ...
361    
362    would set the default trace level to 0 instead of 2, while
363    
364        { trace => ["2-", "tracing level (default 2)"],
365           ...
366    
367    would leave the default at 2, but trace only to the log file, not to the
368    standard output.
369    
370  The parameters to this method are as follows.  The parameters to this method are as follows.
371    
372  =over 4  =over 4
# Line 347  Line 384 
384  by specifying the options as command-line switches prefixed by a hyphen.  by specifying the options as command-line switches prefixed by a hyphen.
385  Tracing-related options may be added to this hash. If the C<-h> option is  Tracing-related options may be added to this hash. If the C<-h> option is
386  specified on the command line, the option descriptions will be used to  specified on the command line, the option descriptions will be used to
387  explain the options.  explain the options. To turn off tracing to the standard output, add a
388    minus sign to the value for C<trace> (see above).
389    
390  =item parmHelp  =item parmHelp
391    
392  A string that vaguely describes the positional parameters. This is used  A string that vaguely describes the positional parameters. This is used
393  if the user specifies the C<-h> option.  if the user specifies the C<-h> option.
394    
395  =item ARGV  =item argv
396    
397  List of command line parameters, including the option switches, which must  List of command line parameters, including the option switches, which must
398  precede the positional parameters and be prefixed by a hyphen.  precede the positional parameters and be prefixed by a hyphen.
# Line 374  Line 412 
412      # Get the parameters.      # Get the parameters.
413      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
414      # Add the tracing options.      # Add the tracing options.
415        if (! exists $options->{trace}) {
416      $options->{trace} = [2, "tracing level"];      $options->{trace} = [2, "tracing level"];
417        }
418      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
419      $options->{h} = [0, "display command-line options"];      $options->{h} = [0, "display command-line options"];
420      $options->{user} = [$$, "trace log file name suffix"];      $options->{user} = [$$, "trace log file name suffix"];
421        $options->{background} = [0, "spool standard and error output"];
422      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
423      # contains the default values rather than the default value      # contains the default values rather than the default value
424      # and the description. While we're at it, we'll memorize the      # and the description. While we're at it, we'll memorize the
# Line 392  Line 433 
433      }      }
434      # Parse the command line.      # Parse the command line.
435      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
436        # Get the logfile suffix.
437        my $suffix = $retOptions->{user};
438        # Check for background mode.
439        if ($retOptions->{background}) {
440            my $outFileName = "$FIG_Config::temp/out$suffix.log";
441            my $errFileName = "$FIG_Config::temp/err$suffix.log";
442            open STDOUT, ">$outFileName";
443            open STDERR, ">$errFileName";
444        }
445      # Now we want to set up tracing. First, we need to know if SQL is to      # Now we want to set up tracing. First, we need to know if SQL is to
446      # be traced.      # be traced.
447      my @cats = @{$categories};      my @cats = @{$categories};
# Line 399  Line 449 
449          push @cats, "SQL";          push @cats, "SQL";
450      }      }
451      # Add the default categories.      # Add the default categories.
452      push @cats, "Tracer", "FIG";      push @cats, "Tracer";
453      # Next, we create the category string by prefixing the trace level      # Next, we create the category string by joining the categories.
454      # and joining the categories.      my $cats = join(" ", @cats);
455      my $cats = join(" ", $parseOptions{trace}, @cats);      # Check to determine whether or not the caller wants to turn off tracing
456        # to the standard output.
457        my $traceLevel = $retOptions->{trace};
458        my $textOKFlag = 1;
459        if ($traceLevel =~ /^(.)-/) {
460            $traceLevel = $1;
461            $textOKFlag = 0;
462        }
463        # Now we set up the trace mode.
464        my $traceMode;
465        # Verify that we can open a file in the FIG temporary directory.
466        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
467        if (open TESTTRACE, ">$traceFileName") {
468            # Here we can trace to a file.
469            $traceMode = ">$traceFileName";
470            if ($textOKFlag) {
471                # Echo to standard output if the text-OK flag is set.
472                $traceMode = "+$traceMode";
473            }
474            # Close the test file.
475            close TESTTRACE;
476        } else {
477            # Here we can't trace to a file. We trace to the standard output if it's
478            # okay, and the error log otherwise.
479            if ($textOKFlag) {
480                $traceMode = "TEXT";
481            } else {
482                $traceMode = "WARN";
483            }
484        }
485      # Now set up the tracing.      # Now set up the tracing.
486      my $suffix = $retOptions->{user};      TSetup("$traceLevel $cats", $traceMode);
     TSetup($cats, "+>$FIG_Config::temp/trace$suffix.log");  
487      # Check for the "h" option. If it is specified, dump the command-line      # Check for the "h" option. If it is specified, dump the command-line
488      # options and exit the program.      # options and exit the program.
489      if ($retOptions->{h}) {      if ($retOptions->{h}) {
490          $0 =~ m#[/\\](\w+)(\.pl)?$#i;          $0 =~ m#[/\\](\w+)(\.pl)?$#i;
491          Trace("$1 [options] $parmHelp") if T(0);          print "$1 [options] $parmHelp\n";
492          for my $key (sort keys %{$options}) {          for my $key (sort keys %{$options}) {
493              my $name = Pad($key, $longestName, 0, ' ');              my $name = Pad($key, $longestName, 0, ' ');
494              my $desc = $options->{$key}->[1];              my $desc = $options->{$key}->[1];
495              if ($options->{$key}->[0]) {              if ($options->{$key}->[0]) {
496                  $desc .= " (default " . $options->{$key}->[0] . ")";                  $desc .= " (default " . $options->{$key}->[0] . ")";
497              }              }
498              Trace("  $name $desc") if T(0);              print "  $name $desc\n";
499          }          }
500          exit(0);          exit(0);
501      }      }
# Line 893  Line 971 
971      # Get the timestamp.      # Get the timestamp.
972      my $timeStamp = Now();      my $timeStamp = Now();
973      # 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.
974      my $formatted = "$timeStamp <$LastCategory>: " . Strip($message);      my $formatted = "[$timeStamp] <$LastCategory>: " . Strip($message);
975      # Process according to the destination.      # Process according to the destination.
976      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
977          # Write the message to the standard output.          # Write the message to the standard output.
# Line 1275  Line 1353 
1353      return @inputList;      return @inputList;
1354  }  }
1355    
1356    =head3 Percent
1357    
1358    C<< my $percent = Tracer::Percent($number, $base); >>
1359    
1360    Returns the percent of the base represented by the given number. If the base
1361    is zero, returns zero.
1362    
1363    =over 4
1364    
1365    =item number
1366    
1367    Percent numerator.
1368    
1369    =item base
1370    
1371    Percent base.
1372    
1373    =item RETURN
1374    
1375    Returns the percentage of the base represented by the numerator.
1376    
1377    =back
1378    
1379    =cut
1380    
1381    sub Percent {
1382        # Get the parameters.
1383        my ($number, $base) = @_;
1384        # Declare the return variable.
1385        my $retVal = 0;
1386        # Compute the percent.
1387        if ($base != 0) {
1388            $retVal = $number * 100 / $base;
1389        }
1390        # Return the result.
1391        return $retVal;
1392    }
1393    
1394  =head3 GetFile  =head3 GetFile
1395    
1396  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
# Line 1308  Line 1424 
1424      # Declare the return variable.      # Declare the return variable.
1425      my @retVal = ();      my @retVal = ();
1426      # Open the file for input.      # Open the file for input.
1427      my $ok = open INPUTFILE, "<$fileName";      my $handle = Open(undef, "<$fileName");
     if (!$ok) {  
         # If we had an error, trace it. We will automatically return a null value.  
         Trace("Could not open \"$fileName\" for input: $!") if T(0);  
     } else {  
1428          # Read the whole file into the return variable, stripping off any terminator          # Read the whole file into the return variable, stripping off any terminator
1429          # characters.          # characters.
1430          my $lineCount = 0;          my $lineCount = 0;
1431          while (my $line = <INPUTFILE>) {      while (my $line = <$handle>) {
1432              $lineCount++;              $lineCount++;
1433              $line = Strip($line);              $line = Strip($line);
1434              push @retVal, $line;              push @retVal, $line;
1435          }          }
1436          # Close it.          # Close it.
1437          close INPUTFILE;      close $handle;
1438          my $actualLines = @retVal;          my $actualLines = @retVal;
     }  
1439      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1440      if (wantarray) {      if (wantarray) {
1441          return @retVal;          return @retVal;
# Line 1333  Line 1444 
1444      }      }
1445  }  }
1446    
1447    =head3 PutFile
1448    
1449    C<< Tracer::PutFile($fileName, \@lines); >>
1450    
1451    Write out a file from a list of lines of text.
1452    
1453    =over 4
1454    
1455    =item fileName
1456    
1457    Name of the output file.
1458    
1459    =item lines
1460    
1461    Reference to a list of text lines. The lines will be written to the file in order, with trailing
1462    new-line characters. Alternatively, may be a string, in which case the string will be written without
1463    modification.
1464    
1465    =back
1466    
1467    =cut
1468    
1469    sub PutFile {
1470        # Get the parameters.
1471        my ($fileName, $lines) = @_;
1472        # Open the output file.
1473        my $handle = Open(undef, ">$fileName");
1474        if (ref $lines ne 'ARRAY') {
1475            # Here we have a scalar, so we write it raw.
1476            print $handle $lines;
1477        } else {
1478            # Write the lines one at a time.
1479            for my $line (@{$lines}) {
1480                print $handle "$line\n";
1481            }
1482        }
1483        # Close the output file.
1484        close $handle;
1485    }
1486    
1487  =head3 QTrace  =head3 QTrace
1488    
1489  C<< my $data = QTrace($format); >>  C<< my $data = QTrace($format); >>
# Line 1533  Line 1684 
1684    
1685  =head3 AddToListMap  =head3 AddToListMap
1686    
1687  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1688    
1689  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
1690  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 1548  Line 1699 
1699    
1700  Key for which the value is to be added.  Key for which the value is to be added.
1701    
1702  =item value  =item value1, value2, ... valueN
1703    
1704  Value to add to the key's value list.  List of values to add to the key's value list.
1705    
1706  =back  =back
1707    
# Line 1558  Line 1709 
1709    
1710  sub AddToListMap {  sub AddToListMap {
1711      # Get the parameters.      # Get the parameters.
1712      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1713      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1714      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1715          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1716      } else {      } else {
1717          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1718      }      }
1719  }  }
1720    
# Line 1571  Line 1722 
1722    
1723  C<< if (Tracer::DebugMode) { ...code... } >>  C<< if (Tracer::DebugMode) { ...code... } >>
1724    
1725  Return TRUE if debug mode has been turned on, else output an error  Return TRUE if debug mode has been turned on, else abort.
 page and return FALSE.  
1726    
1727  Certain CGI scripts are too dangerous to exist in the production  Certain CGI scripts are too dangerous to exist in the production
1728  environment. This method provides a simple way to prevent them  environment. This method provides a simple way to prevent them
1729  from working unless they are explicitly turned on by creating a password  from working unless they are explicitly turned on by creating a password
1730  cookie via the B<SetPassword> script.  If debugging mode  cookie via the B<SetPassword> script.  If debugging mode
1731  is not turned on, an error web page will be output directing the  is not turned on, an error will occur.
 user to enter in the correct password.  
1732    
1733  =cut  =cut
1734    
# Line 1592  Line 1741 
1741      if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {      if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {
1742          $retVal = 1;          $retVal = 1;
1743      } else {      } else {
1744          # Here debug mode is off, so we generate an error page.          # Here debug mode is off, so we generate an error.
1745          my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");          Confess("Cannot use this facility without logging in.");
         print $pageString;  
1746      }      }
1747      # Return the determination indicator.      # Return the determination indicator.
1748      return $retVal;      return $retVal;
# Line 1746  Line 1894 
1894    
1895  =head3 ScriptSetup  =head3 ScriptSetup
1896    
1897  C<< my ($query, $varHash) = ScriptSetup(); >>  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>
1898    
1899  Perform standard tracing and debugging setup for scripts. The value returned is  Perform standard tracing and debugging setup for scripts. The value returned is
1900  the CGI object followed by a pre-built variable hash.  the CGI object followed by a pre-built variable hash.
1901    
1902  The C<Trace> query parameter is used to determine whether or not tracing is active and  The C<Trace> query parameter is used to determine whether or not tracing is active and
1903  which trace modules (other than C<Tracer> and C<FIG>) should be turned on. Specifying  which trace modules (other than C<Tracer> itself) should be turned on. Specifying
1904  the C<CGI> trace module will trace parameter and environment information. Parameters are  the C<CGI> trace module will trace parameter and environment information. Parameters are
1905  traced at level 3 and environment variables at level 4. At the end of the script, the  traced at level 3 and environment variables at level 4. To trace to a file instead of to
1906  client should call L</ScriptFinish> to output the web page.  the web page, set C<TF> to 1. At the end of the script, the client should call
1907    L</ScriptFinish> to output the web page.
1908    
1909    In some situations, it is not practical to invoke tracing via form parameters. For this
1910    situation, you can turn on emergency tracing by invoking the L</Emergency> method from
1911    a web page. Emergency tracing is detected via a file with the name
1912    C<Emergency>I<IPaddr>C<.txt> in the FIG temporary directory, where I<IPaddr> is the
1913    IP address of the remote user who wants tracing turned on. The file contains a time
1914    limit in hours on the first line, a tracing destination on the second line, a trace
1915    level on the third line, and the tracing modules on subsequent lines.
1916    
1917    =over 4
1918    
1919    =item noTrace (optional)
1920    
1921    If specified, tracing will be suppressed. This is useful if the script wants to set up
1922    tracing manually.
1923    
1924    =item RETURN
1925    
1926    Returns a two-element list consisting of a CGI query object and a variable hash for
1927    the output page.
1928    
1929    =back
1930    
1931  =cut  =cut
1932    
1933  sub ScriptSetup {  sub ScriptSetup {
1934        # Get the parameters.
1935        my ($noTrace) = @_;
1936      # Get the CGI query object.      # Get the CGI query object.
1937      my $query = CGI->new();      my $cgi = CGI->new();
1938      # Check for tracing. Set it up if the user asked for it.      # Set up tracing if it's not suppressed.
1939      if ($query->param('Trace')) {      CGITrace($cgi) unless $noTrace;
1940          # Set up tracing to be queued for display at the bottom of the web page.      # Create the variable hash.
1941          TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");      my $varHash = { results => '' };
1942        # Return the query object and variable hash.
1943        return ($cgi, $varHash);
1944    }
1945    
1946    =head3 CGITrace
1947    
1948    C<< Tracer::CGITrace($cgi); >>
1949    
1950    Set up tracing for a CGI script. See L</ScriptSetup> for more information.
1951    
1952    =over 4
1953    
1954    =item cgi
1955    
1956    Ths CGI query object for this script.
1957    
1958    =back
1959    
1960    =cut
1961    
1962    sub CGITrace {
1963        # Get the parameters.
1964        my ($cgi) = @_;
1965        # Default to no tracing except errors.
1966        my ($tracing, $dest) = ("0", "WARN");
1967        # Check for emergency tracing.
1968        my $ip = EmergencyIP($cgi);
1969        my $emergencyFile = EmergencyFileName($ip);
1970        if (-e $emergencyFile) {
1971            # We have the file. Read in the data.
1972            my @tracing = GetFile($emergencyFile);
1973            # Pull off the time limit.
1974            my $expire = shift @tracing;
1975            # Convert it to seconds.
1976            $expire *= 3600;
1977            # Check the file data.
1978            my $stat = stat($emergencyFile);
1979            my ($now) = gettimeofday;
1980            if ($now - $stat->mtime > $expire) {
1981                # Delete the expired file.
1982                unlink $emergencyFile;
1983            } else {
1984                # Emergency tracing is on. Pull off the destination and
1985                # the trace level;
1986                $dest = shift @tracing;
1987                my $level = shift @tracing;
1988                # Convert the destination to a real tracing destination.
1989                # temp directory.
1990                $dest = EmergencyTracingDest($ip, $dest);
1991                warn "Tracing will be to $dest.\n";
1992                # Insure Tracer is specified.
1993                my %moduleHash = map { $_ => 1 } @tracing;
1994                $moduleHash{Tracer} = 1;
1995                # Set the trace parameter.
1996                $tracing = join(" ", $level, sort keys %moduleHash);
1997                # Make sure the script knows tracing is on.
1998                $cgi->param(-name => 'Trace', -value => $tracing);
1999                $cgi->param(-name => 'TF', -value => (($dest =~ /^>/) ? 1 : 0));
2000            }
2001        } elsif ($cgi->param('Trace')) {
2002            # Here the user has requested tracing via a form.
2003            $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
2004            $tracing = $cgi->param('Trace') . " Tracer";
2005        }
2006        # Setup the tracing we've determined from all the stuff above.
2007        TSetup($tracing, $dest);
2008          # Trace the parameter and environment data.          # Trace the parameter and environment data.
2009        TraceParms($cgi);
2010    }
2011    
2012    =head3 EmergencyFileName
2013    
2014    C<< my $fileName = Tracer::EmergencyFileName($ip); >>
2015    
2016    Return the emergency tracing file name. This is the file that specifies
2017    the tracing information.
2018    
2019    =over 4
2020    
2021    =item ip
2022    
2023    IP address of the user who wants tracing, as taken from the C<< $cgi->remote_host() >>
2024    method.
2025    
2026    =item RETURN
2027    
2028    Returns the name of the file to contain the emergency tracing information.
2029    
2030    =back
2031    
2032    =cut
2033    
2034    sub EmergencyFileName {
2035        # Get the parameters.
2036        my ($ip) = @_;
2037        # Compute the emergency tracing file name.
2038        return "$FIG_Config::temp/Emergency$ip.txt";
2039    }
2040    
2041    =head3 EmergencyFileTarget
2042    
2043    C<< my $fileName = Tracer::EmergencyFileTarget($ip); >>
2044    
2045    Return the emergency tracing target file name. This is the file that receives
2046    the tracing output for file-based tracing.
2047    
2048    =over 4
2049    
2050    =item ip
2051    
2052    IP address of the user who wants tracing, as taken from the C<< $cgi->remote_host() >>
2053    method.
2054    
2055    =item RETURN
2056    
2057    Returns the name of the file to contain the emergency tracing information.
2058    
2059    =back
2060    
2061    =cut
2062    
2063    sub EmergencyFileTarget {
2064        # Get the parameters.
2065        my ($ip) = @_;
2066        # Compute the emergency tracing file name.
2067        return "$FIG_Config::temp/Emergency$ip.log";
2068    }
2069    
2070    =head3 EmergencyTracingDest
2071    
2072    C<< my $dest = Tracer::EmergencyTracingDest($ip, $myDest); >>
2073    
2074    This method converts an emergency tracing destination to a real
2075    tracing destination. The main difference is that if the
2076    destination is C<FILE> or C<APPEND>, we convert it to file
2077    output.
2078    
2079    =over 4
2080    
2081    =item ip
2082    
2083    IP address of the user who wants tracing, as taken from the C<< $cgi->remote_host() >>
2084    method.
2085    
2086    =item myDest
2087    
2088    Destination from the emergency tracing file.
2089    
2090    =item RETURN
2091    
2092    Returns a destination that can be passed into L</TSetup>.
2093    
2094    =back
2095    
2096    =cut
2097    
2098    sub EmergencyTracingDest {
2099        # Get the parameters.
2100        my ($ip, $myDest) = @_;
2101        # Declare the return variable.
2102        my $retVal;
2103        # Process according to the destination value.
2104        if ($myDest eq 'FILE') {
2105            $retVal = ">" . EmergencyFileTarget($ip);
2106        } elsif ($myDest eq 'APPEND') {
2107            $retVal = ">>" . EmergencyFileTarget($ip);
2108        } else {
2109            $retVal = $myDest;
2110        }
2111        # Return the result.
2112        return $retVal;
2113    }
2114    
2115    =head3 Emergency
2116    
2117    C<< Emergency($cgi, $hours, $dest, $level, @modules); >>
2118    
2119    Turn on emergency tracing. This method can only be invoked over the web and is
2120    should not be called if debug mode is off. The caller specifies the duration of the
2121    emergency in hours, the desired tracing destination, the trace level,
2122    and a list of the trace modules to activate. For the duration, when a user
2123    from the specified remote web location invokes a Sprout CGI script, tracing
2124    will be turned on automatically. See L</TSetup> for more about tracing
2125    setup and L</ScriptSetup> for more about emergency tracing.
2126    
2127    =over 4
2128    
2129    =item cgi
2130    
2131    A CGI query object.
2132    
2133    =item hours
2134    
2135    Number of hours to keep emergency tracing alive.
2136    
2137    =item dest
2138    
2139    Tracing destination. If no path information is specified for a file
2140    destination, it is put in the FIG temporary directory.
2141    
2142    =item level
2143    
2144    Tracing level. A higher level means more trace messages.
2145    
2146    =item modules
2147    
2148    A list of the tracing modules to activate.
2149    
2150    =back
2151    
2152    =cut
2153    
2154    sub Emergency {
2155        # Get the parameters.
2156        my ($cgi, $hours, $dest, $level, @modules) = @_;
2157        # Get the IP address.
2158        my $ip = EmergencyIP($cgi);
2159        # Create the emergency file.
2160        my $specFile = EmergencyFileName($ip);
2161        my $outHandle = Open(undef, ">$specFile");
2162        print $outHandle join("\n",$hours, $dest, $level, @modules, "");
2163    }
2164    
2165    =head3 EmergencyIP
2166    
2167    C<< my $ip = EmergencyIP($cgi); >>
2168    
2169    Return the IP address to be used for emergency tracing. In actual fact, this is not an
2170    IP address but a session ID stored in a cookie. It used to be an IP address, but those
2171    are too fluid.
2172    
2173    =over 4
2174    
2175    =item cgi
2176    
2177    CGI query object.
2178    
2179    =item RETURN
2180    
2181    Returns the IP address to be used for labelling emergency tracing.
2182    
2183    =back
2184    
2185    =cut
2186    
2187    sub EmergencyIP {
2188        # Get the parameters.
2189        my ($cgi) = @_;
2190        # Look for a cookie.
2191        my $retVal = $cgi->cookie('IP');
2192        # If no cookie, return the remote host address. This will probably not
2193        # work, but that's okay, since the lack of a cookie means the
2194        # tracing is not turned on.
2195        $retVal = $cgi->remote_host() if ! $retVal;
2196        # Return the result.
2197        return $retVal;
2198    }
2199    
2200    
2201    =head3 TraceParms
2202    
2203    C<< Tracer::TraceParms($cgi); >>
2204    
2205    Trace the CGI parameters at trace level CGI => 3 and the environment variables
2206    at level CGI => 4.
2207    
2208    =over 4
2209    
2210    =item cgi
2211    
2212    CGI query object containing the parameters to trace.
2213    
2214    =back
2215    
2216    =cut
2217    
2218    sub TraceParms {
2219        # Get the parameters.
2220        my ($cgi) = @_;
2221          if (T(CGI => 3)) {          if (T(CGI => 3)) {
2222              # Here we want to trace the parameter data.              # Here we want to trace the parameter data.
2223              my @names = $query->param;          my @names = $cgi->param;
2224              for my $parmName (sort @names) {              for my $parmName (sort @names) {
2225                  # Note we skip "Trace", which is for our use only.              # Note we skip the Trace parameters, which are for our use only.
2226                  if ($parmName ne 'Trace') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
2227                      my @values = $query->param($parmName);                  my @values = $cgi->param($parmName);
2228                      Trace("CGI: $parmName = " . join(", ", @values));                      Trace("CGI: $parmName = " . join(", ", @values));
2229                  }                  }
2230              }              }
2231            # Display the request method.
2232            my $method = $cgi->request_method();
2233            Trace("Method: $method");
2234          }          }
2235          if (T(CGI => 4)) {          if (T(CGI => 4)) {
2236              # Here we want the environment data too.              # Here we want the environment data too.
# Line 1784  Line 2238 
2238                  Trace("ENV: $envName = $ENV{$envName}");                  Trace("ENV: $envName = $ENV{$envName}");
2239              }              }
2240          }          }
     } 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 => '' };  
     # If we're in DEBUG mode, set up the debug mode data for forms.  
     if (Tracer::DebugMode) {  
         $varHash->{DebugData} = GetFile("Html/DebugFragment.html");  
     }  
     # Return the query object and variable hash.  
     return ($query, $varHash);  
2241  }  }
2242    
2243  =head3 ScriptFinish  =head3 ScriptFinish
# Line 1823  Line 2264 
2264      use FIG;      use FIG;
2265      # ... more uses ...      # ... more uses ...
2266    
2267      my ($query, $varHash) = ScriptSetup();      my ($cgi, $varHash) = ScriptSetup();
2268      eval {      eval {
2269          # ... get data from $query, put it in $varHash ...          # ... get data from $cgi, put it in $varHash ...
2270      };      };
2271      if ($@) {      if ($@) {
2272          Trace("Script Error: $@") if T(0);          Trace("Script Error: $@") if T(0);
# Line 1860  Line 2301 
2301      # Check for a template file situation.      # Check for a template file situation.
2302      my $outputString;      my $outputString;
2303      if (defined $varHash) {      if (defined $varHash) {
2304          # Here we have a template file. We need to apply the variables to the template.          # Here we have a template file. We need to determine the template type.
2305          $outputString = PageBuilder::Build("<$webData", $varHash, "Html");          my $template;
2306            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
2307                $template = "$FIG_Config::template_url/$webData";
2308            } else {
2309                $template = "<<$webData";
2310            }
2311            $outputString = PageBuilder::Build($template, $varHash, "Html");
2312      } else {      } else {
2313          # Here the user gave us a raw string.          # Here the user gave us a raw string.
2314          $outputString = $webData;          $outputString = $webData;
2315      }      }
2316      # Check for trace messages.      # Check for trace messages.
2317      if ($Destination eq "QUEUE") {      if ($Destination ne "NONE" && $TraceLevel > 0) {
2318          # We have trace messages, so we want to put them at the end of the body. This          # We have trace messages, so we want to put them at the end of the body. This
2319          # is either at the end of the whole string or at the beginning of the BODY          # is either at the end of the whole string or at the beginning of the BODY
2320          # end-tag.          # end-tag.
# Line 1875  Line 2322 
2322          if ($outputString =~ m#</body>#gi) {          if ($outputString =~ m#</body>#gi) {
2323              $pos = (pos $outputString) - 7;              $pos = (pos $outputString) - 7;
2324          }          }
2325          substr $outputString, $pos, 0, QTrace('Html');          # If the trace messages were queued, we unroll them. Otherwise, we display the
2326            # destination.
2327            my $traceHtml;
2328            if ($Destination eq "QUEUE") {
2329                $traceHtml = QTrace('Html');
2330            } elsif ($Destination =~ /^>>(.+)$/) {
2331                # Here the tracing output it to a file. We code it as a hyperlink so the user
2332                # can copy the file name into the clipboard easily.
2333                my $actualDest = $1;
2334                $traceHtml = "<p>Tracing output to <a href=\"$actualDest\">$actualDest</a>.</p>\n";
2335            } else {
2336                # Here we have one of the special destinations.
2337                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
2338            }
2339            substr $outputString, $pos, 0, $traceHtml;
2340      }      }
2341      # Write the output string.      # Write the output string.
2342      print $outputString;      print $outputString;
# Line 1901  Line 2362 
2362      my ($dirName) = @_;      my ($dirName) = @_;
2363      if (! -d $dirName) {      if (! -d $dirName) {
2364          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(2);
2365          mkpath $dirName;          eval { mkpath $dirName; };
2366            if ($@) {
2367                Confess("Error creating $dirName: $@");
2368            }
2369        }
2370    }
2371    
2372    =head3 ChDir
2373    
2374    C<< ChDir($dirName); >>
2375    
2376    Change to the specified directory.
2377    
2378    =over 4
2379    
2380    =item dirName
2381    
2382    Name of the directory to which we want to change.
2383    
2384    =back
2385    
2386    =cut
2387    
2388    sub ChDir {
2389        my ($dirName) = @_;
2390        if (! -d $dirName) {
2391            Confess("Cannot change to directory $dirName: no such directory.");
2392        } else {
2393            Trace("Changing to directory $dirName.") if T(4);
2394            my $okFlag = chdir $dirName;
2395            if (! $okFlag) {
2396                Confess("Error switching to directory $dirName.");
2397            }
2398        }
2399    }
2400    
2401    =head3 SendSMS
2402    
2403    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2404    
2405    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2406    user name, password, and API ID for the relevant account in the hash reference variable
2407    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2408    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2409    is C<2561022>, then the FIG_Config file must contain
2410    
2411        $phone =  { user => 'BruceTheHumanPet',
2412                    password => 'silly',
2413                    api_id => '2561022' };
2414    
2415    The original purpose of this method was to insure Bruce would be notified immediately when the
2416    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2417    when you call this method.
2418    
2419    The message ID will be returned if successful, and C<undef> if an error occurs.
2420    
2421    =over 4
2422    
2423    =item phoneNumber
2424    
2425    Phone number to receive the message, in international format. A United States phone number
2426    would be prefixed by "1". A British phone number would be prefixed by "44".
2427    
2428    =item msg
2429    
2430    Message to send to the specified phone.
2431    
2432    =item RETURN
2433    
2434    Returns the message ID if successful, and C<undef> if the message could not be sent.
2435    
2436    =back
2437    
2438    =cut
2439    
2440    sub SendSMS {
2441        # Get the parameters.
2442        my ($phoneNumber, $msg) = @_;
2443        # Declare the return variable. If we do not change it, C<undef> will be returned.
2444        my $retVal;
2445        # Only proceed if we have phone support.
2446        if (! defined $FIG_Config::phone) {
2447            Trace("Phone support not present in FIG_Config.") if T(1);
2448        } else {
2449            # Get the phone data.
2450            my $parms = $FIG_Config::phone;
2451            # Get the Clickatell URL.
2452            my $url = "http://api.clickatell.com/http/";
2453            # Create the user agent.
2454            my $ua = LWP::UserAgent->new;
2455            # Request a Clickatell session.
2456            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2457                                         password => $parms->{password},
2458                                         api_id => $parms->{api_id},
2459                                         to => $phoneNumber,
2460                                         text => $msg});
2461            # Check for an error.
2462            if (! $resp->is_success) {
2463                Trace("Alert failed.") if T(1);
2464            } else {
2465                # Get the message ID.
2466                my $rstring = $resp->content;
2467                if ($rstring =~ /^ID:\s+(.*)$/) {
2468                    $retVal = $1;
2469                } else {
2470                    Trace("Phone attempt failed with $rstring") if T(1);
2471                }
2472            }
2473        }
2474        # Return the result.
2475        return $retVal;
2476    }
2477    
2478    =head3 CommaFormat
2479    
2480    C<< my $formatted = Tracer::CommaFormat($number); >>
2481    
2482    Insert commas into a number.
2483    
2484    =over 4
2485    
2486    =item number
2487    
2488    A sequence of digits.
2489    
2490    =item RETURN
2491    
2492    Returns the same digits with commas strategically inserted.
2493    
2494    =back
2495    
2496    =cut
2497    
2498    sub CommaFormat {
2499        # Get the parameters.
2500        my ($number) = @_;
2501        # Pad the length up to a multiple of three.
2502        my $padded = "$number";
2503        $padded = " " . $padded while length($padded) % 3 != 0;
2504        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2505        # cause the delimiters to be included in the output stream. The
2506        # GREP removes the empty strings in between the delimiters.
2507        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2508        # Clean out the spaces.
2509        $retVal =~ s/ //g;
2510        # Return the result.
2511        return $retVal;
2512    }
2513    =head3 SetPermissions
2514    
2515    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2516    
2517    Set the permissions for a directory and all the files and folders inside it.
2518    In addition, the group ownership will be changed to the specified value.
2519    
2520    This method is more vulnerable than most to permission and compatability
2521    problems, so it does internal error recovery.
2522    
2523    =over 4
2524    
2525    =item dirName
2526    
2527    Name of the directory to process.
2528    
2529    =item group
2530    
2531    Name of the group to be assigned.
2532    
2533    =item mask
2534    
2535    Permission mask. Bits that are C<1> in this mask will be ORed into the
2536    permission bits of any file or directory that does not already have them
2537    set to 1.
2538    
2539    =item otherMasks
2540    
2541    Map of search patterns to permission masks. If a directory name matches
2542    one of the patterns, that directory and all its members and subdirectories
2543    will be assigned the new pattern. For example, the following would
2544    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2545    
2546        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2547    
2548    The list is ordered, so the following would use 0777 for C<tmp1> and
2549    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2550    
2551        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2552                                                       '^tmp' => 0666);
2553    
2554    Note that the pattern matches are all case-insensitive, and only directory
2555    names are matched, not file names.
2556    
2557    =back
2558    
2559    =cut
2560    
2561    sub SetPermissions {
2562        # Get the parameters.
2563        my ($dirName, $group, $mask, @otherMasks) = @_;
2564        # Set up for error recovery.
2565        eval {
2566            # Switch to the specified directory.
2567            ChDir($dirName);
2568            # Get the group ID.
2569            my $gid = getgrnam($group);
2570            # Get the mask for tracing.
2571            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2572            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2573            my $fixCount = 0;
2574            my $lookCount = 0;
2575            # @dirs will be a stack of directories to be processed.
2576            my @dirs = (getcwd());
2577            while (scalar(@dirs) > 0) {
2578                # Get the current directory.
2579                my $dir = pop @dirs;
2580                # Check for a match to one of the specified directory names. To do
2581                # that, we need to pull the individual part of the name off of the
2582                # whole path.
2583                my $simpleName = $dir;
2584                if ($dir =~ m!/([^/]+)$!) {
2585                    $simpleName = $1;
2586                }
2587                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2588                # Search for a match.
2589                my $match = 0;
2590                my $i;
2591                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2592                    my $pattern = $otherMasks[$i];
2593                    if ($simpleName =~ /$pattern/i) {
2594                        $match = 1;
2595                    }
2596                }
2597                # Check for a match. Note we use $i-1 because the loop added 2
2598                # before terminating due to the match.
2599                if ($match && $otherMasks[$i-1] != $mask) {
2600                    # This directory matches one of the incoming patterns, and it's
2601                    # a different mask, so we process it recursively with that mask.
2602                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2603                } else {
2604                    # Here we can process normally. Get all of the non-hidden members.
2605                    my @submems = OpenDir($dir, 1);
2606                    for my $submem (@submems) {
2607                        # Get the full name.
2608                        my $thisMem = "$dir/$submem";
2609                        Trace("Checking member $thisMem.") if T(4);
2610                        $lookCount++;
2611                        if ($lookCount % 1000 == 0) {
2612                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2613                        }
2614                        # Fix the group.
2615                        chown -1, $gid, $thisMem;
2616                        # Insure this member is not a symlink.
2617                        if (! -l $thisMem) {
2618                            # Get its info.
2619                            my $fileInfo = stat $thisMem;
2620                            # Only proceed if we got the info. Otherwise, it's a hard link
2621                            # and we want to skip it anyway.
2622                            if ($fileInfo) {
2623                                my $fileMode = $fileInfo->mode;
2624                                if (($fileMode & $mask) != $mask) {
2625                                    # Fix this member.
2626                                    $fileMode |= $mask;
2627                                    chmod $fileMode, $thisMem;
2628                                    $fixCount++;
2629                                }
2630                                # If it's a subdirectory, stack it.
2631                                if (-d $thisMem) {
2632                                    push @dirs, $thisMem;
2633                                }
2634                            }
2635                        }
2636                    }
2637                }
2638            }
2639            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2640        };
2641        # Check for an error.
2642        if ($@) {
2643            Confess("SetPermissions error: $@");
2644        }
2645    }
2646    
2647    =head3 CompareLists
2648    
2649    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2650    
2651    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2652    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2653    The return value contains a list of items that are only in the new list
2654    (inserted) and only in the old list (deleted).
2655    
2656    =over 4
2657    
2658    =item newList
2659    
2660    Reference to a list of new tuples.
2661    
2662    =item oldList
2663    
2664    Reference to a list of old tuples.
2665    
2666    =item keyIndex (optional)
2667    
2668    Index into each tuple of its key field. The default is 0.
2669    
2670    =item RETURN
2671    
2672    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2673    list (inserted) followed by a reference to the list of items that are only in the old
2674    list (deleted).
2675    
2676    =back
2677    
2678    =cut
2679    
2680    sub CompareLists {
2681        # Get the parameters.
2682        my ($newList, $oldList, $keyIndex) = @_;
2683        if (! defined $keyIndex) {
2684            $keyIndex = 0;
2685        }
2686        # Declare the return variables.
2687        my ($inserted, $deleted) = ([], []);
2688        # Loop through the two lists simultaneously.
2689        my ($newI, $oldI) = (0, 0);
2690        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2691        while ($newI < $newN || $oldI < $oldN) {
2692            # Get the current object in each list. Note that if one
2693            # of the lists is past the end, we'll get undef.
2694            my $newItem = $newList->[$newI];
2695            my $oldItem = $oldList->[$oldI];
2696            if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2697                # The old item is not in the new list, so mark it deleted.
2698                push @{$deleted}, $oldItem;
2699                $oldI++;
2700            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2701                # The new item is not in the old list, so mark it inserted.
2702                push @{$inserted}, $newItem;
2703                $newI++;
2704            } else {
2705                # The item is in both lists, so push forward.
2706                $oldI++;
2707                $newI++;
2708            }
2709        }
2710        # Return the result.
2711        return ($inserted, $deleted);
2712    }
2713    
2714    =head3 GetLine
2715    
2716    C<< my @data = Tracer::GetLine($handle); >>
2717    
2718    Read a line of data from a tab-delimited file.
2719    
2720    =over 4
2721    
2722    =item handle
2723    
2724    Open file handle from which to read.
2725    
2726    =item RETURN
2727    
2728    Returns a list of the fields in the record read. The fields are presumed to be
2729    tab-delimited. If we are at the end of the file, then an empty list will be
2730    returned. If an empty line is read, a single list item consisting of a null
2731    string will be returned.
2732    
2733    =back
2734    
2735    =cut
2736    
2737    sub GetLine {
2738        # Get the parameters.
2739        my ($handle) = @_;
2740        # Declare the return variable.
2741        my @retVal = ();
2742        # Read from the file.
2743        my $line = <$handle>;
2744        # Only proceed if we found something.
2745        if (defined $line) {
2746            # Remove the new-line.
2747            chomp $line;
2748            # If the line is empty, return a single empty string; otherwise, parse
2749            # it into fields.
2750            if ($line eq "") {
2751                push @retVal, "";
2752            } else {
2753                push @retVal, split /\t/,$line;
2754            }
2755        }
2756        # Return the result.
2757        return @retVal;
2758    }
2759    
2760    =head3 PutLine
2761    
2762    C<< Tracer::PutLine($handle, \@fields); >>
2763    
2764    Write a line of data to a tab-delimited file. The specified field values will be
2765    output in tab-separated form, with a trailing new-line.
2766    
2767    =over 4
2768    
2769    =item handle
2770    
2771    Output file handle.
2772    
2773    =item fields
2774    
2775    List of field values.
2776    
2777    =back
2778    
2779    =cut
2780    
2781    sub PutLine {
2782        # Get the parameters.
2783        my ($handle, $fields) = @_;
2784        # Write the data.
2785        print $handle join("\t", @{$fields}) . "\n";
2786    }
2787    
2788    =head3 GenerateURL
2789    
2790    C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >>
2791    
2792    Generate a GET-style URL for the specified page with the specified parameter
2793    names and values. The values will be URL-escaped automatically. So, for
2794    example
2795    
2796        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
2797    
2798    would return
2799    
2800        form.cgi?type=1&string=%22high%20pass%22%20or%20highway
2801    
2802    =over 4
2803    
2804    =item page
2805    
2806    Page URL.
2807    
2808    =item parameters
2809    
2810    Hash mapping parameter names to parameter values.
2811    
2812    =item RETURN
2813    
2814    Returns a GET-style URL that goes to the specified page and passes in the
2815    specified parameters and values.
2816    
2817    =back
2818    
2819    =cut
2820    
2821    sub GenerateURL {
2822        # Get the parameters.
2823        my ($page, %parameters) = @_;
2824        # Prime the return variable with the page URL.
2825        my $retVal = $page;
2826        # Loop through the parameters, creating parameter elements in a list.
2827        my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
2828        # If the list is nonempty, tack it on.
2829        if (@parmList) {
2830            $retVal .= "?" . join("&", @parmList);
2831      }      }
2832        # Return the result.
2833        return $retVal;
2834  }  }
2835    
2836  1;  1;

Legend:
Removed from v.1.39  
changed lines
  Added in v.1.70

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3