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

Diff of /FigKernelPackages/Tracer.pm

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

revision 1.73, Tue Oct 3 12:04:50 2006 UTC revision 1.83, Fri Apr 27 22:13:57 2007 UTC
# Line 34  Line 34 
34      use LWP::UserAgent;      use LWP::UserAgent;
35      use Time::HiRes 'gettimeofday';      use Time::HiRes 'gettimeofday';
36      use URI::Escape;      use URI::Escape;
37        use Time::Local;
38    
39  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
40    
# Line 661  Line 662 
662          }          }
663          exit(0);          exit(0);
664      }      }
665        # Trace the options, if applicable.
666        if (T(3)) {
667            my @parms = grep { $retOptions->{$_} } keys %{$retOptions};
668            Trace("Selected options: " . join(", ", sort @parms) . ".");
669        }
670      # Return the parsed parameters.      # Return the parsed parameters.
671      return ($retOptions, @retParameters);      return ($retOptions, @retParameters);
672  }  }
# Line 931  Line 937 
937      return $value;      return $value;
938  }  }
939    
940    =head3 ParseTraceDate
941    
942    C<< my $time = Tracer::ParseTraceDate($dateString); >>
943    
944    Convert a date from the trace file into a PERL timestamp.
945    
946    =over 4
947    
948    =item dateString
949    
950    The date string from the trace file. The format of the string is determined by the
951    L</Now> method.
952    
953    =item RETURN
954    
955    Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if
956    the time string is invalid.
957    
958    =back
959    
960    =cut
961    
962    sub ParseTraceDate {
963        # Get the parameters.
964        my ($dateString) = @_;
965        # Declare the return variable.
966        my $retVal;
967        # Parse the date.
968        if ($dateString =~ m#(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)#) {
969            # Create a time object. Note we need to convert the day, month,
970            # and year to a different base. Years count from 1900, and
971            # the internal month value is relocated to January = 0.
972            $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);
973        }
974        # Return the result.
975        return $retVal;
976    }
977    
978  =head3 LogErrors  =head3 LogErrors
979    
980  C<< Tracer::LogErrors($fileName); >>  C<< Tracer::LogErrors($fileName); >>
# Line 1598  Line 1642 
1642      # Close it.      # Close it.
1643      close $handle;      close $handle;
1644      my $actualLines = @retVal;      my $actualLines = @retVal;
1645        Trace("$actualLines lines read from file $fileName.") if T(File => 2);
1646      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1647      if (wantarray) {      if (wantarray) {
1648          return @retVal;          return @retVal;
# Line 1633  Line 1678 
1678      my ($fileName, $lines) = @_;      my ($fileName, $lines) = @_;
1679      # Open the output file.      # Open the output file.
1680      my $handle = Open(undef, ">$fileName");      my $handle = Open(undef, ">$fileName");
1681        # Count the lines written.
1682      if (ref $lines ne 'ARRAY') {      if (ref $lines ne 'ARRAY') {
1683          # Here we have a scalar, so we write it raw.          # Here we have a scalar, so we write it raw.
1684          print $handle $lines;          print $handle $lines;
1685            Trace("Scalar put to file $fileName.") if T(File => 3);
1686      } else {      } else {
1687          # Write the lines one at a time.          # Write the lines one at a time.
1688            my $count = 0;
1689          for my $line (@{$lines}) {          for my $line (@{$lines}) {
1690              print $handle "$line\n";              print $handle "$line\n";
1691                $count++;
1692          }          }
1693            Trace("$count lines put to file $fileName.") if T(File => 3);
1694      }      }
1695      # Close the output file.      # Close the output file.
1696      close $handle;      close $handle;
# Line 2059  Line 2109 
2109  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>
2110    
2111  Perform standard tracing and debugging setup for scripts. The value returned is  Perform standard tracing and debugging setup for scripts. The value returned is
2112  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,
2113    the client should call L</ScriptFinish> to output the web page.
 The C<Trace> form parameter is used to determine whether or not tracing is active and  
 which trace modules (other than C<Tracer> itself) should be turned on. Specifying  
 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.  
2114    
2115  In some situations, it is not practical to invoke tracing via form parameters. For this  This method calls L</ETracing> to configure tracing, which allows the tracing
2116  situation, you can turn on emergency tracing from the debugging control panel.  to be configured via the emergency tracing form on the debugging control panel.
2117  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>
2118  method, which includes every program that uses this method or L</StandardSetup>.  method, which includes every program that uses this method or L</StandardSetup>.
2119    
# Line 2546  Line 2590 
2590  sub Insure {  sub Insure {
2591      my ($dirName) = @_;      my ($dirName) = @_;
2592      if (! -d $dirName) {      if (! -d $dirName) {
2593          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(File => 2);
2594          eval { mkpath $dirName; };          eval { mkpath $dirName; };
2595          if ($@) {          if ($@) {
2596              Confess("Error creating $dirName: $@");              Confess("Error creating $dirName: $@");
# Line 2575  Line 2619 
2619      if (! -d $dirName) {      if (! -d $dirName) {
2620          Confess("Cannot change to directory $dirName: no such directory.");          Confess("Cannot change to directory $dirName: no such directory.");
2621      } else {      } else {
2622          Trace("Changing to directory $dirName.") if T(4);          Trace("Changing to directory $dirName.") if T(File => 4);
2623          my $okFlag = chdir $dirName;          my $okFlag = chdir $dirName;
2624          if (! $okFlag) {          if (! $okFlag) {
2625              Confess("Error switching to directory $dirName.");              Confess("Error switching to directory $dirName.");
# Line 2754  Line 2798 
2798          my $gid = getgrnam($group);          my $gid = getgrnam($group);
2799          # Get the mask for tracing.          # Get the mask for tracing.
2800          my $traceMask = sprintf("%04o", $mask) . "($mask)";          my $traceMask = sprintf("%04o", $mask) . "($mask)";
2801          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);
2802          my $fixCount = 0;          my $fixCount = 0;
2803          my $lookCount = 0;          my $lookCount = 0;
2804          # @dirs will be a stack of directories to be processed.          # @dirs will be a stack of directories to be processed.
# Line 2769  Line 2813 
2813              if ($dir =~ m!/([^/]+)$!) {              if ($dir =~ m!/([^/]+)$!) {
2814                  $simpleName = $1;                  $simpleName = $1;
2815              }              }
2816              Trace("Simple directory name for $dir is $simpleName.") if T(4);              Trace("Simple directory name for $dir is $simpleName.") if T(File => 4);
2817              # Search for a match.              # Search for a match.
2818              my $match = 0;              my $match = 0;
2819              my $i;              my $i;
# Line 2794  Line 2838 
2838                      Trace("Checking member $thisMem.") if T(4);                      Trace("Checking member $thisMem.") if T(4);
2839                      $lookCount++;                      $lookCount++;
2840                      if ($lookCount % 1000 == 0) {                      if ($lookCount % 1000 == 0) {
2841                          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);
2842                      }                      }
2843                      # Fix the group.                      # Fix the group.
2844                      chown -1, $gid, $thisMem;                      chown -1, $gid, $thisMem;
# Line 2821  Line 2865 
2865                  }                  }
2866              }              }
2867          }          }
2868          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(File => 2);
2869      };      };
2870      # Check for an error.      # Check for an error.
2871      if ($@) {      if ($@) {
# Line 2924  Line 2968 
2968      my ($handle) = @_;      my ($handle) = @_;
2969      # Declare the return variable.      # Declare the return variable.
2970      my @retVal = ();      my @retVal = ();
2971        Trace("File position is " . tell($handle) . ". EOF flag is " . eof($handle) . ".") if T(File => 4);
2972      # Read from the file.      # Read from the file.
2973      my $line = <$handle>;      my $line = <$handle>;
2974      # Only proceed if we found something.      # Only proceed if we found something.
2975      if (defined $line) {      if (defined $line) {
2976          # Remove the new-line.          # Remove the new-line. We are a bit over-cautious here because the file may be coming in via an
2977          chomp $line;          # upload control and have a nonstandard EOL combination.
2978            $line =~ s/(\r|\n)+$//;
2979            # Here we do some fancy tracing to help in debugging complicated EOL marks.
2980            if (T(File => 4)) {
2981                my $escapedLine = $line;
2982                $escapedLine =~ s/\n/\\n/g;
2983                $escapedLine =~ s/\r/\\r/g;
2984                $escapedLine =~ s/\t/\\t/g;
2985                Trace("Line read: -->$escapedLine<--");
2986            }
2987          # If the line is empty, return a single empty string; otherwise, parse          # If the line is empty, return a single empty string; otherwise, parse
2988          # it into fields.          # it into fields.
2989          if ($line eq "") {          if ($line eq "") {
# Line 2937  Line 2991 
2991          } else {          } else {
2992              push @retVal, split /\t/,$line;              push @retVal, split /\t/,$line;
2993          }          }
2994        } else {
2995            # Trace the reason the read failed.
2996            Trace("End of file: $!") if T(File => 3);
2997      }      }
2998      # Return the result.      # Return the result.
2999      return @retVal;      return @retVal;
# Line 2944  Line 3001 
3001    
3002  =head3 PutLine  =head3 PutLine
3003    
3004  C<< Tracer::PutLine($handle, \@fields); >>  C<< Tracer::PutLine($handle, \@fields, $eol); >>
3005    
3006  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
3007  output in tab-separated form, with a trailing new-line.  output in tab-separated form, with a trailing new-line.
# Line 2959  Line 3016 
3016    
3017  List of field values.  List of field values.
3018    
3019    =item eol (optional)
3020    
3021    End-of-line character (default is "\n").
3022    
3023  =back  =back
3024    
3025  =cut  =cut
3026    
3027  sub PutLine {  sub PutLine {
3028      # Get the parameters.      # Get the parameters.
3029      my ($handle, $fields) = @_;      my ($handle, $fields, $eol) = @_;
3030      # Write the data.      # Write the data.
3031      print $handle join("\t", @{$fields}) . "\n";      print $handle join("\t", @{$fields}) . ($eol || "\n");
3032  }  }
3033    
3034  =head3 GenerateURL  =head3 GenerateURL
# Line 2982  Line 3043 
3043    
3044  would return  would return
3045    
3046      form.cgi?type=1&string=%22high%20pass%22%20or%20highway      form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3047    
3048  =over 4  =over 4
3049    
# Line 3012  Line 3073 
3073      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
3074      # If the list is nonempty, tack it on.      # If the list is nonempty, tack it on.
3075      if (@parmList) {      if (@parmList) {
3076          $retVal .= "?" . join("&", @parmList);          $retVal .= "?" . join(";", @parmList);
3077        }
3078        # Return the result.
3079        return $retVal;
3080    }
3081    
3082    =head3 ApplyURL
3083    
3084    C<< Tracer::ApplyURL($table, $target, $url); >>
3085    
3086    Run through a two-dimensional table (or more accurately, a list of lists), converting the
3087    I<$target> column to HTML text having a hyperlink to a URL in the I<$url> column. The
3088    URL column will be deleted by this process and the target column will be HTML-escaped.
3089    
3090    This provides a simple way to process the results of a database query into something
3091    displayable by combining a URL with text.
3092    
3093    =over 4
3094    
3095    =item table
3096    
3097    Reference to a list of lists. The elements in the containing list will be updated by
3098    this method.
3099    
3100    =item target
3101    
3102    The index of the column to be converted into HTML.
3103    
3104    =item url
3105    
3106    The index of the column containing the URL. Note that the URL must have a recognizable
3107    C<http:> at the beginning.
3108    
3109    =back
3110    
3111    =cut
3112    
3113    sub ApplyURL {
3114        # Get the parameters.
3115        my ($table, $target, $url) = @_;
3116        # Loop through the table.
3117        for my $row (@{$table}) {
3118            # Apply the URL to the target cell.
3119            $row->[$target] = CombineURL($row->[$target], $row->[$url]);
3120            # Delete the URL from the row.
3121            delete $row->[$url];
3122        }
3123    }
3124    
3125    =head3 CombineURL
3126    
3127    C<< my $combinedHtml = Tracer::CombineURL($text, $url); >>
3128    
3129    This method will convert the specified text into HTML hyperlinked to the specified
3130    URL. The hyperlinking will only take place if the URL looks legitimate: that is, it
3131    is defined and begins with an C<http:> header.
3132    
3133    =over 4
3134    
3135    =item text
3136    
3137    Text to return. This will be HTML-escaped automatically.
3138    
3139    =item url
3140    
3141    A URL to be hyperlinked to the text. If it does not look like a URL, then the text
3142    will be returned without any hyperlinking.
3143    
3144    =item RETURN
3145    
3146    Returns the original text, HTML-escaped, with the URL hyperlinked to it. If the URL
3147    doesn't look right, the HTML-escaped text will be returned without any further
3148    modification.
3149    
3150    =back
3151    
3152    =cut
3153    
3154    sub CombineURL {
3155        # Get the parameters.
3156        my ($text, $url) = @_;
3157        # Declare the return variable.
3158        my $retVal = CGI::escapeHTML($text);
3159        # Verify the URL.
3160        if (defined($url) && $url =~ m!http://!i) {
3161            # It's good, so we apply it to the text.
3162            $retVal = "<a href=\"$url\">$retVal</a>";
3163      }      }
3164      # Return the result.      # Return the result.
3165      return $retVal;      return $retVal;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3