[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.105, Wed May 14 09:09:25 2008 UTC revision 1.106, Fri May 16 08:32:02 2008 UTC
# Line 38  Line 38 
38      use Time::Local;      use Time::Local;
39      use POSIX qw(strftime);      use POSIX qw(strftime);
40      use Time::Zone;      use Time::Zone;
41        use Fcntl ':flock';
42    
43    
44  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
# Line 661  Line 662 
662      croak(">>> $message");      croak(">>> $message");
663  }  }
664    
665    =head3 SaveCGI
666    
667        Tracer::SaveCGI($cgi);
668    
669    This method saves the CGI object but does not activate emergency tracing.
670    It is used to allow L</Warn> to work in situations where emergency
671    tracing is contra-indicated (e.g. the wiki).
672    
673    =over 4
674    
675    =item cgi
676    
677    Active CGI query object.
678    
679    =back
680    
681    =cut
682    
683    sub SaveCGI {
684        $SavedCGI = $_[0];
685    }
686    
687  =head3 Warn  =head3 Warn
688    
689      Warn($message);      Warn($message, @options);
690    
691  This method traces an important message. If an RSS feed is configured  This method traces an important message. If an RSS feed is configured
692  (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,  (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
# Line 686  Line 709 
709    
710  Message to be traced.  Message to be traced.
711    
712    =item options
713    
714    A list containing zero or more options.
715    
716    =back
717    
718    The permissible options are as follows.
719    
720    =over 4
721    
722    =item noStack
723    
724    If specified, then the stack trace is not included in the output.
725    
726  =back  =back
727    
728  =cut  =cut
729    
730  sub Warn {  sub Warn {
731      # Get the parameters.      # Get the parameters.
732      my ($message) = @_;      my $message = shift @_;
733        my %options = map { $_ => 1 } @_;
734      # Trace the message.      # Trace the message.
735      Trace($message);      Trace($message);
736        # This will contain the lock handle. If it's defined, it means we need to unlock.
737        my $lock;
738      # Check for feed forcing.      # Check for feed forcing.
739      my $forceFeed = exists $Categories{feed};      my $forceFeed = exists $Categories{feed};
740      # An error here would be disastrous. Note, however, that we aren't too worried      # An error here would be disastrous. Note that if debug mode is specified,
741      # about losing events. The error log is always available for the occasions where      # we do this stuff even in a test environment.
     # we mess up. Note that if debug mode is specified, we do this stuff even in a  
     # test environment.  
742      eval {      eval {
743          # Do we need to put this in the RSS feed?          # Do we need to put this in the RSS feed?
744          if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {          if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
# Line 729  Line 767 
767                  # We're in a web service. The environment is the user's IP, and the link                  # We're in a web service. The environment is the user's IP, and the link
768                  # is the URL that got us here.                  # is the URL that got us here.
769                  my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};                  my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
770                  $environment .= "Event Reported at IP address $key.";                  $environment .= "Event Reported at IP address $key process $$.";
771                  my $url = $SavedCGI->url(-full => 1, -query => 1);                  my $url = $SavedCGI->self_url();
772                  # We need the user agent string and (if available) the referrer.                  # We need the user agent string and (if available) the referrer.
773                  # The referrer will be the link.                  # The referrer will be the link.
774                  $environment .= "User Agent $ENV{HTTP_USER_AGENT}";                  $environment .= "User Agent $ENV{HTTP_USER_AGENT}";
# Line 741  Line 779 
779                      $environment .= " referrer unknown.";                      $environment .= " referrer unknown.";
780                  }                  }
781                  # Close off the sentence with the original link.                  # Close off the sentence with the original link.
782                  $environment .= " URL of error is <a href=\"$url\">$url</a>.";                  $environment .= " URL of event is <a href=\"$url\">$url</a>.";
783              } else {              } else {
784                  # No CGI object, so we're a command-line tool. Use the tracing                  # No CGI object, so we're a command-line tool. Use the tracing
785                  # key and the PID as the user identifier, and add the command.                  # key and the PID as the user identifier, and add the command.
786                  my $key = EmergencyKey();                  my $key = EmergencyKey();
787                  $environment .= "Event Reported by $key Process $$.";                  $environment .= "Event Reported by $key process $$.";
788                  if ($CommandLine) {                  if ($CommandLine) {
789                      # We're in a StandardSetup script, so we have the real command line.                      # We're in a StandardSetup script, so we have the real command line.
790                      $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";                      $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
# Line 759  Line 797 
797              # then digest the result.              # then digest the result.
798              my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);              my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
799              # Finally, the description. This is a stack trace plus various environmental stuff.              # Finally, the description. This is a stack trace plus various environmental stuff.
800              my $stackTrace = "";              # The trace is optional.
801                my $stackTrace;
802                if ($options{noStack}) {
803                    $stackTrace = "";
804                } else {
805              my @trace = LongMess();              my @trace = LongMess();
806              # Only proceed if we got something back.              # Only proceed if we got something back.
807              if (scalar(@trace) > 0) {              if (scalar(@trace) > 0) {
808                  $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;                  $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
809                  $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");                  $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
810              }              }
811                }
812              # We got the stack trace. Now it's time to put it all together.              # We got the stack trace. Now it's time to put it all together.
813              # We have a goofy thing here in that we need to HTML-escape some sections of the description              # We have a goofy thing here in that we need to HTML-escape some sections of the description
814              # twice. They will be escaped once here, and then once when written by XML::Simple. They are              # twice. They will be escaped once here, and then once when written by XML::Simple. They are
# Line 787  Line 830 
830              my $rss;              my $rss;
831              # Get the name of the RSS file. It's in the FIG temporary directory.              # Get the name of the RSS file. It's in the FIG temporary directory.
832              my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";              my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
833                # Open the config file and lock it.
834                $lock = Open(undef, "<$FIG_Config::fig_disk/config/FIG_Config.pm");
835                flock $lock, LOCK_EX;
836              # Does it exist?              # Does it exist?
837              if (-s $fileName) {              if (-s $fileName) {
838                  # Slurp it in.                  # Slurp it in.
# Line 819  Line 865 
865              unshift @{$items}, $newItem;              unshift @{$items}, $newItem;
866              # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle              # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
867              # the requirements for those.              # the requirements for those.
868              my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => undef, XmlDecl => '');              my $xml = XML::Simple::XMLout($channel, NoAttr => 1, RootName => 'channel', XmlDecl => '');
869              # Here we put in the root and declaration. The problem is that the root has to have the version attribute              # Here we put in the root and declaration. The problem is that the root has to have the version attribute
870              # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.              # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
871              $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";              $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
# Line 836  Line 882 
882          my $error = $@;          my $error = $@;
883          Trace("Feed Error: $error") if T(Feed => 0);          Trace("Feed Error: $error") if T(Feed => 0);
884      }      }
885        # Be sure to unlock.
886        if ($lock) {
887            flock $lock, LOCK_UN;
888            undef $lock;
889  }  }
890    }
891    
892    
893    
894    
895  =head3 Assert  =head3 Assert
896    

Legend:
Removed from v.1.105  
changed lines
  Added in v.1.106

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3