[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.67, Fri Sep 29 15:00:17 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 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);
# Line 121  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 200  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 233  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 308  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 447  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 486  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 969  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 1720  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 1741  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 1895  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.      # Create the variable hash.
1941          my $ttype = ($query->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");      my $varHash = { results => '' };
1942          TSetup($query->param('Trace') . " FIG Tracer", $ttype);      # 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($query);      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 {      } else {
2109          # Here tracing is to be turned off. All we allow is errors traced into the          $retVal = $myDest;
         # error log.  
         TSetup("0", "WARN");  
2110      }      }
2111      # Create the variable hash.      # Return the result.
2112      my $varHash = { DebugData => '' };      return $retVal;
     # Return the query object and variable hash.  
     return ($query, $varHash);  
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  =head3 TraceParms
2202    
2203  C<< Tracer::TraceParms($query); >>  C<< Tracer::TraceParms($cgi); >>
2204    
2205  Trace the CGI parameters at trace level CGI => 3 and the environment variables  Trace the CGI parameters at trace level CGI => 3 and the environment variables
2206  at level CGI => 4.  at level CGI => 4.
2207    
2208  =over 4  =over 4
2209    
2210  =item query  =item cgi
2211    
2212  CGI query object containing the parameters to trace.  CGI query object containing the parameters to trace.
2213    
# Line 1948  Line 2217 
2217    
2218  sub TraceParms {  sub TraceParms {
2219      # Get the parameters.      # Get the parameters.
2220      my ($query) = @_;      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          }          }
         # Now output a GET-style URL for this query.  
         my $getURL = $query->url(-relative => 1, -query => 1);  
         # Strip out the Trace parameters.  
         $getURL =~ s/Trace=\d[^;&]+[;&]//;  
         $getURL =~ s/TF=\d[;&]//;  
         # Output the URL.  
         Trace("URL: ../FIG/$getURL");  
2231          # Display the request method.          # Display the request method.
2232          my $method = $query->request_method();          my $method = $cgi->request_method();
2233          Trace("Method: $method");          Trace("Method: $method");
2234      }      }
2235      if (T(CGI => 4)) {      if (T(CGI => 4)) {
# Line 2002  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 2052  Line 2314 
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 2060  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;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3