[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.98, Thu May 1 07:52:10 2008 UTC revision 1.102, Thu May 8 22:52:30 2008 UTC
# Line 20  Line 20 
20    
21      require Exporter;      require Exporter;
22      @ISA = ('Exporter');      @ISA = ('Exporter');
23      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency Warn);
24      @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);
25      use strict;      use strict;
26      use Carp qw(longmess croak carp);      use Carp qw(longmess croak carp);
# Line 36  Line 36 
36      use Time::HiRes 'gettimeofday';      use Time::HiRes 'gettimeofday';
37      use URI::Escape;      use URI::Escape;
38      use Time::Local;      use Time::Local;
39        use POSIX qw(strftime);
40        use Time::Zone;
41    
42    
43  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
44    
# Line 204  Line 207 
207  my $LastLevel = 0;          # level of the last test call  my $LastLevel = 0;          # level of the last test call
208  my $SetupCount = 0;         # number of times TSetup called  my $SetupCount = 0;         # number of times TSetup called
209  my $AllTrace = 0;           # TRUE if we are tracing all categories.  my $AllTrace = 0;           # TRUE if we are tracing all categories.
210    my $SavedCGI;               # CGI object passed to ETracing
211    umask 2;                    # Fix the damn umask so everything is group-writable.
212    
213  =head2 Tracing Methods  =head2 Tracing Methods
214    
# Line 553  Line 558 
558          $LastLevel = $traceLevel;          $LastLevel = $traceLevel;
559          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
560          $category = lc $category;          $category = lc $category;
561          # Use the category and tracelevel to compute the result.          # Validate the trace level.
562          if (ref $traceLevel) {          if (ref $traceLevel) {
563              Confess("Bad trace level.");              Confess("Bad trace level.");
564          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
565              Confess("Bad trace config.");              Confess("Bad trace config.");
566          }          }
567          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
568            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
569      }      }
570      # Return the computed result.      # Return the computed result.
571      return $retVal;      return $retVal;
# Line 654  Line 660 
660      croak(">>> $message");      croak(">>> $message");
661  }  }
662    
663    =head3 Warn
664    
665        Warn($message);
666    
667    This method traces an important message. If an RSS feed is configured
668    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
669    then the message will be echoed to the feed. In general, a tracing
670    destination of C<WARN> indicates that the caller is running as a web
671    service in a production environment; however, this is not a requirement.
672    
673    The L</Cluck> method calls this one for its final message. Since
674    L</Confess> calls L</Cluck>, this means that any error which is caught
675    and confessed will put something in the feed. This insures that someone
676    will be alerted relatively quickly when a failure occurs.
677    
678    =over 4
679    
680    =item message
681    
682    Message to be traced.
683    
684    =back
685    
686    =cut
687    
688    sub Warn {
689        # Get the parameters.
690        my ($message) = @_;
691        # Trace the message.
692        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
696        # about losing events. The error log is always available for the occasions where
697        # we mess up. Note that if debug mode is specified, we do this stuff even in a
698        # test environment.
699        eval {
700            # Do we need to put this in the RSS feed?
701            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $debugMode)) {
702                # Yes. We now need to compute the date, the link, and the title.
703                # First, the date, in a very specific format.
704                my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
705                    (tz_local_offset() / 30);
706                Trace("Generating RSS feed. Date = $date.") if $debugMode;
707                # Environment data goes in here. We start with the date.
708                my $environment = "$date.  ";
709                # 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;
715                # If it's too long, we have to split it up.
716                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) . "...";
721                }
722                # If we have a CGI object, then this is a web error. Otherwise, it's
723                # command-line.
724                if (defined $SavedCGI) {
725                    # We're in a web service. The environment is the user's IP, and the link
726                    # is the URL that got us here.
727                    my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
728                    $environment .= "Event Reported at IP address $key.";
729                    my $url = $SavedCGI->url(-full => 1, -query => 1);
730                    # 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}";
733                    if ($ENV{HTTP_REFERER}) {
734                        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 with the original link.
740                    $environment .= " URL of error is <a href=\"$url\">$url</a>.";
741                } else {
742                    # 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.
744                    my $key = EmergencyKey();
745                    $environment .= "Event Reported by $key Process $$. Command $ENV{_}.";
746                }
747                # Build a GUID. We use the current time, the title, and the process ID,
748                # then digest the result.
749                my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
750                # Finally, the description. This is a stack trace plus various environmental stuff.
751                my $stackTrace = "";
752                my @trace = LongMess();
753                # Only proceed if we got something back.
754                if (scalar(@trace) > 0) {
755                    $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
756                    $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
757                }
758                # We got the stack trace. Now it's time to put it all together.
759                # 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.
768                my $newItem = { title => $title,
769                                description => $description,
770                                category => $LastCategory,
771                                pubDate => $date,
772                                guid => $guid,
773                               };
774                # We need XML capability for this.
775                require XML::Simple;
776                # The RSS document goes in here.
777                my $rss;
778                # Get the name of the RSS file. It's in the FIG temporary directory.
779                my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
780                # Does it exist?
781                if (-s $fileName) {
782                    # Slurp it in.
783                    $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
784                } else {
785                    my $size = -s $fileName;
786                    # Create an empty channel.
787                    $rss = {
788                        channel => {
789                            title => 'NMPDR Warning Feed',
790                            link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
791                            description => "Important messages regarding the status of the NMPDR.",
792                            generator => "NMPDR Trace Facility",
793                            docs => "http://blogs.law.harvard.edu/tech/rss",
794                            item => []
795                        },
796                    };
797                }
798                # Get the channel object.
799                my $channel = $rss->{channel};
800                # Update the last-build date.
801                $channel->{lastBuildDate} = $date;
802                # Get the item array.
803                my $items = $channel->{item};
804                # Insure it has only 100 entries.
805                while (scalar @{$items} > 100) {
806                    pop @{$items};
807                }
808                # Add our new item at the front.
809                unshift @{$items}, $newItem;
810                # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
811                # the requirements for those.
812                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.
817                if (open XMLOUT, ">$fileName") {
818                    print XMLOUT $xml;
819                    close XMLOUT;
820                }
821            }
822        };
823        # We only worry about problems in debug mode. The loss of an error message is an annoyance, not a
824        # crisis.
825        if ($@ && $debugMode) {
826            my $error = $@;
827            Trace("Feed Error: $error");
828        }
829    }
830    
831  =head3 Assert  =head3 Assert
832    
833      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 878 
878      my ($message) = @_;      my ($message) = @_;
879      # Trace what's happening.      # Trace what's happening.
880      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
881      my $confession = longmess($message);      # Get the stack trace.
882      # Convert the confession to a series of trace messages.      my @trace = LongMess();
883      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
884          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
885          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
886              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
887              # Trace the line.              # Trace the line.
888              Trace($line);              Trace($line);
889          }          }
890        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
891        Warn($message);
892    }
893    
894    =head3 LongMess
895    
896        my @lines = Tracer::LongMess();
897    
898    Return a stack trace with all tracing methods removed. The return will be in the form of a list
899    of message strings.
900    
901    =cut
902    
903    sub LongMess {
904        # Declare the return variable.
905        my @retVal = ();
906        my $confession = longmess("");
907        for my $line (split /\s*\n/, $confession) {
908            unless ($line =~ /Tracer\.pm/) {
909                # Here we have a line worth keeping. Push it onto the result list.
910                push @retVal, $line;
911      }      }
912  }  }
913        # Return the result.
914        return @retVal;
915    }
916    
917  =head3 ScriptSetup (deprecated)  =head3 ScriptSetup (deprecated)
918    
# Line 790  Line 987 
987      # Get the parameter.      # Get the parameter.
988      my ($parameter) = @_;      my ($parameter) = @_;
989      # Check for CGI mode.      # Check for CGI mode.
990      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
991            $SavedCGI = $parameter;
992        } else {
993            $SavedCGI = undef;
994        }
995      # Default to no tracing except errors.      # Default to no tracing except errors.
996      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
997      # Check for emergency tracing.      # Check for emergency tracing.
# Line 823  Line 1024 
1024              # Set the trace parameter.              # Set the trace parameter.
1025              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1026          }          }
1027      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1028          # There's no emergency tracing, but we have a CGI object, so check          # There's no emergency tracing, but we have a CGI object, so check
1029          # for tracing from the form parameters.          # for tracing from the form parameters.
1030          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1031              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1032              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1033              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1034          }          }
1035      }      }
1036      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1037      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1038      # Check to see if we're a web script.      # Check to see if we're a web script.
1039      if (defined $cgi) {      if (defined $SavedCGI) {
1040          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1041          TraceParms($cgi);          TraceParms($SavedCGI);
1042          # 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
1043          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1044          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1029  Line 1230 
1230      my $retVal;      my $retVal;
1231      # Determine the parameter type.      # Determine the parameter type.
1232      if (! defined $parameter) {      if (! defined $parameter) {
1233          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1234          $retVal = $ENV{TRACING};          # get the effective login ID.
1235            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1236      } else {      } else {
1237          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1238          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3