[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.95, Fri Apr 18 18:06:12 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 ScriptSetup ScriptFinish 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);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);
25      use strict;      use strict;
26      use Carp qw(longmess croak);      use Carp qw(longmess croak carp);
27      use CGI;      use CGI;
28      use Cwd;      use Cwd;
29      use FIG_Config;      use FIG_Config;
# 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 160  Line 163 
163    
164  Sometimes, you need a way for tracing to happen automatically without putting parameters  Sometimes, you need a way for tracing to happen automatically without putting parameters
165  in a form or on the command line. Emergency tracing does this. You invoke emergency tracing  in a form or on the command line. Emergency tracing does this. You invoke emergency tracing
166  from the debug form, which is accessed from I<MySeedInstance>C</FIG/Html/SetPassword.html>.  from the debug form, which is accessed from the [[DebugConsole]]. Emergency tracing requires
167  Emergency tracing requires you specify a tracing key. For command-line tools, the key is  that you specify a tracing key. For command-line tools, the key is
168  taken from the C<TRACING> environment variable. For web services, the key is taken from  taken from the C<TRACING> environment variable. For web services, the key is taken from
169  a cookie. Either way, the key tells the tracing facility who you are, so that you control  a cookie. Either way, the key tells the tracing facility who you are, so that you control
170  the tracing in your environment without stepping on other users.  the tracing in your environment without stepping on other users.
# Line 184  Line 187 
187    
188  The web script will look for the tracing key in the cookies, and the command-line  The web script will look for the tracing key in the cookies, and the command-line
189  script will look for it in the C<TRACING> environment variable. If you are  script will look for it in the C<TRACING> environment variable. If you are
190  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing  using the L</StandardSetup> method or a [[WebApplication]], emergency tracing
191  will be configured automatically.  will be configured automatically.
192    
 NOTE: to configure emergency tracing from the command line instead of the Debugging  
 Control Panel (see below), use the C<trace.pl> script.  
   
 =head3 Debugging Control Panel  
   
 The debugging control panel provides several tools to assist in development of  
 SEED and Sprout software. You access the debugging control panel from the URL  
 C</FIG/Html/SetPassword.html> in whichever seed instance you're using. (So,  
 for example, the panel access point for the development NMPDR system is  
 C<http://web-1.nmpdr.org/next/FIG/Html/SetPassword.html>. Contact Bruce to  
 find out what the password is. From this page, you can also specify a tracing  
 key. If you don't specify a key, one will be generated for you.  
   
 =head4 Emergency Tracing Form  
   
 At the bottom of the debugging control panel is a form that allows you to  
 specify a trace level and tracing categories. Special and common categories  
 are listed with check boxes. You can hold your mouse over a check box to see  
 what its category does. In general, however, a category name is the same as  
 the name of the package in which the trace message occurs.  
   
 Additional categories can be entered in an input box, delimited by spaces or commas.  
   
 The B<Activate> button turns on Emergency tracing at the level you specify with the  
 specified categories active. The B<Terminate> button turns tracing off. The  
 B<Show File> button displays the current contents of the trace file. The tracing  
 form at the bottom of the control panel is designed for emergency tracing, so it  
 will only affect programs that call L</ETracing>, L</StandardScript>,  
 or L</StandardSetup>.  
   
 =head4 Script Form  
   
 The top form of the debugging control panel allows you to enter a tiny script and  
 have the output generated in a formatted table. Certain object variables are  
 predefined in the script, including a FIG object (C<$fig>), a CGI object (C<$cgi>),  
 and-- if Sprout is active-- Sprout (C<$sprout>) and SFXlate (C<$sfx>) objects.  
   
 The last line of the script must be a scalar, but it can be a reference to a hash,  
 a list, a list of lists, and various other combinations. If you select the appropriate  
 data type in the dropdown box, the output will be formatted accordingly. The form  
 also has controls for specifying tracing. These controls override any emergency  
 tracing in effect.  
   
 =head4 Database Query Forms  
   
 The forms between the script form and the emergency tracing form allow you to  
 make queries against the database. The FIG query form allows simple queries against  
 a single FIG table. The Sprout query form uses the B<GetAll> method to do a  
 multi-table query against the Sprout database. B<GetAll> is located in the B<ERDB>  
 package, and it takes five parameters.  
   
     GetAll(\@objectNames, $filterClause, \@parameters, \@fields, $count);  
   
 Each of the five parameters corresponds to a text box on the query form:  
   
 =over 4  
   
 =item Objects  
   
 Comma-separated list containing the names of the entity and relationship objects to be retrieved.  
   
 =item Filter  
   
 WHERE/ORDER BY clause (without the WHERE) to be used to filter and sort the query. The WHERE clause can  
 be parameterized with parameter markers (C<?>). Each field used must be specified in the standard form  
 B<I<objectName>(I<fieldName>)> or B<$I<number>(I<fieldName>)> where I<fieldName> is the name of a  
 field, I<objectName> is the name of the entity or relationship object containing the field, and  
 I<number> is the 1-based position of the object in the object list. Any parameters  
 specified in the filter clause should be specified in the B<Params> field.  
 The fields in a filter clause can come from primary entity relations,  
 relationship relations, or secondary entity relations; however, all of the  
 entities and relationships involved must be included in the list of object names.  
   
 =item Params  
   
 List of the parameters to be substituted in for the parameters marks in the filter clause. This  
 is a comma-separated list without any quoting or escaping.  
   
 =item fields  
   
 Comma-separated list of the fields to be returned in each element of the list returned. Fields  
 are specified in the same manner as in the filter clause.  
   
 =item count  
   
 Maximum number of records to return. If omitted or 0, all available records will be returned.  
   
 =back  
   
 B<GetAll> automatically joins together the entities and relationships listed in the object  
 names. This simplifies the coding of the filter clause, but it means that some queries are  
 not possible, since they cannot be expressed in a linear sequence of joins. This is a limitation  
 that has yet to be addressed.  
   
193  =cut  =cut
194    
195  # Declare the configuration variables.  # Declare the configuration variables.
# Line 290  Line 199 
199                              # standard output                              # standard output
200  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
201                              # hash of active category names                              # hash of active category names
202    my @LevelNames = qw(error warn notice info detail);
203  my $TraceLevel = 0;         # trace level; a higher trace level produces more  my $TraceLevel = 0;         # trace level; a higher trace level produces more
204                              # messages                              # messages
205  my @Queue = ();             # queued list of trace messages.  my @Queue = ();             # queued list of trace messages.
206  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
207    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 366  Line 279 
279          }          }
280      }      }
281      # Now we need to process the destination information. The most important special      # Now we need to process the destination information. The most important special
282      # cases are the single ">", which requires we clear the file first, and the      # case is when we're writing to a file. This is indicated by ">" (overwrite) and
283      # "+" prefix which indicates a double echo.      # ">>" (append). A leading "+" for either indicates that we are also writing to
284        # the standard output (tee mode).
285      if ($target =~ m/^\+?>>?/) {      if ($target =~ m/^\+?>>?/) {
286          if ($target =~ m/^\+/) {          if ($target =~ m/^\+/) {
287              $TeeFlag = 1;              $TeeFlag = 1;
288              $target = substr($target, 1);              $target = substr($target, 1);
289          }          }
290          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
291                # We need to initialize the file (which clears it).
292              open TRACEFILE, $target;              open TRACEFILE, $target;
293              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] [notice] [Tracer] Tracing initialized.\n";
294              close TRACEFILE;              close TRACEFILE;
295                # Set to append mode now that the file has been cleared.
296              $Destination = ">$target";              $Destination = ">$target";
297          } else {          } else {
298              $Destination = $target;              $Destination = $target;
# Line 408  Line 324 
324      $TraceLevel = $_[0];      $TraceLevel = $_[0];
325  }  }
326    
327  =head3 ParseTraceDate  =head3 ParseDate
328    
329        my $time = Tracer::ParseDate($dateString);
330    
331      my $time = Tracer::ParseTraceDate($dateString);  Convert a date into a PERL time number. This method expects a date-like string
332    and parses it into a number. The string must be vaguely date-like or it will
333    return an undefined value. Our requirement is that a month and day be
334    present and that three pieces of the date string (time of day, month and day,
335    year) be separated by likely delimiters, such as spaces, commas, and such-like.
336    
337  Convert a date from the trace file into a PERL timestamp.  If a time of day is present, it must be in military time with two digits for
338    everything but the hour.
339    
340    The year must be exactly four digits.
341    
342    Additional stuff can be in the string. We presume it's time zones or weekdays or something
343    equally innocuous. This means, however, that a sufficiently long sentence with date-like
344    parts in it may be interpreted as a date. Hopefully this will not be a problem.
345    
346    It should be guaranteed that this method will parse the output of the L</Now> function.
347    
348    The parameters are as follows.
349    
350  =over 4  =over 4
351    
352  =item dateString  =item dateString
353    
354  The date string from the trace file. The format of the string is determined by the  The date string to convert.
 L</Now> method.  
355    
356  =item RETURN  =item RETURN
357    
358  Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if  Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if
359  the time string is invalid.  the date string is invalid. A valid date string must contain a month and day.
360    
361  =back  =back
362    
363  =cut  =cut
364    
365  sub ParseTraceDate {  # Universal month conversion table.
366    use constant MONTHS => {    Jan =>  0, January   =>  0, '01' =>  0,  '1' =>  0,
367                                Feb =>  1, February  =>  1, '02' =>  1,  '2' =>  1,
368                                Mar =>  2, March     =>  2, '03' =>  2,  '3' =>  2,
369                                Apr =>  3, April     =>  3, '04' =>  3,  '4' =>  3,
370                                May =>  4, May       =>  4, '05' =>  4,  '5' =>  4,
371                                Jun =>  5, June      =>  5, '06' =>  5,  '6' =>  5,
372                                Jul =>  6, July      =>  6, '07' =>  6,  '7' =>  6,
373                                Aug =>  7, August    =>  7, '08' =>  7,  '8' =>  7,
374                                Sep =>  8, September =>  8, '09' =>  8,  '9' =>  8,
375                                Oct =>  9, October  =>   9, '10' =>  9,
376                                Nov => 10, November =>  10, '11' => 10,
377                                Dec => 11, December =>  11, '12' => 11
378                            };
379    
380    sub ParseDate {
381      # Get the parameters.      # Get the parameters.
382      my ($dateString) = @_;      my ($dateString) = @_;
383      # Declare the return variable.      # Declare the return variable.
384      my $retVal;      my $retVal;
385      # Parse the date.      # Find the month and day of month. There are two ways that can happen. We check for the
386      if ($dateString =~ m#(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)#) {      # numeric style first. That way, if the user's done something like "Sun 12/22", then we
387          # Create a time object. Note we need to convert the day, month,      # won't be fooled into thinking the month is Sunday.
388          # and year to a different base. Years count from 1900, and      if ($dateString =~ m#\b(\d{1,2})/(\d{1,2})\b# || $dateString =~ m#\b(\w+)\s(\d{1,2})\b#) {
389          # the internal month value is relocated to January = 0.          my ($mon, $mday) = (MONTHS->{$1}, $2);
390          $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);          # Insist that the month and day are valid.
391            if (defined($mon) && $2 >= 1 && $2 <= 31) {
392                # Find the time.
393                my ($hour, $min, $sec) = (0, 0, 0);
394                if ($dateString =~ /\b(\d{1,2}):(\d{2}):(\d{2})\b/) {
395                    ($hour, $min, $sec) = ($1, $2, $3);
396                }
397                # Find the year.
398                my $year;
399                if ($dateString =~ /\b(\d{4})\b/) {
400                    $year = $1;
401                } else {
402                    # Get the default year, which is this one. Note we must convert it to
403                    # the four-digit value expected by "timelocal".
404                    (undef, undef, undef, undef, undef, $year) = localtime();
405                    $year += 1900;
406                }
407                $retVal = timelocal($sec, $min, $hour, $mday, $mon, $year);
408            }
409      }      }
410      # Return the result.      # Return the result.
411      return $retVal;      return $retVal;
# Line 489  Line 454 
454  sub Trace {  sub Trace {
455      # Get the parameters.      # Get the parameters.
456      my ($message) = @_;      my ($message) = @_;
457        # Strip off any line terminators at the end of the message. We will add
458        # new-line stuff ourselves.
459        my $stripped = Strip($message);
460        # Compute the caller information.
461        my ($callPackage, $callFile, $callLine) = caller();
462        my $callFileTitle = basename($callFile);
463        # Check the caller.
464        my $callerInfo = ($callFileTitle ne "Tracer.pm" ? " [$callFileTitle $callLine]" : "");
465      # Get the timestamp.      # Get the timestamp.
466      my $timeStamp = Now();      my $timeStamp = Now();
467      # Format the message. Note we strip off any line terminators at the end.      # Build the prefix.
468      my $prefix = "[$timeStamp] <$LastCategory>: ";      my $level = $LevelNames[$LastLevel] || "($LastLevel)";
469      my $formatted = $prefix . Strip($message);      my $prefix = "[$timeStamp] [$level] [$LastCategory]$callerInfo";
470        # Format the message.
471        my $formatted = "$prefix $stripped";
472      # Process according to the destination.      # Process according to the destination.
473      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
474          # Write the message to the standard output.          # Write the message to the standard output.
475          print "$formatted\n";          print "$formatted\n";
476      } elsif ($Destination eq "ERROR") {      } elsif ($Destination eq "ERROR") {
477          # Write the message to the error output.          # Write the message to the error output. Here, we want our prefix fields.
478          print STDERR "$formatted\n";          print STDERR "$formatted\n";
479        } elsif ($Destination eq "WARN") {
480            # Emit the message to the standard error output. It is presumed that the
481            # error logger will add its own prefix fields, the notable exception being
482            # the caller info.
483            print STDERR "$callerInfo$stripped\n";
484      } elsif ($Destination eq "QUEUE") {      } elsif ($Destination eq "QUEUE") {
485          # Push the message into the queue.          # Push the message into the queue.
486          push @Queue, "$formatted";          push @Queue, "$formatted";
487      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
488          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML and write it to the standard output.
489          my $escapedMessage = CGI::escapeHTML($message);          my $escapedMessage = CGI::escapeHTML($stripped);
490          print "<p>$timeStamp $LastCategory: $escapedMessage</p>\n";          print "<p>$timeStamp $LastCategory $LastLevel: $escapedMessage</p>\n";
     } elsif ($Destination eq "WARN") {  
        # Emit the message as a warning.  
        carp $message;  
491      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
492          # Write the trace message to an output file.          # Write the trace message to an output file.
493          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
494          print TRACING "$formatted\n";          print TRACING "$formatted\n";
495          close TRACING;          close TRACING;
496          # If the Tee flag is on, echo it to the standard output.          # If the Tee flag is on, echo it to the standard output.
# Line 576  Line 553 
553                  $category = $cats[$#cats];                  $category = $cats[$#cats];
554              }              }
555          }          }
556          # Save the category name.          # Save the category name and level.
557          $LastCategory = $category;          $LastCategory = $category;
558            $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 660  Line 639 
639  sub Confess {  sub Confess {
640      # Get the parameters.      # Get the parameters.
641      my ($message) = @_;      my ($message) = @_;
642        # Set up the category and level.
643        $LastCategory = "(confess)";
644        $LastLevel = 0;
645      if (! defined($FIG_Config::no_tool_hdr)) {      if (! defined($FIG_Config::no_tool_hdr)) {
646          # Here we have a tool header. Display its length so that the user can adjust the line numbers.          # Here we have a tool header. Display its length so that the user can adjust the line numbers.
647          my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";          my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";
648          # Only proceed if the tool header file is actually present.          # Only proceed if the tool header file is actually present.
649          if (-f $toolHeaderFile) {          if (-f $toolHeaderFile) {
650              my @lines = GetFile($toolHeaderFile);              my $fh;
651                if (open $fh, "<$toolHeaderFile") {
652                    my @lines = <$fh>;
653              Trace("Tool header has " . scalar(@lines) . " lines.");              Trace("Tool header has " . scalar(@lines) . " lines.");
654          }          }
655      }      }
656        }
657      # Trace the call stack.      # Trace the call stack.
658      Cluck($message);      Cluck($message);
659      # Abort the program.      # Abort the program.
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 725  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. Note we skip any      my @trace = LongMess();
866      # messages relating to calls into Tracer.      # Convert the trace to a series of messages.
867        for my $line (@trace) {
868            # Replace the tab at the beginning with spaces.
869            $line =~ s/^\t/    /;
870            # Trace the line.
871            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) {      for my $line (split /\s*\n/, $confession) {
891          Trace($line) if ($line !~ /Tracer\.pm/);          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  =head3 ScriptSetup (deprecated)
901    
902      my ($cgi, $varHash) = ScriptSetup($noTrace);      my ($cgi, $varHash) = ScriptSetup($noTrace);
903    
# Line 806  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 839  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 958  Line 1126 
1126          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
1127      } elsif ($myDest eq 'DUAL') {      } elsif ($myDest eq 'DUAL') {
1128          $retVal = "+>" . EmergencyFileTarget($tkey);          $retVal = "+>" . EmergencyFileTarget($tkey);
1129        } elsif ($myDest eq 'WARN') {
1130            $retVal = "WARN";
1131      }      }
1132      # Return the result.      # Return the result.
1133      return $retVal;      return $retVal;
# Line 1043  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') {
# Line 1086  Line 1257 
1257      my ($cgi) = @_;      my ($cgi) = @_;
1258      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1259          # Here we trace the GET-style URL for the script.          # Here we trace the GET-style URL for the script.
1260          Trace("URL: " . $cgi->url(-relative => 1, -query => 1));          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));
1261      }      }
1262      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1263          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1095  Line 1266 
1266              # Note we skip the Trace parameters, which are for our use only.              # Note we skip the Trace parameters, which are for our use only.
1267              if ($parmName ne 'Trace' && $parmName ne 'TF') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
1268                  my @values = $cgi->param($parmName);                  my @values = $cgi->param($parmName);
1269                  Trace("CGI: $parmName = " . join(", ", @values));                  Trace("[CGI] $parmName = " . join(", ", @values));
1270              }              }
1271          }          }
1272          # Display the request method.          # Display the request method.
# Line 1105  Line 1276 
1276      if (T(CGI => 4)) {      if (T(CGI => 4)) {
1277          # Here we want the environment data too.          # Here we want the environment data too.
1278          for my $envName (sort keys %ENV) {          for my $envName (sort keys %ENV) {
1279              Trace("ENV: $envName = $ENV{$envName}");              Trace("[ENV] $envName = $ENV{$envName}");
1280          }          }
1281      }      }
1282  }  }
# Line 1162  Line 1333 
1333  }  }
1334    
1335    
1336  =head3 ScriptFinish  =head3 ScriptFinish (deprecated)
1337    
1338      ScriptFinish($webData, $varHash);      ScriptFinish($webData, $varHash);
1339    
# Line 1620  Line 1791 
1791              # Close the test file.              # Close the test file.
1792              close TESTTRACE;              close TESTTRACE;
1793          } else {          } else {
1794              # Here we can't trace to a file. We trace to the standard output if it's              # Here we can't trace to a file. Complain about this.
1795                warn "Could not open trace file $traceFileName: $!\n";
1796                # We trace to the standard output if it's
1797              # okay, and the error log otherwise.              # okay, and the error log otherwise.
1798              if ($textOKFlag) {              if ($textOKFlag) {
1799                  $traceMode = "TEXT";                  $traceMode = "TEXT";
# Line 2584  Line 2757 
2757  }  }
2758    
2759    
2760    =head3 PrintLine
2761    
2762        Tracer::PrintLine($line);
2763    
2764    Print a line of text with a trailing new-line.
2765    
2766    =over 4
2767    
2768    =item line
2769    
2770    Line of text to print.
2771    
2772    =back
2773    
2774    =cut
2775    
2776    sub PrintLine {
2777        # Get the parameters.
2778        my ($line) = @_;
2779        # Print the line.
2780        print "$line\n";
2781    }
2782    
2783    
2784  =head2 Other Useful Methods  =head2 Other Useful Methods
2785    
# Line 2624  Line 2820 
2820      return $retVal;      return $retVal;
2821  }  }
2822    
   
   
   
2823  =head3 Now  =head3 Now
2824    
2825      my $string = Tracer::Now();      my $string = Tracer::Now();
2826    
2827  Return a displayable time stamp containing the local time.  Return a displayable time stamp containing the local time. Whatever format this
2828    method produces must be parseable by L</ParseDate>.
2829    
2830  =cut  =cut
2831    
2832  sub Now {  sub Now {
2833      my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);      return DisplayTime(time);
2834      my $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .  }
2835    
2836    =head3 DisplayTime
2837    
2838        my $string = Tracer::DisplayTime($time);
2839    
2840    Convert a time value to a displayable time stamp. Whatever format this
2841    method produces must be parseable by L</ParseDate>.
2842    
2843    =over 4
2844    
2845    =item time
2846    
2847    Time to display, in seconds since the epoch, or C<undef> if the time is unknown.
2848    
2849    =item RETURN
2850    
2851    Returns a displayable time, or C<(n/a)> if the incoming time is undefined.
2852    
2853    =back
2854    
2855    =cut
2856    
2857    sub DisplayTime {
2858        my ($time) = @_;
2859        my $retVal = "(n/a)";
2860        if (defined $time) {
2861            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
2862            $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .
2863                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);
2864        }
2865      return $retVal;      return $retVal;
2866  }  }
2867    
# Line 2802  Line 3025 
3025      return $retVal;      return $retVal;
3026  }  }
3027    
3028    =head3 Constrain
3029    
3030        my $constrained = Constrain($value, $min, $max);
3031    
3032    Modify a numeric value to bring it to a point in between a maximum and a minimum.
3033    
3034    =over 4
3035    
3036    =item value
3037    
3038    Value to constrain.
3039    
3040    =item min (optional)
3041    
3042    Minimum permissible value. If this parameter is undefined, no minimum constraint will be applied.
3043    
3044    =item max (optional)
3045    
3046    Maximum permissible value. If this parameter is undefined, no maximum constraint will be applied.
3047    
3048    =item RETURN
3049    
3050    Returns the incoming value, constrained according to the other parameters.
3051    
3052    =back
3053    
3054    =cut
3055    
3056    sub Constrain {
3057        # Get the parameters.
3058        my ($value, $min, $max) = @_;
3059        # Declare the return variable.
3060        my $retVal = $value;
3061        # Apply the minimum constraint.
3062        if (defined $min && $retVal < $min) {
3063            $retVal = $min;
3064        }
3065        # Apply the maximum constraint.
3066        if (defined $max && $retVal > $max) {
3067            $retVal = $max;
3068        }
3069        # Return the result.
3070        return $retVal;
3071    }
3072    
3073  =head3 Min  =head3 Min
3074    
3075      my $min = Min($value1, $value2, ... $valueN);      my $min = Min($value1, $value2, ... $valueN);
# Line 2868  Line 3136 
3136      return $retVal;      return $retVal;
3137  }  }
3138    
 =head3 DebugMode  
   
     if (Tracer::DebugMode) { ...code... }  
   
 Return TRUE if debug mode has been turned on, else abort.  
   
 Certain CGI scripts are too dangerous to exist in the production  
 environment. This method provides a simple way to prevent them  
 from working unless they are explicitly turned on by creating a password  
 cookie via the B<SetPassword> script.  If debugging mode  
 is not turned on, an error will occur.  
   
 =cut  
   
 sub DebugMode {  
     # Declare the return variable.  
     my $retVal = 0;  
     # Check the debug configuration.  
     my $password = CGI::cookie("DebugMode");  
     my $encrypted = Digest::MD5::md5_hex($password);  
     if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {  
         $retVal = 1;  
     } else {  
         # Here debug mode is off, so we generate an error.  
         Confess("Cannot use this facility without logging in.");  
     }  
     # Return the determination indicator.  
     return $retVal;  
 }  
3139    
3140  =head3 Strip  =head3 Strip
3141    
# Line 3340  Line 3579 
3579  }  }
3580    
3581    
3582    =head3 TrackingCode
3583    
3584        my $html = Tracer::TrackingCode();
3585    
3586    Returns the HTML code for doing web page traffic monitoring. If the
3587    current environment is a test system, then it returns a null string;
3588    otherwise, it returns a bunch of javascript containing code for turning
3589    on SiteMeter and Google Analytics.
3590    
3591    =cut
3592    
3593    sub TrackingCode {
3594        # Declare the return variable.
3595        my $retVal = "<!-- tracking off -->";
3596        # Determine if we're in production.
3597        if ($FIG_Config::site_meter) {
3598            $retVal = <<END_HTML
3599            <!-- Site Meter -->
3600            <script type="text/javascript" src="http://s20.sitemeter.com/js/counter.js?site=s20nmpdr">
3601            </script>
3602            <noscript>
3603            <a href="http://s20.sitemeter.com/stats.asp?site=s20nmpdr" target="_top">
3604            <img src="http://s20.sitemeter.com/meter.asp?site=s20nmpdr" alt="Site Meter" border="0"/></a>
3605            </noscript>
3606            <!-- Copyright (c)2006 Site Meter -->
3607    END_HTML
3608        }
3609        return $retVal;
3610    }
3611    
3612    
3613  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3