[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.99, Wed May 7 23:00:16 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 654  Line 659 
659      croak(">>> $message");      croak(">>> $message");
660  }  }
661    
662    =head3 Warn
663    
664        Warn($message);
665    
666    This method traces an important message. If an RSS feed is configured
667    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
668    then the message will be echoed to the feed. In general, a tracing
669    destination of C<WARN> indicates that the caller is running as a web
670    service in a production environment; however, this is not a requirement.
671    
672    The L</Cluck> method calls this one for its final message. Since
673    L</Confess> calls L</Cluck>, this means that any error which is caught
674    and confessed will put something in the feed. This insures that someone
675    will be alerted relatively quickly when a failure occurs.
676    
677    =over 4
678    
679    =item message
680    
681    Message to be traced.
682    
683    =back
684    
685    =cut
686    
687    sub Warn {
688        # Get the parameters.
689        my ($message) = @_;
690        # Trace the message.
691        Trace($message);
692        # An error here would be disastrous. Note, however, that we aren't too worried
693        # about losing events. The error log is always available for the occasions where
694        # we mess up.
695        eval {
696            # Do we need to put this in the RSS feed?
697            if ($FIG_Config::error_feed && $Destination eq 'WARN') {
698                # Yes. We now need to compute the date, the link, and the title.
699                # First, the date, in a very specific format.
700                my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
701                    (tz_local_offset() / 30);
702                # We'll put the link and title in here.
703                my ($link, $title);
704                # Environment data goes in here.
705                my $environment;
706                # HTML-escape the message.
707                my $escaped = CGI::escapeHTML($message);
708                # If we have a CGI object, then this is a web error. Otherwise, it's
709                # command-line.
710                if (defined $SavedCGI) {
711                    # We're in a web service. The title is the user's IP, and the link
712                    # is the URL that got us here.
713                    my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
714                    $title = "Event Reported at IP address $key: $escaped";
715                    $link = $SavedCGI->url(-full => 1, -query => 1);
716                    # We need the user agent string.
717                    $environment = "User Agent $ENV{HTTP_USER_AGENT}."
718                } else {
719                    # No CGI object, so we're a command-line tool. Use the tracing
720                    # key and the PID as the user identifier.
721                    my $key = EmergencyKey();
722                    $title = "Event Reported by $key Process $$: $escaped";
723                    # Set the link to the development NMPDR. There is really no good
724                    # choice here.
725                    $link = "http://$FIG_Config::dev_server";
726                    # We need the command
727                    $environment = "Command $ENV{_}.";
728                }
729                # Build a GUID. We use the current time, the title, and the process ID,
730                # then digest the result.
731                my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
732                # Finally, the description. This is a stack trace plus various environmental stuff.
733                my @trace = LongMess();
734                my $trace = join "; ", @trace;
735                my $description = CGI::escapeHTML("$environment Stack trace: $trace");
736                # Okay, we have all the pieces. Create a hash of the new event.
737                my $newItem = { title => $title,
738                                description => $description,
739                                link => $link,
740                                category => $LastCategory,
741                                pubDate => $date,
742                                guid => $guid,
743                               };
744                # We need XML capability for this.
745                require XML::Simple;
746                # The RSS document goes in here.
747                my $rss;
748                # Get the name of the RSS file. It's in the FIG temporary directory.
749                my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
750                # Does it exist?
751                if (-s $fileName) {
752                    # Slurp it in.
753                    $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
754                } else {
755                    my $size = -s $fileName;
756                    # Create an empty channel.
757                    $rss = {
758                        channel => {
759                            title => 'NMPDR Warning Feed',
760                            link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
761                            description => "Important messages regarding the status of the NMPDR.",
762                            generator => "NMPDR Trace Facility",
763                            docs => "http://blogs.law.harvard.edu/tech/rss",
764                            item => []
765                        },
766                    };
767                }
768                # Get the channel object.
769                my $channel = $rss->{channel};
770                # Update the last-build date.
771                $channel->{lastBuildDate} = $date;
772                # Get the item array.
773                my $items = $channel->{item};
774                # Insure it has only 100 entries.
775                while (scalar @{$items} > 100) {
776                    pop @{$items};
777                }
778                # Add our new item at the front.
779                unshift @{$items}, $newItem;
780                # Replace the file.
781                my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => 'rss', XmlDecl => '<?xml version="1.0" encoding="utf-8"?>',
782                                              NoEscape => 1);
783                # We don't use Open here because we can't afford an error.
784                if (open XMLOUT, ">$fileName") {
785                    print XMLOUT $xml;
786                    close XMLOUT;
787                }
788            }
789        };
790        # There's no "if ($@)" here, because putting an error message in the log
791        # saying that we missed putting an error message in the feed of messages
792        # in the log is not going to help anybody.
793    }
794    
795  =head3 Assert  =head3 Assert
796    
797      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 842 
842      my ($message) = @_;      my ($message) = @_;
843      # Trace what's happening.      # Trace what's happening.
844      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
845      my $confession = longmess($message);      # Get the stack trace.
846      # Convert the confession to a series of trace messages.      my @trace = LongMess();
847      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
848          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
849          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
850              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
851              # Trace the line.              # Trace the line.
852              Trace($line);              Trace($line);
853          }          }
854        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
855        Warn($message);
856    }
857    
858    =head3 LongMess
859    
860        my @lines = Tracer::LongMess();
861    
862    Return a stack trace with all tracing methods removed. The return will be in the form of a list
863    of message strings.
864    
865    =cut
866    
867    sub LongMess {
868        # Declare the return variable.
869        my @retVal = ();
870        my $confession = longmess("");
871        for my $line (split /\s*\n/, $confession) {
872            unless ($line =~ /Tracer\.pm/) {
873                # Here we have a line worth keeping. Push it onto the result list.
874                push @retVal, $line;
875      }      }
876  }  }
877        # Return the result.
878        return @retVal;
879    }
880    
881  =head3 ScriptSetup (deprecated)  =head3 ScriptSetup (deprecated)
882    
# Line 790  Line 951 
951      # Get the parameter.      # Get the parameter.
952      my ($parameter) = @_;      my ($parameter) = @_;
953      # Check for CGI mode.      # Check for CGI mode.
954      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
955            $SavedCGI = $parameter;
956        } else {
957            $SavedCGI = undef;
958        }
959      # Default to no tracing except errors.      # Default to no tracing except errors.
960      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
961      # Check for emergency tracing.      # Check for emergency tracing.
# Line 823  Line 988 
988              # Set the trace parameter.              # Set the trace parameter.
989              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
990          }          }
991      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
992          # 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
993          # for tracing from the form parameters.          # for tracing from the form parameters.
994          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
995              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
996              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
997              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
998          }          }
999      }      }
1000      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1001      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1002      # Check to see if we're a web script.      # Check to see if we're a web script.
1003      if (defined $cgi) {      if (defined $SavedCGI) {
1004          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1005          TraceParms($cgi);          TraceParms($SavedCGI);
1006          # 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
1007          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1008          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1029  Line 1194 
1194      my $retVal;      my $retVal;
1195      # Determine the parameter type.      # Determine the parameter type.
1196      if (! defined $parameter) {      if (! defined $parameter) {
1197          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1198          $retVal = $ENV{TRACING};          # get the effective login ID.
1199            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1200      } else {      } else {
1201          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1202          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3