[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.115, Mon Jan 19 20:50:17 2009 UTC revision 1.129, Tue Jan 5 17:25:48 2010 UTC
# Line 21  Line 21 
21      use strict;      use strict;
22      use base qw(Exporter);      use base qw(Exporter);
23      use vars qw(@EXPORT @EXPORT_OK);      use vars qw(@EXPORT @EXPORT_OK);
24      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency Warn TraceDump IDHASH);      @EXPORT = qw(Trace T TSetup QTrace Confess MemTrace Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency Warn TraceDump IDHASH);
25      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);
26      use Carp qw(longmess croak carp);      use Carp qw(longmess croak carp);
27      use CGI;      use CGI;
# Line 211  Line 211 
211  my $AllTrace = 0;           # TRUE if we are tracing all categories.  my $AllTrace = 0;           # TRUE if we are tracing all categories.
212  my $SavedCGI;               # CGI object passed to ETracing  my $SavedCGI;               # CGI object passed to ETracing
213  my $CommandLine;            # Command line passed to StandardSetup  my $CommandLine;            # Command line passed to StandardSetup
214    my $Confessions = 0;        # confession count
215  umask 2;                    # Fix the damn umask so everything is group-writable.  umask 2;                    # Fix the damn umask so everything is group-writable.
216    
217  =head2 Tracing Methods  =head2 Tracing Methods
# Line 488  Line 489 
489          # Push the message into the queue.          # Push the message into the queue.
490          push @Queue, "$formatted";          push @Queue, "$formatted";
491      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
492          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML.
493          my $escapedMessage = CGI::escapeHTML($stripped);          my $escapedMessage = CGI::escapeHTML($stripped);
494          print "<p>$timeStamp $LastCategory $LastLevel: $escapedMessage</p>\n";          # The stuff after the first line feed should be pre-formatted.
495            my @lines = split /\s*\n/, $escapedMessage;
496            # Get the normal portion.
497            my $line1 = shift @lines;
498            print "<p>$timeStamp $LastCategory $LastLevel: $line1</p>\n";
499            if (@lines) {
500                print "<pre>" . join("\n", @lines, "</pre>");
501            }
502      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
503          # Write the trace message to an output file.          # Write the trace message to an output file.
504          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
# Line 505  Line 513 
513      }      }
514  }  }
515    
516    =head3 MemTrace
517    
518        MemTrace($message);
519    
520    Output a trace message that includes memory size information.
521    
522    =over 4
523    
524    =item message
525    
526    Message to display. The message will be followed by a sentence about the memory size.
527    
528    =back
529    
530    =cut
531    
532    sub MemTrace {
533        # Get the parameters.
534        my ($message) = @_;
535        my $memory = GetMemorySize();
536        Trace("$message $memory in use.");
537    }
538    
539    
540  =head3 TraceDump  =head3 TraceDump
541    
542      TraceDump($title, $object);      TraceDump($title, $object);
# Line 679  Line 711 
711      $LastLevel = 0;      $LastLevel = 0;
712      # Trace the call stack.      # Trace the call stack.
713      Cluck($message);      Cluck($message);
714        # Increment the confession count.
715        $Confessions++;
716      # Abort the program.      # Abort the program.
717      croak(">>> $message");      croak(">>> $message");
718  }  }
719    
720    =head3 Confessions
721    
722        my $count = Tracer::Confessions();
723    
724    Return the number of calls to L</Confess> by the current task.
725    
726    =cut
727    
728    sub Confessions {
729        return $Confessions;
730    }
731    
732    
733  =head3 SaveCGI  =head3 SaveCGI
734    
735      Tracer::SaveCGI($cgi);      Tracer::SaveCGI($cgi);
# Line 1015  Line 1062 
1062    
1063  =head3 ETracing  =head3 ETracing
1064    
1065      ETracing($parameter);      ETracing($parameter, %options);
1066    
1067  Set up emergency tracing. Emergency tracing is tracing that is turned  Set up emergency tracing. Emergency tracing is tracing that is turned
1068  on automatically for any program that calls this method. The emergency  on automatically for any program that calls this method. The emergency
# Line 1036  Line 1083 
1083  is a CGI object and emergency tracing is not on, the C<Trace> and  is a CGI object and emergency tracing is not on, the C<Trace> and
1084  C<TF> parameters will be used to determine the type of tracing.  C<TF> parameters will be used to determine the type of tracing.
1085    
1086    =item options
1087    
1088    Hash of options. The permissible options are given below.
1089    
1090    =over 8
1091    
1092    =item destType
1093    
1094    Emergency tracing destination type to use if no tracing file is found. The
1095    default is C<WARN>.
1096    
1097    =item noParms
1098    
1099    If TRUE, then display of the saved CGI parms is suppressed. The default is FALSE.
1100    
1101    =item level
1102    
1103    The trace level to use if no tracing file is found. The default is C<0>.
1104    
1105  =back  =back
1106    
1107  =cut  =cut
1108    
1109  sub ETracing {  sub ETracing {
1110      # Get the parameter.      # Get the parameter.
1111      my ($parameter) = @_;      my ($parameter, %options) = @_;
1112      # Check for CGI mode.      # Check for CGI mode.
1113      if (defined $parameter && ref $parameter eq 'CGI') {      if (defined $parameter && ref $parameter eq 'CGI') {
1114          $SavedCGI = $parameter;          $SavedCGI = $parameter;
1115      } else {      } else {
1116          $SavedCGI = undef;          $SavedCGI = undef;
1117      }      }
1118      # Default to no tracing except errors.      # Check for the noParms option.
1119      my ($tracing, $dest) = ("0", "WARN");      my $noParms = $options{noParms} || 0;
1120        # Get the default tracing information.
1121        my $tracing = $options{level} || 0;
1122        my $dest = $options{destType} || "WARN";
1123      # Check for emergency tracing.      # Check for emergency tracing.
1124      my $tkey = EmergencyKey($parameter);      my $tkey = EmergencyKey($parameter);
1125      my $emergencyFile = EmergencyFileName($tkey);      my $emergencyFile = EmergencyFileName($tkey);
1126      if (-e $emergencyFile) {      if (-e $emergencyFile && (my $stat = stat($emergencyFile))) {
1127          # We have the file. Read in the data.          # We have the file. Read in the data.
1128          my @tracing = GetFile($emergencyFile);          my @tracing = GetFile($emergencyFile);
1129          # Pull off the time limit.          # Pull off the time limit.
# Line 1062  Line 1131 
1131          # Convert it to seconds.          # Convert it to seconds.
1132          $expire *= 3600;          $expire *= 3600;
1133          # Check the file data.          # Check the file data.
         my $stat = stat($emergencyFile);  
1134          my ($now) = gettimeofday;          my ($now) = gettimeofday;
1135          if ($now - $stat->mtime > $expire) {          if ($now - $stat->mtime <= $expire) {
             # Delete the expired file.  
             unlink $emergencyFile;  
         } else {  
1136              # Emergency tracing is on. Pull off the destination and              # Emergency tracing is on. Pull off the destination and
1137              # the trace level;              # the trace level;
1138              $dest = shift @tracing;              $dest = shift @tracing;
1139              my $level = shift @tracing;              my $level = shift @tracing;
             # Convert the destination to a real tracing destination.  
             # temp directory.  
             $dest = EmergencyTracingDest($tkey, $dest);  
1140              # Insure Tracer is specified.              # Insure Tracer is specified.
1141              my %moduleHash = map { $_ => 1 } @tracing;              my %moduleHash = map { $_ => 1 } @tracing;
1142              $moduleHash{Tracer} = 1;              $moduleHash{Tracer} = 1;
1143              # Set the trace parameter.              # Set the trace parameter.
1144              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1145          }          }
     } elsif (defined $SavedCGI) {  
         # There's no emergency tracing, but we have a CGI object, so check  
         # for tracing from the form parameters.  
         if ($SavedCGI->param('Trace')) {  
             # Here the user has requested tracing via a form.  
             $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");  
             $tracing = $SavedCGI->param('Trace') . " Tracer";  
         }  
1146      }      }
1147        # Convert the destination to a real tracing destination.
1148        $dest = EmergencyTracingDest($tkey, $dest);
1149      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1150      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1151      # Check to see if we're a web script.      # Check to see if we're a web script.
1152      if (defined $SavedCGI) {      if (defined $SavedCGI) {
1153          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data if it's not suppressed.
1154            if (! $noParms) {
1155          TraceParms($SavedCGI);          TraceParms($SavedCGI);
1156            }
1157          # Check for RAW mode. In raw mode, we print a fake header so that we see everything          # Check for RAW mode. In raw mode, we print a fake header so that we see everything
1158          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1159          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1286  Line 1344 
1344      # Declare the return variable.      # Declare the return variable.
1345      my $retVal;      my $retVal;
1346      # Determine the parameter type.      # Determine the parameter type.
1347      if (! defined $parameter || defined($ENV{TRACING})) {      if (! defined $parameter) {
1348          # Here we're supposed to check the environment. If that fails, we          # Here we're supposed to check the environment. If that fails, we
1349          # get the effective login ID.          # get the effective login ID.
1350          $retVal = $ENV{TRACING} || scalar getpwuid($<);          $retVal = $ENV{TRACING} || scalar getpwuid($<);
# Line 2516  Line 2574 
2574          } else {          } else {
2575              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
2576          }          }
2577            closedir $dirHandle;
2578      } elsif (! $flag) {      } elsif (! $flag) {
2579          # Here the directory would not open and it's considered an error.          # Here the directory would not open and it's considered an error.
2580          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
# Line 3429  Line 3488 
3488      return $retVal;      return $retVal;
3489  }  }
3490    
3491    =head3 Quoted
3492    
3493        my $string = Tracer::Quoted($var);
3494    
3495    Convert the specified value to a string and enclose it in single quotes.
3496    If it's undefined, the string C<undef> in angle brackets will be used
3497    instead.
3498    
3499    =over 4
3500    
3501    =item var
3502    
3503    Value to quote.
3504    
3505    =item RETURN
3506    
3507    Returns a string enclosed in quotes, or an indication the value is undefined.
3508    
3509    =back
3510    
3511    =cut
3512    
3513    sub Quoted {
3514        # Get the parameters.
3515        my ($var) = @_;
3516        # Declare the return variable.
3517        my $retVal;
3518        # Are we undefined?
3519        if (! defined $var) {
3520            $retVal = "<undef>";
3521        } else {
3522            # No, so convert to a string and enclose in quotes.
3523            $retVal = $var;
3524            $retVal =~ s/'/\\'/;
3525            $retVal = "'$retVal'";
3526        }
3527        # Return the result.
3528        return $retVal;
3529    }
3530    
3531  =head3 EOF  =head3 EOF
3532    
3533  This is a constant that is lexically greater than any useful string.  This is a constant that is lexically greater than any useful string.
# Line 3518  Line 3617 
3617  }  }
3618    
3619    
3620    =head3 GetMemorySize
3621    
3622        my $string = Tracer::GetMemorySize();
3623    
3624    Return a memory size string for the current process. The string will be
3625    in comma format, with a size indicator (K, M, G) at the end.
3626    
3627    =cut
3628    
3629    sub GetMemorySize {
3630        # Get the memory size from Unix.
3631        my ($retVal) = `ps h -o vsz $$`;
3632        # Remove the ending new-line.
3633        chomp $retVal;
3634        # Format and return the result.
3635        return CommaFormat($retVal) . "K";
3636    }
3637    
3638  =head3 CompareLists  =head3 CompareLists
3639    
3640      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);
# Line 3590  Line 3707 
3707      my $cmp = Tracer::Cmp($a, $b);      my $cmp = Tracer::Cmp($a, $b);
3708    
3709  This method performs a universal sort comparison. Each value coming in is  This method performs a universal sort comparison. Each value coming in is
3710  separated into a leading text part and a trailing number part. The text  separated into a text parts and number parts. The text
3711  part is string compared, and if both parts are equal, then the number  part is string compared, and if both parts are equal, then the number
3712  parts are compared numerically. A stream of just numbers or a stream of  parts are compared numerically. A stream of just numbers or a stream of
3713  just strings will sort correctly, and a mixed stream will sort with the  just strings will sort correctly, and a mixed stream will sort with the
3714  numbers first. Strings with a label and a number will sort in the  numbers first. Strings with a label and a number will sort in the
3715  expected manner instead of lexically.  expected manner instead of lexically. Undefined values sort last.
3716    
3717  =over 4  =over 4
3718    
# Line 3629  Line 3746 
3746          $retVal = 1;          $retVal = 1;
3747      } else {      } else {
3748          # Here we have two real values. Parse the two strings.          # Here we have two real values. Parse the two strings.
3749          my $aParsed = _Parse($a);          my @aParsed = _Parse($a);
3750          my $bParsed = _Parse($b);          my @bParsed = _Parse($b);
3751            # Loop through the first string.
3752            while (! $retVal && @aParsed) {
3753                # Extract the string parts.
3754                my $aPiece = shift(@aParsed);
3755                my $bPiece = shift(@bParsed) || '';
3756                # Extract the number parts.
3757                my $aNum = shift(@aParsed);
3758                my $bNum = shift(@bParsed) || 0;
3759          # Compare the string parts insensitively.          # Compare the string parts insensitively.
3760          $retVal = (lc $aParsed->[0] cmp lc $bParsed->[0]);              $retVal = (lc($aPiece) cmp lc($bPiece));
3761          # If they're equal, compare them sensitively.          # If they're equal, compare them sensitively.
3762          if (! $retVal) {          if (! $retVal) {
3763              $retVal = ($aParsed->[0] cmp $bParsed->[0]);                  $retVal = ($aPiece cmp $bPiece);
         }  
3764          # If they're STILL equal, compare the number parts.          # If they're STILL equal, compare the number parts.
3765          if (! $retVal) {          if (! $retVal) {
3766              $retVal = $aParsed->[1] <=> $bParsed->[1];                      $retVal = $aNum <=> $bNum;
3767                    }
3768                }
3769          }          }
3770      }      }
3771      # Return the result.      # Return the result.
3772      return $retVal;      return $retVal;
3773  }  }
3774    
3775  # This method parses an input string into a string part and a number part.  # This method parses an input string into a string parts alternating with
3776    # number parts.
3777  sub _Parse {  sub _Parse {
3778        # Get the incoming string.
3779      my ($string) = @_;      my ($string) = @_;
3780      my ($alpha, $num);      # The pieces will be put in here.
3781      if ($string =~ /^(.*?)(\d+(?:\.\d+)?)$/) {      my @retVal;
3782          $alpha = $1;      # Loop through as many alpha/num sets as we can.
3783          $num = $2;      while ($string =~ /^(\D*)(\d+)(.*)/) {
3784      } else {          # Push the alpha and number parts into the return string.
3785          $alpha = $string;          push @retVal, $1, $2;
3786          $num = 0;          # Save the residual.
3787            $string = $3;
3788        }
3789        # If there's still stuff left, add it to the end with a trailing
3790        # zero.
3791        if ($string) {
3792            push @retVal, $string, 0;
3793      }      }
3794      return [$alpha, $num];      # Return the list.
3795        return @retVal;
3796  }  }
3797    
3798  =head3 ListEQ  =head3 ListEQ

Legend:
Removed from v.1.115  
changed lines
  Added in v.1.129

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3