[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.45, Mon May 8 20:37:02 2006 UTC revision 1.71, Mon Oct 2 06:34:57 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 ChDir);      @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 303  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 442  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 joining the categories.      # Next, we create the category string by joining the categories.
454      my $cats = join(" ", @cats);      my $cats = join(" ", @cats);
455      # Check to determine whether or not the caller wants to turn off tracing      # Check to determine whether or not the caller wants to turn off tracing
# Line 481  Line 488 
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 964  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 1346  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 1379  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 1404  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 1604  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 1619  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 1629  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 1642  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 1663  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 1817  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                # Insure Tracer is specified.
1992                my %moduleHash = map { $_ => 1 } @tracing;
1993                $moduleHash{Tracer} = 1;
1994                # Set the trace parameter.
1995                $tracing = join(" ", $level, sort keys %moduleHash);
1996                # Make sure the script knows tracing is on.
1997                $cgi->param(-name => 'Trace', -value => $tracing);
1998                $cgi->param(-name => 'TF', -value => (($dest =~ /^>/) ? 1 : 0));
1999            }
2000        } elsif ($cgi->param('Trace')) {
2001            # Here the user has requested tracing via a form.
2002            $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
2003            $tracing = $cgi->param('Trace') . " Tracer";
2004        }
2005        # Setup the tracing we've determined from all the stuff above.
2006        TSetup($tracing, $dest);
2007          # Trace the parameter and environment data.          # Trace the parameter and environment data.
2008        TraceParms($cgi);
2009    }
2010    
2011    =head3 EmergencyFileName
2012    
2013    C<< my $fileName = Tracer::EmergencyFileName($ip); >>
2014    
2015    Return the emergency tracing file name. This is the file that specifies
2016    the tracing information.
2017    
2018    =over 4
2019    
2020    =item ip
2021    
2022    IP address of the user who wants tracing, as taken from the C<< $cgi->remote_host() >>
2023    method.
2024    
2025    =item RETURN
2026    
2027    Returns the name of the file to contain the emergency tracing information.
2028    
2029    =back
2030    
2031    =cut
2032    
2033    sub EmergencyFileName {
2034        # Get the parameters.
2035        my ($ip) = @_;
2036        # Compute the emergency tracing file name.
2037        return "$FIG_Config::temp/Emergency$ip.txt";
2038    }
2039    
2040    =head3 EmergencyFileTarget
2041    
2042    C<< my $fileName = Tracer::EmergencyFileTarget($ip); >>
2043    
2044    Return the emergency tracing target file name. This is the file that receives
2045    the tracing output for file-based tracing.
2046    
2047    =over 4
2048    
2049    =item ip
2050    
2051    IP address of the user who wants tracing, as taken from the C<< $cgi->remote_host() >>
2052    method.
2053    
2054    =item RETURN
2055    
2056    Returns the name of the file to contain the emergency tracing information.
2057    
2058    =back
2059    
2060    =cut
2061    
2062    sub EmergencyFileTarget {
2063        # Get the parameters.
2064        my ($ip) = @_;
2065        # Compute the emergency tracing file name.
2066        return "$FIG_Config::temp/Emergency$ip.log";
2067    }
2068    
2069    =head3 EmergencyTracingDest
2070    
2071    C<< my $dest = Tracer::EmergencyTracingDest($ip, $myDest); >>
2072    
2073    This method converts an emergency tracing destination to a real
2074    tracing destination. The main difference is that if the
2075    destination is C<FILE> or C<APPEND>, we convert it to file
2076    output.
2077    
2078    =over 4
2079    
2080    =item ip
2081    
2082    IP address of the user who wants tracing, as taken from the C<< $cgi->remote_host() >>
2083    method.
2084    
2085    =item myDest
2086    
2087    Destination from the emergency tracing file.
2088    
2089    =item RETURN
2090    
2091    Returns a destination that can be passed into L</TSetup>.
2092    
2093    =back
2094    
2095    =cut
2096    
2097    sub EmergencyTracingDest {
2098        # Get the parameters.
2099        my ($ip, $myDest) = @_;
2100        # Declare the return variable.
2101        my $retVal;
2102        # Process according to the destination value.
2103        if ($myDest eq 'FILE') {
2104            $retVal = ">" . EmergencyFileTarget($ip);
2105        } elsif ($myDest eq 'APPEND') {
2106            $retVal = ">>" . EmergencyFileTarget($ip);
2107        } else {
2108            $retVal = $myDest;
2109        }
2110        # Return the result.
2111        return $retVal;
2112    }
2113    
2114    =head3 Emergency
2115    
2116    C<< Emergency($cgi, $hours, $dest, $level, @modules); >>
2117    
2118    Turn on emergency tracing. This method can only be invoked over the web and is
2119    should not be called if debug mode is off. The caller specifies the duration of the
2120    emergency in hours, the desired tracing destination, the trace level,
2121    and a list of the trace modules to activate. For the duration, when a user
2122    from the specified remote web location invokes a Sprout CGI script, tracing
2123    will be turned on automatically. See L</TSetup> for more about tracing
2124    setup and L</ScriptSetup> for more about emergency tracing.
2125    
2126    =over 4
2127    
2128    =item cgi
2129    
2130    A CGI query object.
2131    
2132    =item hours
2133    
2134    Number of hours to keep emergency tracing alive.
2135    
2136    =item dest
2137    
2138    Tracing destination. If no path information is specified for a file
2139    destination, it is put in the FIG temporary directory.
2140    
2141    =item level
2142    
2143    Tracing level. A higher level means more trace messages.
2144    
2145    =item modules
2146    
2147    A list of the tracing modules to activate.
2148    
2149    =back
2150    
2151    =cut
2152    
2153    sub Emergency {
2154        # Get the parameters.
2155        my ($cgi, $hours, $dest, $level, @modules) = @_;
2156        # Get the IP address.
2157        my $ip = EmergencyIP($cgi);
2158        # Create the emergency file.
2159        my $specFile = EmergencyFileName($ip);
2160        my $outHandle = Open(undef, ">$specFile");
2161        print $outHandle join("\n", $hours, $dest, $level, @modules, "");
2162    }
2163    
2164    =head3 EmergencyIP
2165    
2166    C<< my $ip = EmergencyIP($cgi); >>
2167    
2168    Return the IP address to be used for emergency tracing. In actual fact, this is not an
2169    IP address but a session ID stored in a cookie. It used to be an IP address, but those
2170    are too fluid.
2171    
2172    =over 4
2173    
2174    =item cgi
2175    
2176    CGI query object.
2177    
2178    =item RETURN
2179    
2180    Returns the IP address to be used for labelling emergency tracing.
2181    
2182    =back
2183    
2184    =cut
2185    
2186    sub EmergencyIP {
2187        # Get the parameters.
2188        my ($cgi) = @_;
2189        # Look for a cookie.
2190        my $retVal = $cgi->cookie('IP');
2191        # If no cookie, return the remote host address. This will probably not
2192        # work, but that's okay, since the lack of a cookie means the
2193        # tracing is not turned on.
2194        $retVal = $cgi->remote_host() if ! $retVal;
2195        # Return the result.
2196        return $retVal;
2197    }
2198    
2199    
2200    =head3 TraceParms
2201    
2202    C<< Tracer::TraceParms($cgi); >>
2203    
2204    Trace the CGI parameters at trace level CGI => 3 and the environment variables
2205    at level CGI => 4.
2206    
2207    =over 4
2208    
2209    =item cgi
2210    
2211    CGI query object containing the parameters to trace.
2212    
2213    =back
2214    
2215    =cut
2216    
2217    sub TraceParms {
2218        # Get the parameters.
2219        my ($cgi) = @_;
2220          if (T(CGI => 3)) {          if (T(CGI => 3)) {
2221              # Here we want to trace the parameter data.              # Here we want to trace the parameter data.
2222              my @names = $query->param;          my @names = $cgi->param;
2223              for my $parmName (sort @names) {              for my $parmName (sort @names) {
2224                  # Note we skip "Trace", which is for our use only.              # Note we skip the Trace parameters, which are for our use only.
2225                  if ($parmName ne 'Trace') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
2226                      my @values = $query->param($parmName);                  my @values = $cgi->param($parmName);
2227                      Trace("CGI: $parmName = " . join(", ", @values));                      Trace("CGI: $parmName = " . join(", ", @values));
2228                  }                  }
2229              }              }
2230            # Display the request method.
2231            my $method = $cgi->request_method();
2232            Trace("Method: $method");
2233          }          }
2234          if (T(CGI => 4)) {          if (T(CGI => 4)) {
2235              # Here we want the environment data too.              # Here we want the environment data too.
# Line 1855  Line 2237 
2237                  Trace("ENV: $envName = $ENV{$envName}");                  Trace("ENV: $envName = $ENV{$envName}");
2238              }              }
2239          }          }
     } 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);  
2240  }  }
2241    
2242  =head3 ScriptFinish  =head3 ScriptFinish
# Line 1894  Line 2263 
2263      use FIG;      use FIG;
2264      # ... more uses ...      # ... more uses ...
2265    
2266      my ($query, $varHash) = ScriptSetup();      my ($cgi, $varHash) = ScriptSetup();
2267      eval {      eval {
2268          # ... get data from $query, put it in $varHash ...          # ... get data from $cgi, put it in $varHash ...
2269      };      };
2270      if ($@) {      if ($@) {
2271          Trace("Script Error: $@") if T(0);          Trace("Script Error: $@") if T(0);
# Line 1931  Line 2300 
2300      # Check for a template file situation.      # Check for a template file situation.
2301      my $outputString;      my $outputString;
2302      if (defined $varHash) {      if (defined $varHash) {
2303          # 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.
2304          $outputString = PageBuilder::Build("<$webData", $varHash, "Html");          my $template;
2305            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
2306                $template = "$FIG_Config::template_url/$webData";
2307            } else {
2308                $template = "<<$webData";
2309            }
2310            $outputString = PageBuilder::Build($template, $varHash, "Html");
2311      } else {      } else {
2312          # Here the user gave us a raw string.          # Here the user gave us a raw string.
2313          $outputString = $webData;          $outputString = $webData;
2314      }      }
2315      # Check for trace messages.      # Check for trace messages.
2316      if ($Destination eq "QUEUE") {      if ($Destination ne "NONE" && $TraceLevel > 0) {
2317          # 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
2318          # 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
2319          # end-tag.          # end-tag.
# Line 1946  Line 2321 
2321          if ($outputString =~ m#</body>#gi) {          if ($outputString =~ m#</body>#gi) {
2322              $pos = (pos $outputString) - 7;              $pos = (pos $outputString) - 7;
2323          }          }
2324          substr $outputString, $pos, 0, QTrace('Html');          # If the trace messages were queued, we unroll them. Otherwise, we display the
2325            # destination.
2326            my $traceHtml;
2327            if ($Destination eq "QUEUE") {
2328                $traceHtml = QTrace('Html');
2329            } elsif ($Destination =~ /^>>(.+)$/) {
2330                # Here the tracing output it to a file. We code it as a hyperlink so the user
2331                # can copy the file name into the clipboard easily.
2332                my $actualDest = $1;
2333                $traceHtml = "<p>Tracing output to <a href=\"$actualDest\">$actualDest</a>.</p>\n";
2334            } else {
2335                # Here we have one of the special destinations.
2336                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
2337            }
2338            substr $outputString, $pos, 0, $traceHtml;
2339      }      }
2340      # Write the output string.      # Write the output string.
2341      print $outputString;      print $outputString;
# Line 2008  Line 2397 
2397      }      }
2398  }  }
2399    
2400    =head3 SendSMS
2401    
2402    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2403    
2404    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2405    user name, password, and API ID for the relevant account in the hash reference variable
2406    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2407    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2408    is C<2561022>, then the FIG_Config file must contain
2409    
2410        $phone =  { user => 'BruceTheHumanPet',
2411                    password => 'silly',
2412                    api_id => '2561022' };
2413    
2414    The original purpose of this method was to insure Bruce would be notified immediately when the
2415    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2416    when you call this method.
2417    
2418    The message ID will be returned if successful, and C<undef> if an error occurs.
2419    
2420    =over 4
2421    
2422    =item phoneNumber
2423    
2424    Phone number to receive the message, in international format. A United States phone number
2425    would be prefixed by "1". A British phone number would be prefixed by "44".
2426    
2427    =item msg
2428    
2429    Message to send to the specified phone.
2430    
2431    =item RETURN
2432    
2433    Returns the message ID if successful, and C<undef> if the message could not be sent.
2434    
2435    =back
2436    
2437    =cut
2438    
2439    sub SendSMS {
2440        # Get the parameters.
2441        my ($phoneNumber, $msg) = @_;
2442        # Declare the return variable. If we do not change it, C<undef> will be returned.
2443        my $retVal;
2444        # Only proceed if we have phone support.
2445        if (! defined $FIG_Config::phone) {
2446            Trace("Phone support not present in FIG_Config.") if T(1);
2447        } else {
2448            # Get the phone data.
2449            my $parms = $FIG_Config::phone;
2450            # Get the Clickatell URL.
2451            my $url = "http://api.clickatell.com/http/";
2452            # Create the user agent.
2453            my $ua = LWP::UserAgent->new;
2454            # Request a Clickatell session.
2455            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2456                                         password => $parms->{password},
2457                                         api_id => $parms->{api_id},
2458                                         to => $phoneNumber,
2459                                         text => $msg});
2460            # Check for an error.
2461            if (! $resp->is_success) {
2462                Trace("Alert failed.") if T(1);
2463            } else {
2464                # Get the message ID.
2465                my $rstring = $resp->content;
2466                if ($rstring =~ /^ID:\s+(.*)$/) {
2467                    $retVal = $1;
2468                } else {
2469                    Trace("Phone attempt failed with $rstring") if T(1);
2470                }
2471            }
2472        }
2473        # Return the result.
2474        return $retVal;
2475    }
2476    
2477    =head3 CommaFormat
2478    
2479    C<< my $formatted = Tracer::CommaFormat($number); >>
2480    
2481    Insert commas into a number.
2482    
2483    =over 4
2484    
2485    =item number
2486    
2487    A sequence of digits.
2488    
2489    =item RETURN
2490    
2491    Returns the same digits with commas strategically inserted.
2492    
2493    =back
2494    
2495    =cut
2496    
2497    sub CommaFormat {
2498        # Get the parameters.
2499        my ($number) = @_;
2500        # Pad the length up to a multiple of three.
2501        my $padded = "$number";
2502        $padded = " " . $padded while length($padded) % 3 != 0;
2503        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2504        # cause the delimiters to be included in the output stream. The
2505        # GREP removes the empty strings in between the delimiters.
2506        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2507        # Clean out the spaces.
2508        $retVal =~ s/ //g;
2509        # Return the result.
2510        return $retVal;
2511    }
2512    =head3 SetPermissions
2513    
2514    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2515    
2516    Set the permissions for a directory and all the files and folders inside it.
2517    In addition, the group ownership will be changed to the specified value.
2518    
2519    This method is more vulnerable than most to permission and compatability
2520    problems, so it does internal error recovery.
2521    
2522    =over 4
2523    
2524    =item dirName
2525    
2526    Name of the directory to process.
2527    
2528    =item group
2529    
2530    Name of the group to be assigned.
2531    
2532    =item mask
2533    
2534    Permission mask. Bits that are C<1> in this mask will be ORed into the
2535    permission bits of any file or directory that does not already have them
2536    set to 1.
2537    
2538    =item otherMasks
2539    
2540    Map of search patterns to permission masks. If a directory name matches
2541    one of the patterns, that directory and all its members and subdirectories
2542    will be assigned the new pattern. For example, the following would
2543    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2544    
2545        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2546    
2547    The list is ordered, so the following would use 0777 for C<tmp1> and
2548    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2549    
2550        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2551                                                       '^tmp' => 0666);
2552    
2553    Note that the pattern matches are all case-insensitive, and only directory
2554    names are matched, not file names.
2555    
2556    =back
2557    
2558    =cut
2559    
2560    sub SetPermissions {
2561        # Get the parameters.
2562        my ($dirName, $group, $mask, @otherMasks) = @_;
2563        # Set up for error recovery.
2564        eval {
2565            # Switch to the specified directory.
2566            ChDir($dirName);
2567            # Get the group ID.
2568            my $gid = getgrnam($group);
2569            # Get the mask for tracing.
2570            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2571            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2572            my $fixCount = 0;
2573            my $lookCount = 0;
2574            # @dirs will be a stack of directories to be processed.
2575            my @dirs = (getcwd());
2576            while (scalar(@dirs) > 0) {
2577                # Get the current directory.
2578                my $dir = pop @dirs;
2579                # Check for a match to one of the specified directory names. To do
2580                # that, we need to pull the individual part of the name off of the
2581                # whole path.
2582                my $simpleName = $dir;
2583                if ($dir =~ m!/([^/]+)$!) {
2584                    $simpleName = $1;
2585                }
2586                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2587                # Search for a match.
2588                my $match = 0;
2589                my $i;
2590                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2591                    my $pattern = $otherMasks[$i];
2592                    if ($simpleName =~ /$pattern/i) {
2593                        $match = 1;
2594                    }
2595                }
2596                # Check for a match. Note we use $i-1 because the loop added 2
2597                # before terminating due to the match.
2598                if ($match && $otherMasks[$i-1] != $mask) {
2599                    # This directory matches one of the incoming patterns, and it's
2600                    # a different mask, so we process it recursively with that mask.
2601                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2602                } else {
2603                    # Here we can process normally. Get all of the non-hidden members.
2604                    my @submems = OpenDir($dir, 1);
2605                    for my $submem (@submems) {
2606                        # Get the full name.
2607                        my $thisMem = "$dir/$submem";
2608                        Trace("Checking member $thisMem.") if T(4);
2609                        $lookCount++;
2610                        if ($lookCount % 1000 == 0) {
2611                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2612                        }
2613                        # Fix the group.
2614                        chown -1, $gid, $thisMem;
2615                        # Insure this member is not a symlink.
2616                        if (! -l $thisMem) {
2617                            # Get its info.
2618                            my $fileInfo = stat $thisMem;
2619                            # Only proceed if we got the info. Otherwise, it's a hard link
2620                            # and we want to skip it anyway.
2621                            if ($fileInfo) {
2622                                my $fileMode = $fileInfo->mode;
2623                                if (($fileMode & $mask) != $mask) {
2624                                    # Fix this member.
2625                                    $fileMode |= $mask;
2626                                    chmod $fileMode, $thisMem;
2627                                    $fixCount++;
2628                                }
2629                                # If it's a subdirectory, stack it.
2630                                if (-d $thisMem) {
2631                                    push @dirs, $thisMem;
2632                                }
2633                            }
2634                        }
2635                    }
2636                }
2637            }
2638            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2639        };
2640        # Check for an error.
2641        if ($@) {
2642            Confess("SetPermissions error: $@");
2643        }
2644    }
2645    
2646    =head3 CompareLists
2647    
2648    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2649    
2650    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2651    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2652    The return value contains a list of items that are only in the new list
2653    (inserted) and only in the old list (deleted).
2654    
2655    =over 4
2656    
2657    =item newList
2658    
2659    Reference to a list of new tuples.
2660    
2661    =item oldList
2662    
2663    Reference to a list of old tuples.
2664    
2665    =item keyIndex (optional)
2666    
2667    Index into each tuple of its key field. The default is 0.
2668    
2669    =item RETURN
2670    
2671    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2672    list (inserted) followed by a reference to the list of items that are only in the old
2673    list (deleted).
2674    
2675    =back
2676    
2677    =cut
2678    
2679    sub CompareLists {
2680        # Get the parameters.
2681        my ($newList, $oldList, $keyIndex) = @_;
2682        if (! defined $keyIndex) {
2683            $keyIndex = 0;
2684        }
2685        # Declare the return variables.
2686        my ($inserted, $deleted) = ([], []);
2687        # Loop through the two lists simultaneously.
2688        my ($newI, $oldI) = (0, 0);
2689        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2690        while ($newI < $newN || $oldI < $oldN) {
2691            # Get the current object in each list. Note that if one
2692            # of the lists is past the end, we'll get undef.
2693            my $newItem = $newList->[$newI];
2694            my $oldItem = $oldList->[$oldI];
2695            if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2696                # The old item is not in the new list, so mark it deleted.
2697                push @{$deleted}, $oldItem;
2698                $oldI++;
2699            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2700                # The new item is not in the old list, so mark it inserted.
2701                push @{$inserted}, $newItem;
2702                $newI++;
2703            } else {
2704                # The item is in both lists, so push forward.
2705                $oldI++;
2706                $newI++;
2707            }
2708        }
2709        # Return the result.
2710        return ($inserted, $deleted);
2711    }
2712    
2713    =head3 GetLine
2714    
2715    C<< my @data = Tracer::GetLine($handle); >>
2716    
2717    Read a line of data from a tab-delimited file.
2718    
2719    =over 4
2720    
2721    =item handle
2722    
2723    Open file handle from which to read.
2724    
2725    =item RETURN
2726    
2727    Returns a list of the fields in the record read. The fields are presumed to be
2728    tab-delimited. If we are at the end of the file, then an empty list will be
2729    returned. If an empty line is read, a single list item consisting of a null
2730    string will be returned.
2731    
2732    =back
2733    
2734    =cut
2735    
2736    sub GetLine {
2737        # Get the parameters.
2738        my ($handle) = @_;
2739        # Declare the return variable.
2740        my @retVal = ();
2741        # Read from the file.
2742        my $line = <$handle>;
2743        # Only proceed if we found something.
2744        if (defined $line) {
2745            # Remove the new-line.
2746            chomp $line;
2747            # If the line is empty, return a single empty string; otherwise, parse
2748            # it into fields.
2749            if ($line eq "") {
2750                push @retVal, "";
2751            } else {
2752                push @retVal, split /\t/,$line;
2753            }
2754        }
2755        # Return the result.
2756        return @retVal;
2757    }
2758    
2759    =head3 PutLine
2760    
2761    C<< Tracer::PutLine($handle, \@fields); >>
2762    
2763    Write a line of data to a tab-delimited file. The specified field values will be
2764    output in tab-separated form, with a trailing new-line.
2765    
2766    =over 4
2767    
2768    =item handle
2769    
2770    Output file handle.
2771    
2772    =item fields
2773    
2774    List of field values.
2775    
2776    =back
2777    
2778    =cut
2779    
2780    sub PutLine {
2781        # Get the parameters.
2782        my ($handle, $fields) = @_;
2783        # Write the data.
2784        print $handle join("\t", @{$fields}) . "\n";
2785    }
2786    
2787    =head3 GenerateURL
2788    
2789    C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >>
2790    
2791    Generate a GET-style URL for the specified page with the specified parameter
2792    names and values. The values will be URL-escaped automatically. So, for
2793    example
2794    
2795        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
2796    
2797    would return
2798    
2799        form.cgi?type=1&string=%22high%20pass%22%20or%20highway
2800    
2801    =over 4
2802    
2803    =item page
2804    
2805    Page URL.
2806    
2807    =item parameters
2808    
2809    Hash mapping parameter names to parameter values.
2810    
2811    =item RETURN
2812    
2813    Returns a GET-style URL that goes to the specified page and passes in the
2814    specified parameters and values.
2815    
2816    =back
2817    
2818    =cut
2819    
2820    sub GenerateURL {
2821        # Get the parameters.
2822        my ($page, %parameters) = @_;
2823        # Prime the return variable with the page URL.
2824        my $retVal = $page;
2825        # Loop through the parameters, creating parameter elements in a list.
2826        my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
2827        # If the list is nonempty, tack it on.
2828        if (@parmList) {
2829            $retVal .= "?" . join("&", @parmList);
2830        }
2831        # Return the result.
2832        return $retVal;
2833    }
2834    
2835  1;  1;

Legend:
Removed from v.1.45  
changed lines
  Added in v.1.71

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3