[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.104, Fri May 9 06:22:49 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    my $CommandLine;            # Command line passed to StandardSetup
212    umask 2;                    # Fix the damn umask so everything is group-writable.
213    
214  =head2 Tracing Methods  =head2 Tracing Methods
215    
# Line 553  Line 559 
559          $LastLevel = $traceLevel;          $LastLevel = $traceLevel;
560          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
561          $category = lc $category;          $category = lc $category;
562          # Use the category and tracelevel to compute the result.          # Validate the trace level.
563          if (ref $traceLevel) {          if (ref $traceLevel) {
564              Confess("Bad trace level.");              Confess("Bad trace level.");
565          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
566              Confess("Bad trace config.");              Confess("Bad trace config.");
567          }          }
568          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
569            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
570      }      }
571      # Return the computed result.      # Return the computed result.
572      return $retVal;      return $retVal;
# Line 654  Line 661 
661      croak(">>> $message");      croak(">>> $message");
662  }  }
663    
664    =head3 Warn
665    
666        Warn($message);
667    
668    This method traces an important message. If an RSS feed is configured
669    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
670    then the message will be echoed to the feed. In general, a tracing
671    destination of C<WARN> indicates that the caller is running as a web
672    service in a production environment; however, this is not a requirement.
673    
674    To force warnings into the RSS feed even when the tracing destination
675    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
676    configured automatically when L</StandardSetup> is used.
677    
678    The L</Cluck> method calls this one for its final message. Since
679    L</Confess> calls L</Cluck>, this means that any error which is caught
680    and confessed will put something in the feed. This insures that someone
681    will be alerted relatively quickly when a failure occurs.
682    
683    =over 4
684    
685    =item message
686    
687    Message to be traced.
688    
689    =back
690    
691    =cut
692    
693    sub Warn {
694        # Get the parameters.
695        my ($message) = @_;
696        # Trace the message.
697        Trace($message);
698        # Check for feed forcing.
699        my $forceFeed = exists $Categories{feed};
700        # An error here would be disastrous. Note, however, that we aren't too worried
701        # about losing events. The error log is always available for the occasions where
702        # we mess up. Note that if debug mode is specified, we do this stuff even in a
703        # test environment.
704        eval {
705            # Do we need to put this in the RSS feed?
706            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
707                # Yes. We now need to compute the date, the link, and the title.
708                # First, the date, in a very specific format.
709                my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
710                    (tz_local_offset() / 30);
711                # Environment data goes in here. We start with the date.
712                my $environment = "$date.  ";
713                # If we need to recap the message (because it's too long to be a title), we'll
714                # put it in here.
715                my $recap;
716                # Copy the message and remove excess space.
717                my $title = $message;
718                $title =~ s/\s+/ /gs;
719                # If it's too long, we have to split it up.
720                if (length $title > 60) {
721                    # Put the full message in the environment string.
722                    $recap = $title;
723                    # Excerpt it as the title.
724                    $title = substr($title, 0, 50) . "...";
725                }
726                # If we have a CGI object, then this is a web error. Otherwise, it's
727                # command-line.
728                if (defined $SavedCGI) {
729                    # We're in a web service. The environment is the user's IP, and the link
730                    # is the URL that got us here.
731                    my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
732                    $environment .= "Event Reported at IP address $key.";
733                    my $url = $SavedCGI->url(-full => 1, -query => 1);
734                    # We need the user agent string and (if available) the referrer.
735                    # The referrer will be the link.
736                    $environment .= "User Agent $ENV{HTTP_USER_AGENT}";
737                    if ($ENV{HTTP_REFERER}) {
738                        my $link = $ENV{HTTP_REFERER};
739                        $environment .= " referred from <a href=\"$link\">$link</a>.";
740                    } else {
741                        $environment .= " referrer unknown.";
742                    }
743                    # Close off the sentence with the original link.
744                    $environment .= " URL of error is <a href=\"$url\">$url</a>.";
745                } else {
746                    # No CGI object, so we're a command-line tool. Use the tracing
747                    # key and the PID as the user identifier, and add the command.
748                    my $key = EmergencyKey();
749                    $environment .= "Event Reported by $key Process $$.";
750                    if ($CommandLine) {
751                        # We're in a StandardSetup script, so we have the real command line.
752                        $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
753                    } elsif ($ENV{_}) {
754                        # We're in a BASH script, so the command has been stored in the _ variable.
755                        $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
756                    }
757                }
758                # Build a GUID. We use the current time, the title, and the process ID,
759                # then digest the result.
760                my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
761                # Finally, the description. This is a stack trace plus various environmental stuff.
762                my $stackTrace = "";
763                my @trace = LongMess();
764                # Only proceed if we got something back.
765                if (scalar(@trace) > 0) {
766                    $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
767                    $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
768                }
769                # We got the stack trace. Now it's time to put it all together.
770                # We have a goofy thing here in that we need to HTML-escape some sections of the description
771                # twice. They will be escaped once here, and then once when written by XML::Simple. They are
772                # unescaped once when processed by the RSS reader, and stuff in the description is treated as
773                # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
774                # our <br>s and <pre>s are used to format the description.
775                $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
776                my $description = "$recap$environment  $stackTrace";
777                # Okay, we have all the pieces. Create a hash of the new event.
778                my $newItem = { title => $title,
779                                description => $description,
780                                category => $LastCategory,
781                                pubDate => $date,
782                                guid => $guid,
783                               };
784                # We need XML capability for this.
785                require XML::Simple;
786                # The RSS document goes in here.
787                my $rss;
788                # Get the name of the RSS file. It's in the FIG temporary directory.
789                my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
790                # Does it exist?
791                if (-s $fileName) {
792                    # Slurp it in.
793                    $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
794                } else {
795                    my $size = -s $fileName;
796                    # Create an empty channel.
797                    $rss = {
798                        channel => {
799                            title => 'NMPDR Warning Feed',
800                            link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
801                            description => "Important messages regarding the status of the NMPDR.",
802                            generator => "NMPDR Trace Facility",
803                            docs => "http://blogs.law.harvard.edu/tech/rss",
804                            item => []
805                        },
806                    };
807                }
808                # Get the channel object.
809                my $channel = $rss->{channel};
810                # Update the last-build date.
811                $channel->{lastBuildDate} = $date;
812                # Get the item array.
813                my $items = $channel->{item};
814                # Insure it has only 100 entries.
815                while (scalar @{$items} > 100) {
816                    pop @{$items};
817                }
818                # Add our new item at the front.
819                unshift @{$items}, $newItem;
820                # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
821                # the requirements for those.
822                my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => undef, XmlDecl => '');
823                # Here we put in the root and declaration. The problem is that the root has to have the version attribute
824                # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
825                $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
826                # We don't use Open here because we can't afford an error.
827                if (open XMLOUT, ">$fileName") {
828                    print XMLOUT $xml;
829                    close XMLOUT;
830                }
831            }
832        };
833        if ($@) {
834            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
835            # (which is a good thing).
836            my $error = $@;
837            Trace("Feed Error: $error") if T(Feed => 0);
838        }
839    }
840    
841  =head3 Assert  =head3 Assert
842    
843      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 888 
888      my ($message) = @_;      my ($message) = @_;
889      # Trace what's happening.      # Trace what's happening.
890      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
891      my $confession = longmess($message);      # Get the stack trace.
892      # Convert the confession to a series of trace messages.      my @trace = LongMess();
893      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
894          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
895          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
896              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
897              # Trace the line.              # Trace the line.
898              Trace($line);              Trace($line);
899          }          }
900        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
901        Warn($message);
902      }      }
903    
904    =head3 LongMess
905    
906        my @lines = Tracer::LongMess();
907    
908    Return a stack trace with all tracing methods removed. The return will be in the form of a list
909    of message strings.
910    
911    =cut
912    
913    sub LongMess {
914        # Declare the return variable.
915        my @retVal = ();
916        my $confession = longmess("");
917        for my $line (split /\s*\n/, $confession) {
918            unless ($line =~ /Tracer\.pm/) {
919                # Here we have a line worth keeping. Push it onto the result list.
920                push @retVal, $line;
921            }
922        }
923        # Return the result.
924        return @retVal;
925  }  }
926    
927  =head3 ScriptSetup (deprecated)  =head3 ScriptSetup (deprecated)
# Line 790  Line 997 
997      # Get the parameter.      # Get the parameter.
998      my ($parameter) = @_;      my ($parameter) = @_;
999      # Check for CGI mode.      # Check for CGI mode.
1000      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
1001            $SavedCGI = $parameter;
1002        } else {
1003            $SavedCGI = undef;
1004        }
1005      # Default to no tracing except errors.      # Default to no tracing except errors.
1006      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
1007      # Check for emergency tracing.      # Check for emergency tracing.
# Line 823  Line 1034 
1034              # Set the trace parameter.              # Set the trace parameter.
1035              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1036          }          }
1037      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1038          # 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
1039          # for tracing from the form parameters.          # for tracing from the form parameters.
1040          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1041              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1042              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1043              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1044          }          }
1045      }      }
1046      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1047      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1048      # Check to see if we're a web script.      # Check to see if we're a web script.
1049      if (defined $cgi) {      if (defined $SavedCGI) {
1050          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1051          TraceParms($cgi);          TraceParms($SavedCGI);
1052          # 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
1053          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1054          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1029  Line 1240 
1240      my $retVal;      my $retVal;
1241      # Determine the parameter type.      # Determine the parameter type.
1242      if (! defined $parameter) {      if (! defined $parameter) {
1243          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1244          $retVal = $ENV{TRACING};          # get the effective login ID.
1245            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1246      } else {      } else {
1247          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1248          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1454  Line 1666 
1666  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
1667  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,
1668  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
1669  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
1670    login ID.
1671    
1672    Since the default situation in StandardSetup is to trace to the standard
1673    output, errors that occur in command-line scripts will not generate
1674    RSS events. To force the events, use the C<warn> option.
1675    
1676        TransactFeatures -background -warn register ../xacts IDs.tbl
1677    
1678  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1679  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 1534  Line 1753 
1753      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1754      # Get the default tracing key.      # Get the default tracing key.
1755      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1756        # Save the command line.
1757        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1758      # Add the tracing options.      # Add the tracing options.
1759      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1760          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
# Line 1542  Line 1763 
1763      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1764      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1765      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1766        $options->{warn} = [0, "send errors to RSS feed"];
1767      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1768      # contains the default values rather than the default value      # contains the default values rather than the default value
1769      # 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 1802 
1802          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1803              push @cats, "SQL";              push @cats, "SQL";
1804          }          }
1805            if ($retOptions->{warn}) {
1806                push @cats, "Feed";
1807            }
1808          # Add the default categories.          # Add the default categories.
1809          push @cats, "Tracer";          push @cats, "Tracer";
1810          # 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.104

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3