[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.101, Thu May 8 18:03:10 2008 UTC revision 1.102, Thu May 8 22:52:30 2008 UTC
# Line 690  Line 690 
690      my ($message) = @_;      my ($message) = @_;
691      # Trace the message.      # Trace the message.
692      Trace($message);      Trace($message);
693        # Check for debug mode.
694        my $debugMode = (exists $Categories{feed} && $TraceLevel > 0);
695      # An error here would be disastrous. Note, however, that we aren't too worried      # An error here would be disastrous. Note, however, that we aren't too worried
696      # about losing events. The error log is always available for the occasions where      # about losing events. The error log is always available for the occasions where
697      # we mess up.      # we mess up. Note that if debug mode is specified, we do this stuff even in a
698        # test environment.
699      eval {      eval {
700          # Do we need to put this in the RSS feed?          # Do we need to put this in the RSS feed?
701          if ($FIG_Config::error_feed && $Destination eq 'WARN') {          if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $debugMode)) {
702              # Yes. We now need to compute the date, the link, and the title.              # Yes. We now need to compute the date, the link, and the title.
703              # First, the date, in a very specific format.              # First, the date, in a very specific format.
704              my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .              my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
705                  (tz_local_offset() / 30);                  (tz_local_offset() / 30);
706              # Environment data goes in here.              Trace("Generating RSS feed. Date = $date.") if $debugMode;
707              my $environment;              # Environment data goes in here. We start with the date.
708              # HTML-escape the message and remove excess space.              my $environment = "$date.  ";
709              my $title = CGI::escapeHTML($message);              # If we need to recap the message (because it's too long to be a title), we'll
710                # put it in here.
711                my $recap;
712                # Copy the message and remove excess space.
713                my $title = $message;
714              $title =~ s/\s+/ /gs;              $title =~ s/\s+/ /gs;
715              # Compute the title from the message. If it's too long, we have to              # If it's too long, we have to split it up.
             # split it up.  
716              if (length $title > 60) {              if (length $title > 60) {
717                    # Put the full message in the environment string.
718                    $recap = $title;
719                    # Excerpt it as the title.
720                  $title = substr($title, 0, 50) . "...";                  $title = substr($title, 0, 50) . "...";
721              }              }
             # We'll put the link in here.  
             my $link;  
722              # If we have a CGI object, then this is a web error. Otherwise, it's              # If we have a CGI object, then this is a web error. Otherwise, it's
723              # command-line.              # command-line.
724              if (defined $SavedCGI) {              if (defined $SavedCGI) {
725                  # 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
726                  # is the URL that got us here.                  # is the URL that got us here.
727                  my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};                  my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
728                  $environment = "Event Reported at IP address $key.";                  $environment .= "Event Reported at IP address $key.";
729                  $link = $SavedCGI->url(-full => 1, -query => 1);                  my $url = $SavedCGI->url(-full => 1, -query => 1);
730                  # We need the user agent string and (if available) the referrer.                  # We need the user agent string and (if available) the referrer.
731                    # The referrer will be the link.
732                  $environment .= "User Agent $ENV{HTTP_USER_AGENT}";                  $environment .= "User Agent $ENV{HTTP_USER_AGENT}";
733                  if ($ENV{HTTP_REFERER}) {                  if ($ENV{HTTP_REFERER}) {
734                      $environment .= " referred from $ENV{HTTP_REFERER}"                      my $link = $ENV{HTTP_REFERER};
735                        $environment .= " referred from <a href=\"$link\">$link</a>.";
736                    } else {
737                        $environment .= " referrer unknown.";
738                  }                  }
739                  # Close off the sentence.                  # Close off the sentence with the original link.
740                  $environment .= ". ";                  $environment .= " URL of error is <a href=\"$url\">$url</a>.";
741              } else {              } else {
742                  # 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
743                  # key and the PID as the user identifier, and add the command.                  # key and the PID as the user identifier, and add the command.
744                  my $key = EmergencyKey();                  my $key = EmergencyKey();
745                  $environment = "Event Reported by $key Process $$. Command $ENV{_}.";                  $environment .= "Event Reported by $key Process $$. Command $ENV{_}.";
                 # Set the link to the development NMPDR. There is really no good  
                 # choice here.  
                 $link = "http://$FIG_Config::dev_server";  
746              }              }
747              # Build a GUID. We use the current time, the title, and the process ID,              # Build a GUID. We use the current time, the title, and the process ID,
748              # then digest the result.              # then digest the result.
749              my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);              my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
750              # Finally, the description. This is a stack trace plus various environmental stuff.              # Finally, the description. This is a stack trace plus various environmental stuff.
             # We have a goofy thing here in that we need to HTML-escape some sections of the description  
             # twice. They will be unescaped once when processed by the RSS reader. First, the stack  
             # trace.  
751              my $stackTrace = "";              my $stackTrace = "";
752              my @trace = LongMess();              my @trace = LongMess();
753              # Only proceed if we got something back.              # Only proceed if we got something back.
# Line 750  Line 755 
755                  $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;                  $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
756                  $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");                  $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
757              }              }
758              my $basicDescription = CGI::escapeHTML($message) . "<br /><br />" .              # We got the stack trace. Now it's time to put it all together.
759                      CGI::escapeHTML($environment) . $stackTrace;              # We have a goofy thing here in that we need to HTML-escape some sections of the description
760                # twice. They will be escaped once here, and then once when written by XML::Simple. They are
761                # unescaped once when processed by the RSS reader, and stuff in the description is treated as
762                # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
763                # our <br>s and <pre>s are used to format the description.
764                $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
765                my $description = "$recap$environment  $stackTrace";
766                Trace("Unescaped description is:\n$description") if $debugMode;
767              # Okay, we have all the pieces. Create a hash of the new event.              # Okay, we have all the pieces. Create a hash of the new event.
768              my $newItem = { title => $title,              my $newItem = { title => $title,
769                              description => CGI::escapeHTML($basicDescription),                              description => $description,
                             link => $link,  
770                              category => $LastCategory,                              category => $LastCategory,
771                              pubDate => $date,                              pubDate => $date,
772                              guid => $guid,                              guid => $guid,
# Line 796  Line 807 
807              }              }
808              # Add our new item at the front.              # Add our new item at the front.
809              unshift @{$items}, $newItem;              unshift @{$items}, $newItem;
810              # Replace the file.              # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
811              my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => 'rss version="2.0"', XmlDecl => '<?xml version="1.0" encoding="utf-8"?>',              # the requirements for those.
812                                            NoEscape => 1);              my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => undef, XmlDecl => '');
813                # Here we put in the root and declaration. The problem is that the root has to have the version attribute
814                # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
815                $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
816              # We don't use Open here because we can't afford an error.              # We don't use Open here because we can't afford an error.
817              if (open XMLOUT, ">$fileName") {              if (open XMLOUT, ">$fileName") {
818                  print XMLOUT $xml;                  print XMLOUT $xml;
# Line 806  Line 820 
820              }              }
821          }          }
822      };      };
823      # There's no "if ($@)" here, because putting an error message in the log      # We only worry about problems in debug mode. The loss of an error message is an annoyance, not a
824      # saying that we missed putting an error message in the feed of messages      # crisis.
825      # in the log is not going to help anybody.      if ($@ && $debugMode) {
826            my $error = $@;
827            Trace("Feed Error: $error");
828        }
829  }  }
830    
831  =head3 Assert  =head3 Assert

Legend:
Removed from v.1.101  
changed lines
  Added in v.1.102

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3