[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.103, Fri May 9 04:21:45 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    To force warnings into the RSS feed even when the tracing destination
674    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
675    configured automatically when L</StandardSetup> is used.
676    
677    The L</Cluck> method calls this one for its final message. Since
678    L</Confess> calls L</Cluck>, this means that any error which is caught
679    and confessed will put something in the feed. This insures that someone
680    will be alerted relatively quickly when a failure occurs.
681    
682    =over 4
683    
684    =item message
685    
686    Message to be traced.
687    
688    =back
689    
690    =cut
691    
692    sub Warn {
693        # Get the parameters.
694        my ($message) = @_;
695        # Trace the message.
696        Trace($message);
697        # Check for feed forcing.
698        my $forceFeed = exists $Categories{feed};
699        # An error here would be disastrous. Note, however, that we aren't too worried
700        # about losing events. The error log is always available for the occasions where
701        # we mess up. Note that if debug mode is specified, we do this stuff even in a
702        # test environment.
703        eval {
704            # Do we need to put this in the RSS feed?
705            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
706                # Yes. We now need to compute the date, the link, and the title.
707                # First, the date, in a very specific format.
708                my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
709                    (tz_local_offset() / 30);
710                # Environment data goes in here. We start with the date.
711                my $environment = "$date.  ";
712                # If we need to recap the message (because it's too long to be a title), we'll
713                # put it in here.
714                my $recap;
715                # Copy the message and remove excess space.
716                my $title = $message;
717                $title =~ s/\s+/ /gs;
718                # If it's too long, we have to split it up.
719                if (length $title > 60) {
720                    # Put the full message in the environment string.
721                    $recap = $title;
722                    # Excerpt it as the title.
723                    $title = substr($title, 0, 50) . "...";
724                }
725                # If we have a CGI object, then this is a web error. Otherwise, it's
726                # command-line.
727                if (defined $SavedCGI) {
728                    # We're in a web service. The environment is the user's IP, and the link
729                    # is the URL that got us here.
730                    my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
731                    $environment .= "Event Reported at IP address $key.";
732                    my $url = $SavedCGI->url(-full => 1, -query => 1);
733                    # We need the user agent string and (if available) the referrer.
734                    # The referrer will be the link.
735                    $environment .= "User Agent $ENV{HTTP_USER_AGENT}";
736                    if ($ENV{HTTP_REFERER}) {
737                        my $link = $ENV{HTTP_REFERER};
738                        $environment .= " referred from <a href=\"$link\">$link</a>.";
739                    } else {
740                        $environment .= " referrer unknown.";
741                    }
742                    # Close off the sentence with the original link.
743                    $environment .= " URL of error is <a href=\"$url\">$url</a>.";
744                } else {
745                    # No CGI object, so we're a command-line tool. Use the tracing
746                    # key and the PID as the user identifier, and add the command.
747                    my $key = EmergencyKey();
748                    $environment .= "Event Reported by $key Process $$. Command $ENV{_}.";
749                }
750                # Build a GUID. We use the current time, the title, and the process ID,
751                # then digest the result.
752                my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
753                # Finally, the description. This is a stack trace plus various environmental stuff.
754                my $stackTrace = "";
755                my @trace = LongMess();
756                # Only proceed if we got something back.
757                if (scalar(@trace) > 0) {
758                    $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
759                    $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
760                }
761                # We got the stack trace. Now it's time to put it all together.
762                # We have a goofy thing here in that we need to HTML-escape some sections of the description
763                # twice. They will be escaped once here, and then once when written by XML::Simple. They are
764                # unescaped once when processed by the RSS reader, and stuff in the description is treated as
765                # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
766                # our <br>s and <pre>s are used to format the description.
767                $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
768                my $description = "$recap$environment  $stackTrace";
769                # Okay, we have all the pieces. Create a hash of the new event.
770                my $newItem = { title => $title,
771                                description => $description,
772                                category => $LastCategory,
773                                pubDate => $date,
774                                guid => $guid,
775                               };
776                # We need XML capability for this.
777                require XML::Simple;
778                # The RSS document goes in here.
779                my $rss;
780                # Get the name of the RSS file. It's in the FIG temporary directory.
781                my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
782                # Does it exist?
783                if (-s $fileName) {
784                    # Slurp it in.
785                    $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
786                } else {
787                    my $size = -s $fileName;
788                    # Create an empty channel.
789                    $rss = {
790                        channel => {
791                            title => 'NMPDR Warning Feed',
792                            link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
793                            description => "Important messages regarding the status of the NMPDR.",
794                            generator => "NMPDR Trace Facility",
795                            docs => "http://blogs.law.harvard.edu/tech/rss",
796                            item => []
797                        },
798                    };
799                }
800                # Get the channel object.
801                my $channel = $rss->{channel};
802                # Update the last-build date.
803                $channel->{lastBuildDate} = $date;
804                # Get the item array.
805                my $items = $channel->{item};
806                # Insure it has only 100 entries.
807                while (scalar @{$items} > 100) {
808                    pop @{$items};
809                }
810                # Add our new item at the front.
811                unshift @{$items}, $newItem;
812                # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
813                # the requirements for those.
814                my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => undef, XmlDecl => '');
815                # Here we put in the root and declaration. The problem is that the root has to have the version attribute
816                # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
817                $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
818                # We don't use Open here because we can't afford an error.
819                if (open XMLOUT, ">$fileName") {
820                    print XMLOUT $xml;
821                    close XMLOUT;
822                }
823            }
824        };
825        if ($@) {
826            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
827            # (which is a good thing).
828            my $error = $@;
829            Trace("Feed Error: $error") if T(Feed => 0);
830        }
831    }
832    
833  =head3 Assert  =head3 Assert
834    
835      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 880 
880      my ($message) = @_;      my ($message) = @_;
881      # Trace what's happening.      # Trace what's happening.
882      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
883      my $confession = longmess($message);      # Get the stack trace.
884      # Convert the confession to a series of trace messages.      my @trace = LongMess();
885      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
886          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
887          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
888              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
889              # Trace the line.              # Trace the line.
890              Trace($line);              Trace($line);
891          }          }
892        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
893        Warn($message);
894      }      }
895    
896    =head3 LongMess
897    
898        my @lines = Tracer::LongMess();
899    
900    Return a stack trace with all tracing methods removed. The return will be in the form of a list
901    of message strings.
902    
903    =cut
904    
905    sub LongMess {
906        # Declare the return variable.
907        my @retVal = ();
908        my $confession = longmess("");
909        for my $line (split /\s*\n/, $confession) {
910            unless ($line =~ /Tracer\.pm/) {
911                # Here we have a line worth keeping. Push it onto the result list.
912                push @retVal, $line;
913            }
914        }
915        # Return the result.
916        return @retVal;
917  }  }
918    
919  =head3 ScriptSetup (deprecated)  =head3 ScriptSetup (deprecated)
# Line 790  Line 989 
989      # Get the parameter.      # Get the parameter.
990      my ($parameter) = @_;      my ($parameter) = @_;
991      # Check for CGI mode.      # Check for CGI mode.
992      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
993            $SavedCGI = $parameter;
994        } else {
995            $SavedCGI = undef;
996        }
997      # Default to no tracing except errors.      # Default to no tracing except errors.
998      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
999      # Check for emergency tracing.      # Check for emergency tracing.
# Line 823  Line 1026 
1026              # Set the trace parameter.              # Set the trace parameter.
1027              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1028          }          }
1029      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1030          # 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
1031          # for tracing from the form parameters.          # for tracing from the form parameters.
1032          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1033              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1034              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1035              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1036          }          }
1037      }      }
1038      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1039      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1040      # Check to see if we're a web script.      # Check to see if we're a web script.
1041      if (defined $cgi) {      if (defined $SavedCGI) {
1042          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1043          TraceParms($cgi);          TraceParms($SavedCGI);
1044          # 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
1045          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1046          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1029  Line 1232 
1232      my $retVal;      my $retVal;
1233      # Determine the parameter type.      # Determine the parameter type.
1234      if (! defined $parameter) {      if (! defined $parameter) {
1235          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1236          $retVal = $ENV{TRACING};          # get the effective login ID.
1237            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1238      } else {      } else {
1239          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1240          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1454  Line 1658 
1658  Specifying a value of C<E> for the trace level causes emergency tracing to  Specifying a value of C<E> for the trace level causes emergency tracing to
1659  be used instead of custom tracing. If the user name is not specified,  be used instead of custom tracing. If the user name is not specified,
1660  the tracing key is taken from the C<Tracing> environment variable. If there  the tracing key is taken from the C<Tracing> environment variable. If there
1661  is no value for that variable, the tracing key will be computed from the PID.  is no value for that variable, the tracing key will be computed from the active
1662    login ID.
1663    
1664    Since the default situation in StandardSetup is to trace to the standard
1665    output, errors that occur in command-line scripts will not generate
1666    RSS events. To force the events, use the C<warn> option.
1667    
1668        TransactFeatures -background -warn register ../xacts IDs.tbl
1669    
1670  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1671  names will be traced at level 0 and the program will exit without processing.  names will be traced at level 0 and the program will exit without processing.
# Line 1542  Line 1753 
1753      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1754      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1755      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1756        $options->{warn} = [0, "send errors to RSS feed"];
1757      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1758      # contains the default values rather than the default value      # contains the default values rather than the default value
1759      # and the description. While we're at it, we'll memorize the      # and the description. While we're at it, we'll memorize the
# Line 1580  Line 1792 
1792          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1793              push @cats, "SQL";              push @cats, "SQL";
1794          }          }
1795            if ($retOptions->{warn}) {
1796                push @cats, "Feed";
1797            }
1798          # Add the default categories.          # Add the default categories.
1799          push @cats, "Tracer";          push @cats, "Tracer";
1800          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3