[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.75, Fri Oct 6 00:41:44 2006 UTC revision 1.84, Thu May 3 12:28:00 2007 UTC
# Line 186  Line 186 
186  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing
187  will be configured automatically.  will be configured automatically.
188    
189    NOTE: to configure emergency tracing from the command line instead of the Debugging
190    Control Panel (see below), use the C<trace.pl> script.
191    
192  =head3 Debugging Control Panel  =head3 Debugging Control Panel
193    
194  The debugging control panel provides several tools to assist in development of  The debugging control panel provides several tools to assist in development of
# Line 445  Line 448 
448                            noAlias => [0, "do not expect aliases in CHANGE transactions"],                            noAlias => [0, "do not expect aliases in CHANGE transactions"],
449                            start => [' ', "start with this genome"],                            start => [' ', "start with this genome"],
450                            tblFiles => [0, "output TBL files containing the corrected IDs"] },                            tblFiles => [0, "output TBL files containing the corrected IDs"] },
451                          "command transactionDirectory IDfile",                          "<command> <transactionDirectory> <IDfile>",
452                        @ARGV);                        @ARGV);
453    
454    
# Line 457  Line 460 
460    
461      TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl      TransactFeatures -trace=2 -noAlias register ../xacts IDs.tbl
462    
463    Single and double hyphens are equivalent. So, you could also code the
464    above command as
465    
466        TransactFeatures --trace=2 --noAlias register ../xacts IDs.tbl
467    
468  In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional  In this case, C<register>, C<../xacts>, and C<IDs.tbl> are the positional
469  parameters, and would find themselves in I<@parameters> after executing the  parameters, and would find themselves in I<@parameters> after executing the
470  above code fragment. The tracing would be set to level 2, and the categories  above code fragment. The tracing would be set to level 2, and the categories
# Line 491  Line 499 
499  the tracing key is taken from the C<Tracing> environment variable. If there  the tracing key is taken from the C<Tracing> environment variable. If there
500  is no value for that variable, the tracing key will be computed from the PID.  is no value for that variable, the tracing key will be computed from the PID.
501    
502  Finally, if the special option C<-h> is specified, the option names will  Finally, if the special option C<-help> is specified, the option
503  be traced at level 0 and the program will exit without processing.  names will be traced at level 0 and the program will exit without processing.
504  This provides a limited help capability. For example, if the user enters  This provides a limited help capability. For example, if the user enters
505    
506      TransactFeatures -h      TransactFeatures -help
507    
508  he would see the following output.  he would see the following output.
509    
510      TransactFeatures [options] command transactionDirectory IDfile      TransactFeatures [options] <command> <transactionDirectory> <IDfile>
511          -trace    tracing level (default E)          -trace    tracing level (default E)
512          -sql      trace SQL commands          -sql      trace SQL commands
513          -safe     use database transactions          -safe     use database transactions
# Line 574  Line 582 
582          $options->{trace} = ['E', "tracing level (E for emergency tracing)"];          $options->{trace} = ['E', "tracing level (E for emergency tracing)"];
583      }      }
584      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
585      $options->{h} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
586      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
587      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
588      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
# Line 649  Line 657 
657      }      }
658      # 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
659      # options and exit the program.      # options and exit the program.
660      if ($retOptions->{h}) {      if ($retOptions->{help}) {
661          $0 =~ m#[/\\](\w+)(\.pl)?$#i;          $0 =~ m#[/\\](\w+)(\.pl)?$#i;
662          print "$1 [options] $parmHelp\n";          print "$1 [options] $parmHelp\n";
663          for my $key (sort keys %{$options}) {          for my $key (sort keys %{$options}) {
# Line 662  Line 670 
670          }          }
671          exit(0);          exit(0);
672      }      }
673        # Trace the options, if applicable.
674        if (T(3)) {
675            my @parms = grep { $retOptions->{$_} } keys %{$retOptions};
676            Trace("Selected options: " . join(", ", sort @parms) . ".");
677        }
678      # Return the parsed parameters.      # Return the parsed parameters.
679      return ($retOptions, @retParameters);      return ($retOptions, @retParameters);
680  }  }
# Line 950  Line 963 
963  Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if  Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if
964  the time string is invalid.  the time string is invalid.
965    
966    =back
967    
968  =cut  =cut
969    
970  sub ParseTraceDate {  sub ParseTraceDate {
# Line 959  Line 974 
974      my $retVal;      my $retVal;
975      # Parse the date.      # Parse the date.
976      if ($dateString =~ m#(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)#) {      if ($dateString =~ m#(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)#) {
977          # Create a time object.          # Create a time object. Note we need to convert the day, month,
978          $retVal = timelocal($6, $5, $4, $2, $1, $3);          # and year to a different base. Years count from 1900, and
979            # the internal month value is relocated to January = 0.
980            $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);
981      }      }
982      # Return the result.      # Return the result.
983      return $retVal;      return $retVal;
# Line 1277  Line 1294 
1294    
1295  C<< my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words); >>  C<< my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words); >>
1296    
1297  In this case, the list @words will be treated as a command line. There are two options available,  In this case, the list @words will be treated as a command line and there are two options available,
1298  B<errors> and B<logFile>. If @words has the following format  B<errors> and B<logFile>. If @words has the following format
1299    
1300  C<< -logFile=error.log apple orange rutabaga >>  C<< -logFile=error.log apple orange rutabaga >>
# Line 1291  Line 1308 
1308  C<< apple orange rutabaga >>  C<< apple orange rutabaga >>
1309    
1310  The parser allows for some escape sequences. See L</UnEscape> for a description. There is no  The parser allows for some escape sequences. See L</UnEscape> for a description. There is no
1311  support for quote characters.  support for quote characters. Options can be specified with single or double hyphens.
1312    
1313  =over 4  =over 4
1314    
# Line 1316  Line 1333 
1333      my ($optionTable, @inputList) = @_;      my ($optionTable, @inputList) = @_;
1334      # Process any options in the input list.      # Process any options in the input list.
1335      my %overrides = ();      my %overrides = ();
1336      while ((@inputList > 0) && ($inputList[0] =~ /^-/)) {      while ((@inputList > 0) && ($inputList[0] =~ /^--?/)) {
1337          # Get the current option.          # Get the current option.
1338          my $arg = shift @inputList;          my $arg = shift @inputList;
1339          # Pull out the option name.          # Pull out the option name.
1340          $arg =~ /^-([^=]*)/g;          $arg =~ /^--?([^=]*)/g;
1341          my $name = $1;          my $name = $1;
1342          # Check for an option value.          # Check for an option value.
1343          if ($arg =~ /\G=(.*)$/g) {          if ($arg =~ /\G=(.*)$/g) {
# Line 1633  Line 1650 
1650      # Close it.      # Close it.
1651      close $handle;      close $handle;
1652      my $actualLines = @retVal;      my $actualLines = @retVal;
1653        Trace("$actualLines lines read from file $fileName.") if T(File => 2);
1654      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1655      if (wantarray) {      if (wantarray) {
1656          return @retVal;          return @retVal;
# Line 1668  Line 1686 
1686      my ($fileName, $lines) = @_;      my ($fileName, $lines) = @_;
1687      # Open the output file.      # Open the output file.
1688      my $handle = Open(undef, ">$fileName");      my $handle = Open(undef, ">$fileName");
1689        # Count the lines written.
1690      if (ref $lines ne 'ARRAY') {      if (ref $lines ne 'ARRAY') {
1691          # Here we have a scalar, so we write it raw.          # Here we have a scalar, so we write it raw.
1692          print $handle $lines;          print $handle $lines;
1693            Trace("Scalar put to file $fileName.") if T(File => 3);
1694      } else {      } else {
1695          # Write the lines one at a time.          # Write the lines one at a time.
1696            my $count = 0;
1697          for my $line (@{$lines}) {          for my $line (@{$lines}) {
1698              print $handle "$line\n";              print $handle "$line\n";
1699                $count++;
1700          }          }
1701            Trace("$count lines put to file $fileName.") if T(File => 3);
1702      }      }
1703      # Close the output file.      # Close the output file.
1704      close $handle;      close $handle;
# Line 2094  Line 2117 
2117  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>
2118    
2119  Perform standard tracing and debugging setup for scripts. The value returned is  Perform standard tracing and debugging setup for scripts. The value returned is
2120  the CGI object followed by a pre-built variable hash.  the CGI object followed by a pre-built variable hash. At the end of the script,
2121    the client should call L</ScriptFinish> to output the web page.
2122    
2123  The C<Trace> form parameter is used to determine whether or not tracing is active and  This method calls L</ETracing> to configure tracing, which allows the tracing
2124  which trace modules (other than C<Tracer> itself) should be turned on. Specifying  to be configured via the emergency tracing form on the debugging control panel.
 the C<CGI> trace module will trace parameter and environment information. Parameters are  
 traced at level 3 and environment variables at level 4. To trace to a file instead of to  
 the web page, set C<TF> to 1. At the end of the script, the client should call  
 L</ScriptFinish> to output the web page.  
   
 In some situations, it is not practical to invoke tracing via form parameters. For this  
 situation, you can turn on emergency tracing from the debugging control panel.  
2125  Tracing will then be turned on automatically for all programs that use the L</ETracing>  Tracing will then be turned on automatically for all programs that use the L</ETracing>
2126  method, which includes every program that uses this method or L</StandardSetup>.  method, which includes every program that uses this method or L</StandardSetup>.
2127    
# Line 2281  Line 2298 
2298  This method converts an emergency tracing destination to a real  This method converts an emergency tracing destination to a real
2299  tracing destination. The main difference is that if the  tracing destination. The main difference is that if the
2300  destination is C<FILE> or C<APPEND>, we convert it to file  destination is C<FILE> or C<APPEND>, we convert it to file
2301  output.  output. If the destination is C<DUAL>, we convert it to file
2302    and standard output.
2303    
2304  =over 4  =over 4
2305    
# Line 2311  Line 2329 
2329          $retVal = ">" . EmergencyFileTarget($tkey);          $retVal = ">" . EmergencyFileTarget($tkey);
2330      } elsif ($myDest eq 'APPEND') {      } elsif ($myDest eq 'APPEND') {
2331          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
2332      } else {      } elsif ($myDest eq 'DUAL') {
2333          $retVal = $myDest;          $retVal = "+>" . EmergencyFileTarget($tkey);
2334      }      }
2335      # Return the result.      # Return the result.
2336      return $retVal;      return $retVal;
# Line 2322  Line 2340 
2340    
2341  C<< Emergency($key, $hours, $dest, $level, @modules); >>  C<< Emergency($key, $hours, $dest, $level, @modules); >>
2342    
2343  Turn on emergency tracing. This method can only be invoked over the web and is  Turn on emergency tracing. This method is normally invoked over the web from
2344  should not be called if debug mode is off. The caller specifies the duration of the  a debugging console, but it can also be called by the C<trace.pl> script.
2345  emergency in hours, the desired tracing destination, the trace level,  The caller specifies the duration of the emergency in hours, the desired tracing
2346  and a list of the trace modules to activate. For the length of the duration, when a  destination, the trace level, and a list of the trace modules to activate.
2347  program in an environment with the specified tracing key active invokes a Sprout  For the length of the duration, when a program in an environment with the
2348  CGI script, tracing will be turned on automatically. See L</TSetup> for more  specified tracing key active invokes a Sprout CGI script, tracing will be
2349  about tracing setup and L</ETracing> for more about emergency tracing.  turned on automatically. See L</TSetup> for more about tracing setup and
2350    L</ETracing> for more about emergency tracing.
2351    
2352  =over 4  =over 4
2353    
# Line 2581  Line 2600 
2600  sub Insure {  sub Insure {
2601      my ($dirName) = @_;      my ($dirName) = @_;
2602      if (! -d $dirName) {      if (! -d $dirName) {
2603          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(File => 2);
2604          eval { mkpath $dirName; };          eval { mkpath $dirName; };
2605          if ($@) {          if ($@) {
2606              Confess("Error creating $dirName: $@");              Confess("Error creating $dirName: $@");
# Line 2610  Line 2629 
2629      if (! -d $dirName) {      if (! -d $dirName) {
2630          Confess("Cannot change to directory $dirName: no such directory.");          Confess("Cannot change to directory $dirName: no such directory.");
2631      } else {      } else {
2632          Trace("Changing to directory $dirName.") if T(4);          Trace("Changing to directory $dirName.") if T(File => 4);
2633          my $okFlag = chdir $dirName;          my $okFlag = chdir $dirName;
2634          if (! $okFlag) {          if (! $okFlag) {
2635              Confess("Error switching to directory $dirName.");              Confess("Error switching to directory $dirName.");
# Line 2789  Line 2808 
2808          my $gid = getgrnam($group);          my $gid = getgrnam($group);
2809          # Get the mask for tracing.          # Get the mask for tracing.
2810          my $traceMask = sprintf("%04o", $mask) . "($mask)";          my $traceMask = sprintf("%04o", $mask) . "($mask)";
2811          Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);          Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(File => 2);
2812          my $fixCount = 0;          my $fixCount = 0;
2813          my $lookCount = 0;          my $lookCount = 0;
2814          # @dirs will be a stack of directories to be processed.          # @dirs will be a stack of directories to be processed.
# Line 2804  Line 2823 
2823              if ($dir =~ m!/([^/]+)$!) {              if ($dir =~ m!/([^/]+)$!) {
2824                  $simpleName = $1;                  $simpleName = $1;
2825              }              }
2826              Trace("Simple directory name for $dir is $simpleName.") if T(4);              Trace("Simple directory name for $dir is $simpleName.") if T(File => 4);
2827              # Search for a match.              # Search for a match.
2828              my $match = 0;              my $match = 0;
2829              my $i;              my $i;
# Line 2829  Line 2848 
2848                      Trace("Checking member $thisMem.") if T(4);                      Trace("Checking member $thisMem.") if T(4);
2849                      $lookCount++;                      $lookCount++;
2850                      if ($lookCount % 1000 == 0) {                      if ($lookCount % 1000 == 0) {
2851                          Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);                          Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(File => 3);
2852                      }                      }
2853                      # Fix the group.                      # Fix the group.
2854                      chown -1, $gid, $thisMem;                      chown -1, $gid, $thisMem;
# Line 2856  Line 2875 
2875                  }                  }
2876              }              }
2877          }          }
2878          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(File => 2);
2879      };      };
2880      # Check for an error.      # Check for an error.
2881      if ($@) {      if ($@) {
# Line 2959  Line 2978 
2978      my ($handle) = @_;      my ($handle) = @_;
2979      # Declare the return variable.      # Declare the return variable.
2980      my @retVal = ();      my @retVal = ();
2981        Trace("File position is " . tell($handle) . ". EOF flag is " . eof($handle) . ".") if T(File => 4);
2982      # Read from the file.      # Read from the file.
2983      my $line = <$handle>;      my $line = <$handle>;
2984      # Only proceed if we found something.      # Only proceed if we found something.
2985      if (defined $line) {      if (defined $line) {
2986          # Remove the new-line.          # Remove the new-line. We are a bit over-cautious here because the file may be coming in via an
2987          chomp $line;          # upload control and have a nonstandard EOL combination.
2988            $line =~ s/(\r|\n)+$//;
2989            # Here we do some fancy tracing to help in debugging complicated EOL marks.
2990            if (T(File => 4)) {
2991                my $escapedLine = $line;
2992                $escapedLine =~ s/\n/\\n/g;
2993                $escapedLine =~ s/\r/\\r/g;
2994                $escapedLine =~ s/\t/\\t/g;
2995                Trace("Line read: -->$escapedLine<--");
2996            }
2997          # If the line is empty, return a single empty string; otherwise, parse          # If the line is empty, return a single empty string; otherwise, parse
2998          # it into fields.          # it into fields.
2999          if ($line eq "") {          if ($line eq "") {
# Line 2972  Line 3001 
3001          } else {          } else {
3002              push @retVal, split /\t/,$line;              push @retVal, split /\t/,$line;
3003          }          }
3004        } else {
3005            # Trace the reason the read failed.
3006            Trace("End of file: $!") if T(File => 3);
3007      }      }
3008      # Return the result.      # Return the result.
3009      return @retVal;      return @retVal;
# Line 2979  Line 3011 
3011    
3012  =head3 PutLine  =head3 PutLine
3013    
3014  C<< Tracer::PutLine($handle, \@fields); >>  C<< Tracer::PutLine($handle, \@fields, $eol); >>
3015    
3016  Write a line of data to a tab-delimited file. The specified field values will be  Write a line of data to a tab-delimited file. The specified field values will be
3017  output in tab-separated form, with a trailing new-line.  output in tab-separated form, with a trailing new-line.
# Line 2994  Line 3026 
3026    
3027  List of field values.  List of field values.
3028    
3029    =item eol (optional)
3030    
3031    End-of-line character (default is "\n").
3032    
3033  =back  =back
3034    
3035  =cut  =cut
3036    
3037  sub PutLine {  sub PutLine {
3038      # Get the parameters.      # Get the parameters.
3039      my ($handle, $fields) = @_;      my ($handle, $fields, $eol) = @_;
3040      # Write the data.      # Write the data.
3041      print $handle join("\t", @{$fields}) . "\n";      print $handle join("\t", @{$fields}) . ($eol || "\n");
3042  }  }
3043    
3044  =head3 GenerateURL  =head3 GenerateURL
# Line 3017  Line 3053 
3053    
3054  would return  would return
3055    
3056      form.cgi?type=1&string=%22high%20pass%22%20or%20highway      form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3057    
3058  =over 4  =over 4
3059    
# Line 3047  Line 3083 
3083      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
3084      # If the list is nonempty, tack it on.      # If the list is nonempty, tack it on.
3085      if (@parmList) {      if (@parmList) {
3086          $retVal .= "?" . join("&", @parmList);          $retVal .= "?" . join(";", @parmList);
3087        }
3088        # Return the result.
3089        return $retVal;
3090    }
3091    
3092    =head3 ApplyURL
3093    
3094    C<< Tracer::ApplyURL($table, $target, $url); >>
3095    
3096    Run through a two-dimensional table (or more accurately, a list of lists), converting the
3097    I<$target> column to HTML text having a hyperlink to a URL in the I<$url> column. The
3098    URL column will be deleted by this process and the target column will be HTML-escaped.
3099    
3100    This provides a simple way to process the results of a database query into something
3101    displayable by combining a URL with text.
3102    
3103    =over 4
3104    
3105    =item table
3106    
3107    Reference to a list of lists. The elements in the containing list will be updated by
3108    this method.
3109    
3110    =item target
3111    
3112    The index of the column to be converted into HTML.
3113    
3114    =item url
3115    
3116    The index of the column containing the URL. Note that the URL must have a recognizable
3117    C<http:> at the beginning.
3118    
3119    =back
3120    
3121    =cut
3122    
3123    sub ApplyURL {
3124        # Get the parameters.
3125        my ($table, $target, $url) = @_;
3126        # Loop through the table.
3127        for my $row (@{$table}) {
3128            # Apply the URL to the target cell.
3129            $row->[$target] = CombineURL($row->[$target], $row->[$url]);
3130            # Delete the URL from the row.
3131            delete $row->[$url];
3132        }
3133    }
3134    
3135    =head3 CombineURL
3136    
3137    C<< my $combinedHtml = Tracer::CombineURL($text, $url); >>
3138    
3139    This method will convert the specified text into HTML hyperlinked to the specified
3140    URL. The hyperlinking will only take place if the URL looks legitimate: that is, it
3141    is defined and begins with an C<http:> header.
3142    
3143    =over 4
3144    
3145    =item text
3146    
3147    Text to return. This will be HTML-escaped automatically.
3148    
3149    =item url
3150    
3151    A URL to be hyperlinked to the text. If it does not look like a URL, then the text
3152    will be returned without any hyperlinking.
3153    
3154    =item RETURN
3155    
3156    Returns the original text, HTML-escaped, with the URL hyperlinked to it. If the URL
3157    doesn't look right, the HTML-escaped text will be returned without any further
3158    modification.
3159    
3160    =back
3161    
3162    =cut
3163    
3164    sub CombineURL {
3165        # Get the parameters.
3166        my ($text, $url) = @_;
3167        # Declare the return variable.
3168        my $retVal = CGI::escapeHTML($text);
3169        # Verify the URL.
3170        if (defined($url) && $url =~ m!http://!i) {
3171            # It's good, so we apply it to the text.
3172            $retVal = "<a href=\"$url\">$retVal</a>";
3173      }      }
3174      # Return the result.      # Return the result.
3175      return $retVal;      return $retVal;

Legend:
Removed from v.1.75  
changed lines
  Added in v.1.84

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3