[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.82, Tue Apr 10 03:51:18 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 931  Line 932 
932      return $value;      return $value;
933  }  }
934    
935    =head3 ParseTraceDate
936    
937    C<< my $time = Tracer::ParseTraceDate($dateString); >>
938    
939    Convert a date from the trace file into a PERL timestamp.
940    
941    =over 4
942    
943    =item dateString
944    
945    The date string from the trace file. The format of the string is determined by the
946    L</Now> method.
947    
948    =item RETURN
949    
950    Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if
951    the time string is invalid.
952    
953    =back
954    
955    =cut
956    
957    sub ParseTraceDate {
958        # Get the parameters.
959        my ($dateString) = @_;
960        # Declare the return variable.
961        my $retVal;
962        # Parse the date.
963        if ($dateString =~ m#(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)#) {
964            # Create a time object. Note we need to convert the day, month,
965            # and year to a different base. Years count from 1900, and
966            # the internal month value is relocated to January = 0.
967            $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);
968        }
969        # Return the result.
970        return $retVal;
971    }
972    
973  =head3 LogErrors  =head3 LogErrors
974    
975  C<< Tracer::LogErrors($fileName); >>  C<< Tracer::LogErrors($fileName); >>
# Line 1598  Line 1637 
1637      # Close it.      # Close it.
1638      close $handle;      close $handle;
1639      my $actualLines = @retVal;      my $actualLines = @retVal;
1640        Trace("$actualLines lines read from file $fileName.") if T(File => 2);
1641      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1642      if (wantarray) {      if (wantarray) {
1643          return @retVal;          return @retVal;
# Line 1633  Line 1673 
1673      my ($fileName, $lines) = @_;      my ($fileName, $lines) = @_;
1674      # Open the output file.      # Open the output file.
1675      my $handle = Open(undef, ">$fileName");      my $handle = Open(undef, ">$fileName");
1676        # Count the lines written.
1677      if (ref $lines ne 'ARRAY') {      if (ref $lines ne 'ARRAY') {
1678          # Here we have a scalar, so we write it raw.          # Here we have a scalar, so we write it raw.
1679          print $handle $lines;          print $handle $lines;
1680            Trace("Scalar put to file $fileName.") if T(File => 3);
1681      } else {      } else {
1682          # Write the lines one at a time.          # Write the lines one at a time.
1683            my $count = 0;
1684          for my $line (@{$lines}) {          for my $line (@{$lines}) {
1685              print $handle "$line\n";              print $handle "$line\n";
1686                $count++;
1687          }          }
1688            Trace("$count lines put to file $fileName.") if T(File => 3);
1689      }      }
1690      # Close the output file.      # Close the output file.
1691      close $handle;      close $handle;
# Line 2059  Line 2104 
2104  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>  C<< my ($cgi, $varHash) = ScriptSetup($noTrace); >>
2105    
2106  Perform standard tracing and debugging setup for scripts. The value returned is  Perform standard tracing and debugging setup for scripts. The value returned is
2107  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,
2108    the client should call L</ScriptFinish> to output the web page.
2109    
2110  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
2111  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.  
2112  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>
2113  method, which includes every program that uses this method or L</StandardSetup>.  method, which includes every program that uses this method or L</StandardSetup>.
2114    
# Line 2546  Line 2585 
2585  sub Insure {  sub Insure {
2586      my ($dirName) = @_;      my ($dirName) = @_;
2587      if (! -d $dirName) {      if (! -d $dirName) {
2588          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(File => 2);
2589          eval { mkpath $dirName; };          eval { mkpath $dirName; };
2590          if ($@) {          if ($@) {
2591              Confess("Error creating $dirName: $@");              Confess("Error creating $dirName: $@");
# Line 2575  Line 2614 
2614      if (! -d $dirName) {      if (! -d $dirName) {
2615          Confess("Cannot change to directory $dirName: no such directory.");          Confess("Cannot change to directory $dirName: no such directory.");
2616      } else {      } else {
2617          Trace("Changing to directory $dirName.") if T(4);          Trace("Changing to directory $dirName.") if T(File => 4);
2618          my $okFlag = chdir $dirName;          my $okFlag = chdir $dirName;
2619          if (! $okFlag) {          if (! $okFlag) {
2620              Confess("Error switching to directory $dirName.");              Confess("Error switching to directory $dirName.");
# Line 2754  Line 2793 
2793          my $gid = getgrnam($group);          my $gid = getgrnam($group);
2794          # Get the mask for tracing.          # Get the mask for tracing.
2795          my $traceMask = sprintf("%04o", $mask) . "($mask)";          my $traceMask = sprintf("%04o", $mask) . "($mask)";
2796          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);
2797          my $fixCount = 0;          my $fixCount = 0;
2798          my $lookCount = 0;          my $lookCount = 0;
2799          # @dirs will be a stack of directories to be processed.          # @dirs will be a stack of directories to be processed.
# Line 2769  Line 2808 
2808              if ($dir =~ m!/([^/]+)$!) {              if ($dir =~ m!/([^/]+)$!) {
2809                  $simpleName = $1;                  $simpleName = $1;
2810              }              }
2811              Trace("Simple directory name for $dir is $simpleName.") if T(4);              Trace("Simple directory name for $dir is $simpleName.") if T(File => 4);
2812              # Search for a match.              # Search for a match.
2813              my $match = 0;              my $match = 0;
2814              my $i;              my $i;
# Line 2794  Line 2833 
2833                      Trace("Checking member $thisMem.") if T(4);                      Trace("Checking member $thisMem.") if T(4);
2834                      $lookCount++;                      $lookCount++;
2835                      if ($lookCount % 1000 == 0) {                      if ($lookCount % 1000 == 0) {
2836                          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);
2837                      }                      }
2838                      # Fix the group.                      # Fix the group.
2839                      chown -1, $gid, $thisMem;                      chown -1, $gid, $thisMem;
# Line 2821  Line 2860 
2860                  }                  }
2861              }              }
2862          }          }
2863          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(File => 2);
2864      };      };
2865      # Check for an error.      # Check for an error.
2866      if ($@) {      if ($@) {
# Line 2924  Line 2963 
2963      my ($handle) = @_;      my ($handle) = @_;
2964      # Declare the return variable.      # Declare the return variable.
2965      my @retVal = ();      my @retVal = ();
2966        Trace("File position is " . tell($handle) . ". EOF flag is " . eof($handle) . ".") if T(File => 4);
2967      # Read from the file.      # Read from the file.
2968      my $line = <$handle>;      my $line = <$handle>;
2969      # Only proceed if we found something.      # Only proceed if we found something.
2970      if (defined $line) {      if (defined $line) {
2971          # Remove the new-line.          # Remove the new-line. We are a bit over-cautious here because the file may be coming in via an
2972          chomp $line;          # upload control and have a nonstandard EOL combination.
2973            $line =~ s/(\r|\n)+$//;
2974            # Here we do some fancy tracing to help in debugging complicated EOL marks.
2975            if (T(File => 4)) {
2976                my $escapedLine = $line;
2977                $escapedLine =~ s/\n/\\n/g;
2978                $escapedLine =~ s/\r/\\r/g;
2979                $escapedLine =~ s/\t/\\t/g;
2980                Trace("Line read: -->$escapedLine<--");
2981            }
2982          # If the line is empty, return a single empty string; otherwise, parse          # If the line is empty, return a single empty string; otherwise, parse
2983          # it into fields.          # it into fields.
2984          if ($line eq "") {          if ($line eq "") {
# Line 2937  Line 2986 
2986          } else {          } else {
2987              push @retVal, split /\t/,$line;              push @retVal, split /\t/,$line;
2988          }          }
2989        } else {
2990            # Trace the reason the read failed.
2991            Trace("End of file: $!") if T(File => 3);
2992      }      }
2993      # Return the result.      # Return the result.
2994      return @retVal;      return @retVal;
# Line 2944  Line 2996 
2996    
2997  =head3 PutLine  =head3 PutLine
2998    
2999  C<< Tracer::PutLine($handle, \@fields); >>  C<< Tracer::PutLine($handle, \@fields, $eol); >>
3000    
3001  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
3002  output in tab-separated form, with a trailing new-line.  output in tab-separated form, with a trailing new-line.
# Line 2959  Line 3011 
3011    
3012  List of field values.  List of field values.
3013    
3014    =item eol (optional)
3015    
3016    End-of-line character (default is "\n").
3017    
3018  =back  =back
3019    
3020  =cut  =cut
3021    
3022  sub PutLine {  sub PutLine {
3023      # Get the parameters.      # Get the parameters.
3024      my ($handle, $fields) = @_;      my ($handle, $fields, $eol) = @_;
3025      # Write the data.      # Write the data.
3026      print $handle join("\t", @{$fields}) . "\n";      print $handle join("\t", @{$fields}) . ($eol || "\n");
3027  }  }
3028    
3029  =head3 GenerateURL  =head3 GenerateURL
# Line 2982  Line 3038 
3038    
3039  would return  would return
3040    
3041      form.cgi?type=1&string=%22high%20pass%22%20or%20highway      form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3042    
3043  =over 4  =over 4
3044    
# Line 3012  Line 3068 
3068      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
3069      # If the list is nonempty, tack it on.      # If the list is nonempty, tack it on.
3070      if (@parmList) {      if (@parmList) {
3071          $retVal .= "?" . join("&", @parmList);          $retVal .= "?" . join(";", @parmList);
3072        }
3073        # Return the result.
3074        return $retVal;
3075    }
3076    
3077    =head3 ApplyURL
3078    
3079    C<< Tracer::ApplyURL($table, $target, $url); >>
3080    
3081    Run through a two-dimensional table (or more accurately, a list of lists), converting the
3082    I<$target> column to HTML text having a hyperlink to a URL in the I<$url> column. The
3083    URL column will be deleted by this process and the target column will be HTML-escaped.
3084    
3085    This provides a simple way to process the results of a database query into something
3086    displayable by combining a URL with text.
3087    
3088    =over 4
3089    
3090    =item table
3091    
3092    Reference to a list of lists. The elements in the containing list will be updated by
3093    this method.
3094    
3095    =item target
3096    
3097    The index of the column to be converted into HTML.
3098    
3099    =item url
3100    
3101    The index of the column containing the URL. Note that the URL must have a recognizable
3102    C<http:> at the beginning.
3103    
3104    =back
3105    
3106    =cut
3107    
3108    sub ApplyURL {
3109        # Get the parameters.
3110        my ($table, $target, $url) = @_;
3111        # Loop through the table.
3112        for my $row (@{$table}) {
3113            # Apply the URL to the target cell.
3114            $row->[$target] = CombineURL($row->[$target], $row->[$url]);
3115            # Delete the URL from the row.
3116            delete $row->[$url];
3117        }
3118    }
3119    
3120    =head3 CombineURL
3121    
3122    C<< my $combinedHtml = Tracer::CombineURL($text, $url); >>
3123    
3124    This method will convert the specified text into HTML hyperlinked to the specified
3125    URL. The hyperlinking will only take place if the URL looks legitimate: that is, it
3126    is defined and begins with an C<http:> header.
3127    
3128    =over 4
3129    
3130    =item text
3131    
3132    Text to return. This will be HTML-escaped automatically.
3133    
3134    =item url
3135    
3136    A URL to be hyperlinked to the text. If it does not look like a URL, then the text
3137    will be returned without any hyperlinking.
3138    
3139    =item RETURN
3140    
3141    Returns the original text, HTML-escaped, with the URL hyperlinked to it. If the URL
3142    doesn't look right, the HTML-escaped text will be returned without any further
3143    modification.
3144    
3145    =back
3146    
3147    =cut
3148    
3149    sub CombineURL {
3150        # Get the parameters.
3151        my ($text, $url) = @_;
3152        # Declare the return variable.
3153        my $retVal = CGI::escapeHTML($text);
3154        # Verify the URL.
3155        if (defined($url) && $url =~ m!http://!i) {
3156            # It's good, so we apply it to the text.
3157            $retVal = "<a href=\"$url\">$retVal</a>";
3158      }      }
3159      # Return the result.      # Return the result.
3160      return $retVal;      return $retVal;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3