[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.101, Thu May 8 18:03:10 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        # An error here would be disastrous. Note, however, that we aren't too worried
694        # about losing events. The error log is always available for the occasions where
695        # we mess up.
696        eval {
697            # Do we need to put this in the RSS feed?
698            if ($FIG_Config::error_feed && $Destination eq 'WARN') {
699                # Yes. We now need to compute the date, the link, and the title.
700                # First, the date, in a very specific format.
701                my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
702                    (tz_local_offset() / 30);
703                # Environment data goes in here.
704                my $environment;
705                # HTML-escape the message and remove excess space.
706                my $title = CGI::escapeHTML($message);
707                $title =~ s/\s+/ /gs;
708                # Compute the title from the message. If it's too long, we have to
709                # split it up.
710                if (length $title > 60) {
711                    $title = substr($title, 0, 50) . "...";
712                }
713                # We'll put the link in here.
714                my $link;
715                # If we have a CGI object, then this is a web error. Otherwise, it's
716                # command-line.
717                if (defined $SavedCGI) {
718                    # We're in a web service. The environment is the user's IP, and the link
719                    # is the URL that got us here.
720                    my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
721                    $environment = "Event Reported at IP address $key.";
722                    $link = $SavedCGI->url(-full => 1, -query => 1);
723                    # We need the user agent string and (if available) the referrer.
724                    $environment .= "User Agent $ENV{HTTP_USER_AGENT}";
725                    if ($ENV{HTTP_REFERER}) {
726                        $environment .= " referred from $ENV{HTTP_REFERER}"
727                    }
728                    # Close off the sentence.
729                    $environment .= ". ";
730                } else {
731                    # No CGI object, so we're a command-line tool. Use the tracing
732                    # key and the PID as the user identifier, and add the command.
733                    my $key = EmergencyKey();
734                    $environment = "Event Reported by $key Process $$. Command $ENV{_}.";
735                    # Set the link to the development NMPDR. There is really no good
736                    # choice here.
737                    $link = "http://$FIG_Config::dev_server";
738                }
739                # Build a GUID. We use the current time, the title, and the process ID,
740                # then digest the result.
741                my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
742                # Finally, the description. This is a stack trace plus various environmental stuff.
743                # We have a goofy thing here in that we need to HTML-escape some sections of the description
744                # twice. They will be unescaped once when processed by the RSS reader. First, the stack
745                # trace.
746                my $stackTrace = "";
747                my @trace = LongMess();
748                # Only proceed if we got something back.
749                if (scalar(@trace) > 0) {
750                    $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
751                    $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
752                }
753                my $basicDescription = CGI::escapeHTML($message) . "<br /><br />" .
754                        CGI::escapeHTML($environment) . $stackTrace;
755                # Okay, we have all the pieces. Create a hash of the new event.
756                my $newItem = { title => $title,
757                                description => CGI::escapeHTML($basicDescription),
758                                link => $link,
759                                category => $LastCategory,
760                                pubDate => $date,
761                                guid => $guid,
762                               };
763                # We need XML capability for this.
764                require XML::Simple;
765                # The RSS document goes in here.
766                my $rss;
767                # Get the name of the RSS file. It's in the FIG temporary directory.
768                my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
769                # Does it exist?
770                if (-s $fileName) {
771                    # Slurp it in.
772                    $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
773                } else {
774                    my $size = -s $fileName;
775                    # Create an empty channel.
776                    $rss = {
777                        channel => {
778                            title => 'NMPDR Warning Feed',
779                            link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
780                            description => "Important messages regarding the status of the NMPDR.",
781                            generator => "NMPDR Trace Facility",
782                            docs => "http://blogs.law.harvard.edu/tech/rss",
783                            item => []
784                        },
785                    };
786                }
787                # Get the channel object.
788                my $channel = $rss->{channel};
789                # Update the last-build date.
790                $channel->{lastBuildDate} = $date;
791                # Get the item array.
792                my $items = $channel->{item};
793                # Insure it has only 100 entries.
794                while (scalar @{$items} > 100) {
795                    pop @{$items};
796                }
797                # Add our new item at the front.
798                unshift @{$items}, $newItem;
799                # Replace the file.
800                my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => 'rss version="2.0"', XmlDecl => '<?xml version="1.0" encoding="utf-8"?>',
801                                              NoEscape => 1);
802                # We don't use Open here because we can't afford an error.
803                if (open XMLOUT, ">$fileName") {
804                    print XMLOUT $xml;
805                    close XMLOUT;
806                }
807            }
808        };
809        # There's no "if ($@)" here, because putting an error message in the log
810        # saying that we missed putting an error message in the feed of messages
811        # in the log is not going to help anybody.
812    }
813    
814  =head3 Assert  =head3 Assert
815    
816      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 861 
861      my ($message) = @_;      my ($message) = @_;
862      # Trace what's happening.      # Trace what's happening.
863      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
864      my $confession = longmess($message);      # Get the stack trace.
865      # Convert the confession to a series of trace messages.      my @trace = LongMess();
866      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
867          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
868          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
869              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
870              # Trace the line.              # Trace the line.
871              Trace($line);              Trace($line);
872          }          }
873        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
874        Warn($message);
875    }
876    
877    =head3 LongMess
878    
879        my @lines = Tracer::LongMess();
880    
881    Return a stack trace with all tracing methods removed. The return will be in the form of a list
882    of message strings.
883    
884    =cut
885    
886    sub LongMess {
887        # Declare the return variable.
888        my @retVal = ();
889        my $confession = longmess("");
890        for my $line (split /\s*\n/, $confession) {
891            unless ($line =~ /Tracer\.pm/) {
892                # Here we have a line worth keeping. Push it onto the result list.
893                push @retVal, $line;
894      }      }
895  }  }
896        # Return the result.
897        return @retVal;
898    }
899    
900  =head3 ScriptSetup (deprecated)  =head3 ScriptSetup (deprecated)
901    
# Line 790  Line 970 
970      # Get the parameter.      # Get the parameter.
971      my ($parameter) = @_;      my ($parameter) = @_;
972      # Check for CGI mode.      # Check for CGI mode.
973      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
974            $SavedCGI = $parameter;
975        } else {
976            $SavedCGI = undef;
977        }
978      # Default to no tracing except errors.      # Default to no tracing except errors.
979      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
980      # Check for emergency tracing.      # Check for emergency tracing.
# Line 823  Line 1007 
1007              # Set the trace parameter.              # Set the trace parameter.
1008              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1009          }          }
1010      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1011          # 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
1012          # for tracing from the form parameters.          # for tracing from the form parameters.
1013          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1014              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1015              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1016              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1017          }          }
1018      }      }
1019      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1020      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1021      # Check to see if we're a web script.      # Check to see if we're a web script.
1022      if (defined $cgi) {      if (defined $SavedCGI) {
1023          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1024          TraceParms($cgi);          TraceParms($SavedCGI);
1025          # 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
1026          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1027          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1029  Line 1213 
1213      my $retVal;      my $retVal;
1214      # Determine the parameter type.      # Determine the parameter type.
1215      if (! defined $parameter) {      if (! defined $parameter) {
1216          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1217          $retVal = $ENV{TRACING};          # get the effective login ID.
1218            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1219      } else {      } else {
1220          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1221          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3