[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.80, Fri Feb 9 22:53:22 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 2546  Line 2591 
2591  sub Insure {  sub Insure {
2592      my ($dirName) = @_;      my ($dirName) = @_;
2593      if (! -d $dirName) {      if (! -d $dirName) {
2594          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(File => 2);
2595          eval { mkpath $dirName; };          eval { mkpath $dirName; };
2596          if ($@) {          if ($@) {
2597              Confess("Error creating $dirName: $@");              Confess("Error creating $dirName: $@");
# Line 2575  Line 2620 
2620      if (! -d $dirName) {      if (! -d $dirName) {
2621          Confess("Cannot change to directory $dirName: no such directory.");          Confess("Cannot change to directory $dirName: no such directory.");
2622      } else {      } else {
2623          Trace("Changing to directory $dirName.") if T(4);          Trace("Changing to directory $dirName.") if T(File => 4);
2624          my $okFlag = chdir $dirName;          my $okFlag = chdir $dirName;
2625          if (! $okFlag) {          if (! $okFlag) {
2626              Confess("Error switching to directory $dirName.");              Confess("Error switching to directory $dirName.");
# Line 2754  Line 2799 
2799          my $gid = getgrnam($group);          my $gid = getgrnam($group);
2800          # Get the mask for tracing.          # Get the mask for tracing.
2801          my $traceMask = sprintf("%04o", $mask) . "($mask)";          my $traceMask = sprintf("%04o", $mask) . "($mask)";
2802          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);
2803          my $fixCount = 0;          my $fixCount = 0;
2804          my $lookCount = 0;          my $lookCount = 0;
2805          # @dirs will be a stack of directories to be processed.          # @dirs will be a stack of directories to be processed.
# Line 2769  Line 2814 
2814              if ($dir =~ m!/([^/]+)$!) {              if ($dir =~ m!/([^/]+)$!) {
2815                  $simpleName = $1;                  $simpleName = $1;
2816              }              }
2817              Trace("Simple directory name for $dir is $simpleName.") if T(4);              Trace("Simple directory name for $dir is $simpleName.") if T(File => 4);
2818              # Search for a match.              # Search for a match.
2819              my $match = 0;              my $match = 0;
2820              my $i;              my $i;
# Line 2794  Line 2839 
2839                      Trace("Checking member $thisMem.") if T(4);                      Trace("Checking member $thisMem.") if T(4);
2840                      $lookCount++;                      $lookCount++;
2841                      if ($lookCount % 1000 == 0) {                      if ($lookCount % 1000 == 0) {
2842                          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);
2843                      }                      }
2844                      # Fix the group.                      # Fix the group.
2845                      chown -1, $gid, $thisMem;                      chown -1, $gid, $thisMem;
# Line 2821  Line 2866 
2866                  }                  }
2867              }              }
2868          }          }
2869          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);          Trace("$lookCount files and directories processed, $fixCount fixed.") if T(File => 2);
2870      };      };
2871      # Check for an error.      # Check for an error.
2872      if ($@) {      if ($@) {
# Line 2924  Line 2969 
2969      my ($handle) = @_;      my ($handle) = @_;
2970      # Declare the return variable.      # Declare the return variable.
2971      my @retVal = ();      my @retVal = ();
2972        Trace("File position is " . tell($handle) . ". EOF flag is " . eof($handle) . ".") if T(File => 4);
2973      # Read from the file.      # Read from the file.
2974      my $line = <$handle>;      my $line = <$handle>;
2975      # Only proceed if we found something.      # Only proceed if we found something.
2976      if (defined $line) {      if (defined $line) {
2977          # Remove the new-line.          # Remove the new-line. We are a bit over-cautious here because the file may be coming in via an
2978          chomp $line;          # upload control and have a nonstandard EOL combination.
2979            $line =~ s/(\r|\n)+$//;
2980            # Here we do some fancy tracing to help in debugging complicated EOL marks.
2981            if (T(File => 4)) {
2982                my $escapedLine = $line;
2983                $escapedLine =~ s/\n/\\n/g;
2984                $escapedLine =~ s/\r/\\r/g;
2985                $escapedLine =~ s/\t/\\t/g;
2986                Trace("Line read: -->$escapedLine<--");
2987            }
2988          # If the line is empty, return a single empty string; otherwise, parse          # If the line is empty, return a single empty string; otherwise, parse
2989          # it into fields.          # it into fields.
2990          if ($line eq "") {          if ($line eq "") {
# Line 2937  Line 2992 
2992          } else {          } else {
2993              push @retVal, split /\t/,$line;              push @retVal, split /\t/,$line;
2994          }          }
2995        } else {
2996            # Trace the reason the read failed.
2997            Trace("End of file: $!") if T(File => 3);
2998      }      }
2999      # Return the result.      # Return the result.
3000      return @retVal;      return @retVal;
# Line 2982  Line 3040 
3040    
3041  would return  would return
3042    
3043      form.cgi?type=1&string=%22high%20pass%22%20or%20highway      form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3044    
3045  =over 4  =over 4
3046    
# Line 3012  Line 3070 
3070      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
3071      # If the list is nonempty, tack it on.      # If the list is nonempty, tack it on.
3072      if (@parmList) {      if (@parmList) {
3073          $retVal .= "?" . join("&", @parmList);          $retVal .= "?" . join(";", @parmList);
3074        }
3075        # Return the result.
3076        return $retVal;
3077    }
3078    
3079    =head3 ApplyURL
3080    
3081    C<< Tracer::ApplyURL($table, $target, $url); >>
3082    
3083    Run through a two-dimensional table (or more accurately, a list of lists), converting the
3084    I<$target> column to HTML text having a hyperlink to a URL in the I<$url> column. The
3085    URL column will be deleted by this process and the target column will be HTML-escaped.
3086    
3087    This provides a simple way to process the results of a database query into something
3088    displayable by combining a URL with text.
3089    
3090    =over 4
3091    
3092    =item table
3093    
3094    Reference to a list of lists. The elements in the containing list will be updated by
3095    this method.
3096    
3097    =item target
3098    
3099    The index of the column to be converted into HTML.
3100    
3101    =item url
3102    
3103    The index of the column containing the URL. Note that the URL must have a recognizable
3104    C<http:> at the beginning.
3105    
3106    =back
3107    
3108    =cut
3109    
3110    sub ApplyURL {
3111        # Get the parameters.
3112        my ($table, $target, $url) = @_;
3113        # Loop through the table.
3114        for my $row (@{$table}) {
3115            # Apply the URL to the target cell.
3116            $row->[$target] = CombineURL($row->[$target], $row->[$url]);
3117            # Delete the URL from the row.
3118            delete $row->[$url];
3119        }
3120    }
3121    
3122    =head3 CombineURL
3123    
3124    C<< my $combinedHtml = Tracer::CombineURL($text, $url); >>
3125    
3126    This method will convert the specified text into HTML hyperlinked to the specified
3127    URL. The hyperlinking will only take place if the URL looks legitimate: that is, it
3128    is defined and begins with an C<http:> header.
3129    
3130    =over 4
3131    
3132    =item text
3133    
3134    Text to return. This will be HTML-escaped automatically.
3135    
3136    =item url
3137    
3138    A URL to be hyperlinked to the text. If it does not look like a URL, then the text
3139    will be returned without any hyperlinking.
3140    
3141    =item RETURN
3142    
3143    Returns the original text, HTML-escaped, with the URL hyperlinked to it. If the URL
3144    doesn't look right, the HTML-escaped text will be returned without any further
3145    modification.
3146    
3147    =back
3148    
3149    =cut
3150    
3151    sub CombineURL {
3152        # Get the parameters.
3153        my ($text, $url) = @_;
3154        # Declare the return variable.
3155        my $retVal = CGI::escapeHTML($text);
3156        # Verify the URL.
3157        if (defined($url) && $url =~ m!http://!i) {
3158            # It's good, so we apply it to the text.
3159            $retVal = "<a href=\"$url\">$retVal</a>";
3160      }      }
3161      # Return the result.      # Return the result.
3162      return $retVal;      return $retVal;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3