[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.109, Tue Sep 23 15:33:54 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        use Fcntl ':flock';
42    
43    
44  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
45    
# Line 160  Line 164 
164    
165  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
166  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
167  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
168  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
169  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
170  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
171  the tracing in your environment without stepping on other users.  the tracing in your environment without stepping on other users.
# Line 184  Line 188 
188    
189  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
190  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
191  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing  using the L</StandardSetup> method or a [[WebApplication]], emergency tracing
192  will be configured automatically.  will be configured automatically.
193    
 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.  
   
194  =cut  =cut
195    
196  # Declare the configuration variables.  # Declare the configuration variables.
# Line 290  Line 200 
200                              # standard output                              # standard output
201  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
202                              # hash of active category names                              # hash of active category names
203    my @LevelNames = qw(error warn notice info detail);
204  my $TraceLevel = 0;         # trace level; a higher trace level produces more  my $TraceLevel = 0;         # trace level; a higher trace level produces more
205                              # messages                              # messages
206  my @Queue = ();             # queued list of trace messages.  my @Queue = ();             # queued list of trace messages.
207  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
208    my $LastLevel = 0;          # level of the last test call
209  my $SetupCount = 0;         # number of times TSetup called  my $SetupCount = 0;         # number of times TSetup called
210  my $AllTrace = 0;           # TRUE if we are tracing all categories.  my $AllTrace = 0;           # TRUE if we are tracing all categories.
211    my $SavedCGI;               # CGI object passed to ETracing
212    my $CommandLine;            # Command line passed to StandardSetup
213    umask 2;                    # Fix the damn umask so everything is group-writable.
214    
215  =head2 Tracing Methods  =head2 Tracing Methods
216    
# Line 366  Line 281 
281          }          }
282      }      }
283      # Now we need to process the destination information. The most important special      # Now we need to process the destination information. The most important special
284      # 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
285      # "+" prefix which indicates a double echo.      # ">>" (append). A leading "+" for either indicates that we are also writing to
286        # the standard output (tee mode).
287      if ($target =~ m/^\+?>>?/) {      if ($target =~ m/^\+?>>?/) {
288          if ($target =~ m/^\+/) {          if ($target =~ m/^\+/) {
289              $TeeFlag = 1;              $TeeFlag = 1;
290              $target = substr($target, 1);              $target = substr($target, 1);
291          }          }
292          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
293                # We need to initialize the file (which clears it).
294              open TRACEFILE, $target;              open TRACEFILE, $target;
295              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] [notice] [Tracer] Tracing initialized.\n";
296              close TRACEFILE;              close TRACEFILE;
297                # Set to append mode now that the file has been cleared.
298              $Destination = ">$target";              $Destination = ">$target";
299          } else {          } else {
300              $Destination = $target;              $Destination = $target;
# Line 408  Line 326 
326      $TraceLevel = $_[0];      $TraceLevel = $_[0];
327  }  }
328    
329  =head3 ParseTraceDate  =head3 ParseDate
330    
331        my $time = Tracer::ParseDate($dateString);
332    
333      my $time = Tracer::ParseTraceDate($dateString);  Convert a date into a PERL time number. This method expects a date-like string
334    and parses it into a number. The string must be vaguely date-like or it will
335    return an undefined value. Our requirement is that a month and day be
336    present and that three pieces of the date string (time of day, month and day,
337    year) be separated by likely delimiters, such as spaces, commas, and such-like.
338    
339  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
340    everything but the hour.
341    
342    The year must be exactly four digits.
343    
344    Additional stuff can be in the string. We presume it's time zones or weekdays or something
345    equally innocuous. This means, however, that a sufficiently long sentence with date-like
346    parts in it may be interpreted as a date. Hopefully this will not be a problem.
347    
348    It should be guaranteed that this method will parse the output of the L</Now> function.
349    
350    The parameters are as follows.
351    
352  =over 4  =over 4
353    
354  =item dateString  =item dateString
355    
356  The date string from the trace file. The format of the string is determined by the  The date string to convert.
 L</Now> method.  
357    
358  =item RETURN  =item RETURN
359    
360  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
361  the time string is invalid.  the date string is invalid. A valid date string must contain a month and day.
362    
363  =back  =back
364    
365  =cut  =cut
366    
367  sub ParseTraceDate {  # Universal month conversion table.
368    use constant MONTHS => {    Jan =>  0, January   =>  0, '01' =>  0,  '1' =>  0,
369                                Feb =>  1, February  =>  1, '02' =>  1,  '2' =>  1,
370                                Mar =>  2, March     =>  2, '03' =>  2,  '3' =>  2,
371                                Apr =>  3, April     =>  3, '04' =>  3,  '4' =>  3,
372                                May =>  4, May       =>  4, '05' =>  4,  '5' =>  4,
373                                Jun =>  5, June      =>  5, '06' =>  5,  '6' =>  5,
374                                Jul =>  6, July      =>  6, '07' =>  6,  '7' =>  6,
375                                Aug =>  7, August    =>  7, '08' =>  7,  '8' =>  7,
376                                Sep =>  8, September =>  8, '09' =>  8,  '9' =>  8,
377                                Oct =>  9, October  =>   9, '10' =>  9,
378                                Nov => 10, November =>  10, '11' => 10,
379                                Dec => 11, December =>  11, '12' => 11
380                            };
381    
382    sub ParseDate {
383      # Get the parameters.      # Get the parameters.
384      my ($dateString) = @_;      my ($dateString) = @_;
385      # Declare the return variable.      # Declare the return variable.
386      my $retVal;      my $retVal;
387      # Parse the date.      # Find the month and day of month. There are two ways that can happen. We check for the
388      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
389          # Create a time object. Note we need to convert the day, month,      # won't be fooled into thinking the month is Sunday.
390          # 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#) {
391          # the internal month value is relocated to January = 0.          my ($mon, $mday) = (MONTHS->{$1}, $2);
392          $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);          # Insist that the month and day are valid.
393            if (defined($mon) && $2 >= 1 && $2 <= 31) {
394                # Find the time.
395                my ($hour, $min, $sec) = (0, 0, 0);
396                if ($dateString =~ /\b(\d{1,2}):(\d{2}):(\d{2})\b/) {
397                    ($hour, $min, $sec) = ($1, $2, $3);
398                }
399                # Find the year.
400                my $year;
401                if ($dateString =~ /\b(\d{4})\b/) {
402                    $year = $1;
403                } else {
404                    # Get the default year, which is this one. Note we must convert it to
405                    # the four-digit value expected by "timelocal".
406                    (undef, undef, undef, undef, undef, $year) = localtime();
407                    $year += 1900;
408                }
409                $retVal = timelocal($sec, $min, $hour, $mday, $mon, $year);
410            }
411      }      }
412      # Return the result.      # Return the result.
413      return $retVal;      return $retVal;
# Line 489  Line 456 
456  sub Trace {  sub Trace {
457      # Get the parameters.      # Get the parameters.
458      my ($message) = @_;      my ($message) = @_;
459        # Strip off any line terminators at the end of the message. We will add
460        # new-line stuff ourselves.
461        my $stripped = Strip($message);
462        # Compute the caller information.
463        my ($callPackage, $callFile, $callLine) = caller();
464        my $callFileTitle = basename($callFile);
465        # Check the caller.
466        my $callerInfo = ($callFileTitle ne "Tracer.pm" ? " [$callFileTitle $callLine]" : "");
467      # Get the timestamp.      # Get the timestamp.
468      my $timeStamp = Now();      my $timeStamp = Now();
469      # Format the message. Note we strip off any line terminators at the end.      # Build the prefix.
470      my $prefix = "[$timeStamp] <$LastCategory>: ";      my $level = $LevelNames[$LastLevel] || "($LastLevel)";
471      my $formatted = $prefix . Strip($message);      my $prefix = "[$timeStamp] [$level] [$LastCategory]$callerInfo";
472        # Format the message.
473        my $formatted = "$prefix $stripped";
474      # Process according to the destination.      # Process according to the destination.
475      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
476          # Write the message to the standard output.          # Write the message to the standard output.
477          print "$formatted\n";          print "$formatted\n";
478      } elsif ($Destination eq "ERROR") {      } elsif ($Destination eq "ERROR") {
479          # Write the message to the error output.          # Write the message to the error output. Here, we want our prefix fields.
480          print STDERR "$formatted\n";          print STDERR "$formatted\n";
481        } elsif ($Destination eq "WARN") {
482            # Emit the message to the standard error output. It is presumed that the
483            # error logger will add its own prefix fields, the notable exception being
484            # the caller info.
485            print STDERR "$callerInfo$stripped\n";
486      } elsif ($Destination eq "QUEUE") {      } elsif ($Destination eq "QUEUE") {
487          # Push the message into the queue.          # Push the message into the queue.
488          push @Queue, "$formatted";          push @Queue, "$formatted";
489      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
490          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML and write it to the standard output.
491          my $escapedMessage = CGI::escapeHTML($message);          my $escapedMessage = CGI::escapeHTML($stripped);
492          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;  
493      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
494          # Write the trace message to an output file.          # Write the trace message to an output file.
495          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
496          print TRACING "$formatted\n";          print TRACING "$formatted\n";
497          close TRACING;          close TRACING;
498          # 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 555 
555                  $category = $cats[$#cats];                  $category = $cats[$#cats];
556              }              }
557          }          }
558          # Save the category name.          # Save the category name and level.
559          $LastCategory = $category;          $LastCategory = $category;
560            $LastLevel = $traceLevel;
561          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
562          $category = lc $category;          $category = lc $category;
563          # Use the category and tracelevel to compute the result.          # Validate the trace level.
564          if (ref $traceLevel) {          if (ref $traceLevel) {
565              Confess("Bad trace level.");              Confess("Bad trace level.");
566          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
567              Confess("Bad trace config.");              Confess("Bad trace config.");
568          }          }
569          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
570            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
571      }      }
572      # Return the computed result.      # Return the computed result.
573      return $retVal;      return $retVal;
# Line 660  Line 641 
641  sub Confess {  sub Confess {
642      # Get the parameters.      # Get the parameters.
643      my ($message) = @_;      my ($message) = @_;
644        # Set up the category and level.
645        $LastCategory = "(confess)";
646        $LastLevel = 0;
647      if (! defined($FIG_Config::no_tool_hdr)) {      if (! defined($FIG_Config::no_tool_hdr)) {
648          # 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.
649          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";
650          # Only proceed if the tool header file is actually present.          # Only proceed if the tool header file is actually present.
651          if (-f $toolHeaderFile) {          if (-f $toolHeaderFile) {
652              my @lines = GetFile($toolHeaderFile);              my $fh;
653                if (open $fh, "<$toolHeaderFile") {
654                    my @lines = <$fh>;
655              Trace("Tool header has " . scalar(@lines) . " lines.");              Trace("Tool header has " . scalar(@lines) . " lines.");
656          }          }
657      }      }
658        }
659      # Trace the call stack.      # Trace the call stack.
660      Cluck($message);      Cluck($message);
661      # Abort the program.      # Abort the program.
662      croak(">>> $message");      croak(">>> $message");
663  }  }
664    
665    =head3 SaveCGI
666    
667        Tracer::SaveCGI($cgi);
668    
669    This method saves the CGI object but does not activate emergency tracing.
670    It is used to allow L</Warn> to work in situations where emergency
671    tracing is contra-indicated (e.g. the wiki).
672    
673    =over 4
674    
675    =item cgi
676    
677    Active CGI query object.
678    
679    =back
680    
681    =cut
682    
683    sub SaveCGI {
684        $SavedCGI = $_[0];
685    }
686    
687    =head3 Warn
688    
689        Warn($message, @options);
690    
691    This method traces an important message. If an RSS feed is configured
692    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
693    then the message will be echoed to the feed. In general, a tracing
694    destination of C<WARN> indicates that the caller is running as a web
695    service in a production environment; however, this is not a requirement.
696    
697    To force warnings into the RSS feed even when the tracing destination
698    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
699    configured automatically when L</StandardSetup> is used.
700    
701    The L</Cluck> method calls this one for its final message. Since
702    L</Confess> calls L</Cluck>, this means that any error which is caught
703    and confessed will put something in the feed. This insures that someone
704    will be alerted relatively quickly when a failure occurs.
705    
706    =over 4
707    
708    =item message
709    
710    Message to be traced.
711    
712    =item options
713    
714    A list containing zero or more options.
715    
716    =back
717    
718    The permissible options are as follows.
719    
720    =over 4
721    
722    =item noStack
723    
724    If specified, then the stack trace is not included in the output.
725    
726    =back
727    
728    =cut
729    
730    sub Warn {
731        # Get the parameters.
732        my $message = shift @_;
733        my %options = map { $_ => 1 } @_;
734        # Save $@;
735        my $savedError = $@;
736        # Trace the message.
737        Trace($message);
738        # This will contain the lock handle. If it's defined, it means we need to unlock.
739        my $lock;
740        # Check for feed forcing.
741        my $forceFeed = exists $Categories{feed};
742        # An error here would be disastrous. Note that if debug mode is specified,
743        # we do this stuff even in a test environment.
744        eval {
745            # Do we need to put this in the RSS feed?
746            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
747                # Probably. We need to check first, however, to see if it's from an
748                # ignored IP. For non-CGI situations, we default the IP to the self-referent.
749                my $key = "127.0.0.1";
750                if (defined $SavedCGI) {
751                    # Get the IP address.
752                    $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
753                }
754                # Is the IP address in the ignore list?
755                my $found = scalar(grep { $_ eq $key } @FIG_Config::error_ignore_ips);
756                if (! $found) {
757                    # No. We're good. We now need to compute the date, the link, and the title.
758                    # First, the date, in a very specific format.
759                    my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
760                        (tz_local_offset() / 30);
761                    # Environment data goes in here. We start with the date.
762                    my $environment = "$date.  ";
763                    # If we need to recap the message (because it's too long to be a title), we'll
764                    # put it in here.
765                    my $recap;
766                    # Copy the message and remove excess space.
767                    my $title = $message;
768                    $title =~ s/\s+/ /gs;
769                    # If it's too long, we have to split it up.
770                    if (length $title > 60) {
771                        # Put the full message in the environment string.
772                        $recap = $title;
773                        # Excerpt it as the title.
774                        $title = substr($title, 0, 50) . "...";
775                    }
776                    # If we have a CGI object, then this is a web error. Otherwise, it's
777                    # command-line.
778                    if (defined $SavedCGI) {
779                        # We're in a web service. The environment is the user's IP, and the link
780                        # is the URL that got us here.
781                        $environment .= "Event Reported at IP address $key process $$.";
782                        my $url = $SavedCGI->self_url();
783                        # We need the user agent string and (if available) the referrer.
784                        # The referrer will be the link.
785                        $environment .= " User Agent $ENV{HTTP_USER_AGENT}";
786                        if ($ENV{HTTP_REFERER}) {
787                            my $link = $ENV{HTTP_REFERER};
788                            $environment .= " referred from <a href=\"$link\">$link</a>.";
789                        } else {
790                            $environment .= " referrer unknown.";
791                        }
792                        # Close off the sentence with the original link.
793                        $environment .= " URL of event is <a href=\"$url\">$url</a>.";
794                    } else {
795                        # No CGI object, so we're a command-line tool. Use the tracing
796                        # key and the PID as the user identifier, and add the command.
797                        my $key = EmergencyKey();
798                        $environment .= "Event Reported by $key process $$.";
799                        if ($CommandLine) {
800                            # We're in a StandardSetup script, so we have the real command line.
801                            $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
802                        } elsif ($ENV{_}) {
803                            # We're in a BASH script, so the command has been stored in the _ variable.
804                            $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
805                        }
806                    }
807                    # Build a GUID. We use the current time, the title, and the process ID,
808                    # then digest the result.
809                    my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
810                    # Finally, the description. This is a stack trace plus various environmental stuff.
811                    # The trace is optional.
812                    my $stackTrace;
813                    if ($options{noStack}) {
814                        $stackTrace = "";
815                    } else {
816                        my @trace = LongMess();
817                        # Only proceed if we got something back.
818                        if (scalar(@trace) > 0) {
819                            $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
820                            $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
821                        }
822                    }
823                    # We got the stack trace. Now it's time to put it all together.
824                    # We have a goofy thing here in that we need to HTML-escape some sections of the description
825                    # twice. They will be escaped once here, and then once when written by XML::Simple. They are
826                    # unescaped once when processed by the RSS reader, and stuff in the description is treated as
827                    # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
828                    # our <br>s and <pre>s are used to format the description.
829                    $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
830                    my $description = "$recap$environment  $stackTrace";
831                    # Okay, we have all the pieces. Create a hash of the new event.
832                    my $newItem = { title => $title,
833                                    description => $description,
834                                    category => $LastCategory,
835                                    pubDate => $date,
836                                    guid => $guid,
837                                  };
838                    # We need XML capability for this.
839                    require XML::Simple;
840                    # The RSS document goes in here.
841                    my $rss;
842                    # Get the name of the RSS file. It's in the FIG temporary directory.
843                    my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
844                    # Open the config file and lock it.
845                    $lock = Open(undef, "<$FIG_Config::fig_disk/config/FIG_Config.pm");
846                    flock $lock, LOCK_EX;
847                    # Does it exist?
848                    if (-s $fileName) {
849                        # Slurp it in.
850                        $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
851                    } else {
852                        my $size = -s $fileName;
853                        # Create an empty channel.
854                        $rss = {
855                            channel => {
856                                title => 'NMPDR Warning Feed',
857                                link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
858                                description => "Important messages regarding the status of the NMPDR.",
859                                generator => "NMPDR Trace Facility",
860                                docs => "http://blogs.law.harvard.edu/tech/rss",
861                                item => []
862                            },
863                        };
864                    }
865                    # Get the channel object.
866                    my $channel = $rss->{channel};
867                    # Update the last-build date.
868                    $channel->{lastBuildDate} = $date;
869                    # Get the item array.
870                    my $items = $channel->{item};
871                    # Insure it has only 100 entries.
872                    while (scalar @{$items} > 100) {
873                        pop @{$items};
874                    }
875                    # Add our new item at the front.
876                    unshift @{$items}, $newItem;
877                    # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
878                    # the requirements for those.
879                    my $xml = XML::Simple::XMLout($channel, NoAttr => 1, RootName => 'channel', XmlDecl => '');
880                    # Here we put in the root and declaration. The problem is that the root has to have the version attribute
881                    # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
882                    $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
883                    # We don't use Open here because we can't afford an error.
884                    if (open XMLOUT, ">$fileName") {
885                        print XMLOUT $xml;
886                        close XMLOUT;
887                    }
888                }
889            }
890        };
891        if ($@) {
892            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
893            # (which is a good thing).
894            my $error = $@;
895            Trace("Feed Error: $error") if T(Feed => 0);
896        }
897        # Be sure to unlock.
898        if ($lock) {
899            flock $lock, LOCK_UN;
900            undef $lock;
901        }
902        # Restore the error message.
903        $@ = $savedError;
904    }
905    
906    
907    
908    
909  =head3 Assert  =head3 Assert
910    
911      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 725  Line 956 
956      my ($message) = @_;      my ($message) = @_;
957      # Trace what's happening.      # Trace what's happening.
958      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
959      my $confession = longmess($message);      # Get the stack trace.
960      # Convert the confession to a series of trace messages. Note we skip any      my @trace = LongMess();
961      # messages relating to calls into Tracer.      # Convert the trace to a series of messages.
962      for my $line (split /\s*\n/, $confession) {      for my $line (@trace) {
963          Trace($line) if ($line !~ /Tracer\.pm/);          # Replace the tab at the beginning with spaces.
964            $line =~ s/^\t/    /;
965            # Trace the line.
966            Trace($line);
967      }      }
968        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
969        Warn($message);
970  }  }
971    
972  =head3 ScriptSetup  =head3 LongMess
   
     my ($cgi, $varHash) = ScriptSetup($noTrace);  
   
 Perform standard tracing and debugging setup for scripts. The value returned is  
 the CGI object followed by a pre-built variable hash. At the end of the script,  
 the client should call L</ScriptFinish> to output the web page.  
   
 This method calls L</ETracing> to configure tracing, which allows the tracing  
 to be configured via the emergency tracing form on the debugging control panel.  
 Tracing will then be turned on automatically for all programs that use the L</ETracing>  
 method, which includes every program that uses this method or L</StandardSetup>.  
   
 =over 4  
   
 =item noTrace (optional)  
   
 If specified, tracing will be suppressed. This is useful if the script wants to set up  
 tracing manually.  
   
 =item RETURN  
973    
974  Returns a two-element list consisting of a CGI query object and a variable hash for      my @lines = Tracer::LongMess();
 the output page.  
975    
976  =back  Return a stack trace with all tracing methods removed. The return will be in the form of a list
977    of message strings.
978    
979  =cut  =cut
980    
981  sub ScriptSetup {  sub LongMess {
982      # Get the parameters.      # Declare the return variable.
983      my ($noTrace) = @_;      my @retVal = ();
984      # Get the CGI query object.      my $confession = longmess("");
985      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
986      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
987      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
988      # Create the variable hash.              push @retVal, $line;
989      my $varHash = { results => '' };          }
990      # Return the query object and variable hash.      }
991      return ($cgi, $varHash);      # Return the result.
992        return @retVal;
993  }  }
994    
995  =head3 ETracing  =head3 ETracing
# Line 806  Line 1023 
1023      # Get the parameter.      # Get the parameter.
1024      my ($parameter) = @_;      my ($parameter) = @_;
1025      # Check for CGI mode.      # Check for CGI mode.
1026      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
1027            $SavedCGI = $parameter;
1028        } else {
1029            $SavedCGI = undef;
1030        }
1031      # Default to no tracing except errors.      # Default to no tracing except errors.
1032      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
1033      # Check for emergency tracing.      # Check for emergency tracing.
# Line 839  Line 1060 
1060              # Set the trace parameter.              # Set the trace parameter.
1061              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1062          }          }
1063      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1064          # 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
1065          # for tracing from the form parameters.          # for tracing from the form parameters.
1066          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1067              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1068              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1069              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1070          }          }
1071      }      }
1072      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1073      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1074      # Check to see if we're a web script.      # Check to see if we're a web script.
1075      if (defined $cgi) {      if (defined $SavedCGI) {
1076          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1077          TraceParms($cgi);          TraceParms($SavedCGI);
1078          # 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
1079          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1080          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 958  Line 1179 
1179          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
1180      } elsif ($myDest eq 'DUAL') {      } elsif ($myDest eq 'DUAL') {
1181          $retVal = "+>" . EmergencyFileTarget($tkey);          $retVal = "+>" . EmergencyFileTarget($tkey);
1182        } elsif ($myDest eq 'WARN') {
1183            $retVal = "WARN";
1184      }      }
1185      # Return the result.      # Return the result.
1186      return $retVal;      return $retVal;
# Line 1043  Line 1266 
1266      my $retVal;      my $retVal;
1267      # Determine the parameter type.      # Determine the parameter type.
1268      if (! defined $parameter) {      if (! defined $parameter) {
1269          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1270          $retVal = $ENV{TRACING};          # get the effective login ID.
1271            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1272      } else {      } else {
1273          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1274          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1086  Line 1310 
1310      my ($cgi) = @_;      my ($cgi) = @_;
1311      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1312          # Here we trace the GET-style URL for the script.          # Here we trace the GET-style URL for the script.
1313          Trace("URL: " . $cgi->url(-relative => 1, -query => 1));          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));
1314      }      }
1315      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1316          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1095  Line 1319 
1319              # Note we skip the Trace parameters, which are for our use only.              # Note we skip the Trace parameters, which are for our use only.
1320              if ($parmName ne 'Trace' && $parmName ne 'TF') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
1321                  my @values = $cgi->param($parmName);                  my @values = $cgi->param($parmName);
1322                  Trace("CGI: $parmName = " . join(", ", @values));                  Trace("[CGI] $parmName = " . join(", ", @values));
1323              }              }
1324          }          }
1325          # Display the request method.          # Display the request method.
# Line 1105  Line 1329 
1329      if (T(CGI => 4)) {      if (T(CGI => 4)) {
1330          # Here we want the environment data too.          # Here we want the environment data too.
1331          for my $envName (sort keys %ENV) {          for my $envName (sort keys %ENV) {
1332              Trace("ENV: $envName = $ENV{$envName}");              Trace("[ENV] $envName = $ENV{$envName}");
1333          }          }
1334      }      }
1335  }  }
# Line 1161  Line 1385 
1385      }      }
1386  }  }
1387    
   
 =head3 ScriptFinish  
   
     ScriptFinish($webData, $varHash);  
   
 Output a web page at the end of a script. Either the string to be output or the  
 name of a template file can be specified. If the second parameter is omitted,  
 it is assumed we have a string to be output; otherwise, it is assumed we have the  
 name of a template file. The template should have the variable C<DebugData>  
 specified in any form that invokes a standard script. If debugging mode is turned  
 on, a form field will be put in that allows the user to enter tracing data.  
 Trace messages will be placed immediately before the terminal C<BODY> tag in  
 the output, formatted as a list.  
   
 A typical standard script would loook like the following.  
   
     BEGIN {  
         # Print the HTML header.  
         print "CONTENT-TYPE: text/html\n\n";  
     }  
     use Tracer;  
     use CGI;  
     use FIG;  
     # ... more uses ...  
   
     my ($cgi, $varHash) = ScriptSetup();  
     eval {  
         # ... get data from $cgi, put it in $varHash ...  
     };  
     if ($@) {  
         Trace("Script Error: $@") if T(0);  
     }  
     ScriptFinish("Html/MyTemplate.html", $varHash);  
   
 The idea here is that even if the script fails, you'll see trace messages and  
 useful output.  
   
 =over 4  
   
 =item webData  
   
 A string containing either the full web page to be written to the output or the  
 name of a template file from which the page is to be constructed. If the name  
 of a template file is specified, then the second parameter must be present;  
 otherwise, it must be absent.  
   
 =item varHash (optional)  
   
 If specified, then a reference to a hash mapping variable names for a template  
 to their values. The template file will be read into memory, and variable markers  
 will be replaced by data in this hash reference.  
   
 =back  
   
 =cut  
   
 sub ScriptFinish {  
     # Get the parameters.  
     my ($webData, $varHash) = @_;  
     # Check for a template file situation.  
     my $outputString;  
     if (defined $varHash) {  
         # Here we have a template file. We need to determine the template type.  
         my $template;  
         if ($FIG_Config::template_url && $webData =~ /\.php$/) {  
             $template = "$FIG_Config::template_url/$webData";  
         } else {  
             $template = "<<$webData";  
         }  
         $outputString = PageBuilder::Build($template, $varHash, "Html");  
     } else {  
         # Here the user gave us a raw string.  
         $outputString = $webData;  
     }  
     # Check for trace messages.  
     if ($Destination ne "NONE" && $TraceLevel > 0) {  
         # We have trace messages, so we want to put them at the end of the body. This  
         # is either at the end of the whole string or at the beginning of the BODY  
         # end-tag.  
         my $pos = length $outputString;  
         if ($outputString =~ m#</body>#gi) {  
             $pos = (pos $outputString) - 7;  
         }  
         # If the trace messages were queued, we unroll them. Otherwise, we display the  
         # destination.  
         my $traceHtml;  
         if ($Destination eq "QUEUE") {  
             $traceHtml = QTrace('Html');  
         } elsif ($Destination =~ /^>>(.+)$/) {  
             # Here the tracing output it to a file. We code it as a hyperlink so the user  
             # can copy the file name into the clipboard easily.  
             my $actualDest = $1;  
             $traceHtml = "<p>Tracing output to $actualDest.</p>\n";  
         } else {  
             # Here we have one of the special destinations.  
             $traceHtml = "<P>Tracing output type is $Destination.</p>\n";  
         }  
         substr $outputString, $pos, 0, $traceHtml;  
     }  
     # Write the output string.  
     print $outputString;  
 }  
   
1388  =head2 Command-Line Utility Methods  =head2 Command-Line Utility Methods
1389    
1390  =head3 SendSMS  =head3 SendSMS
# Line 1468  Line 1589 
1589  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
1590  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,
1591  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
1592  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
1593    login ID.
1594    
1595    Since the default situation in StandardSetup is to trace to the standard
1596    output, errors that occur in command-line scripts will not generate
1597    RSS events. To force the events, use the C<warn> option.
1598    
1599        TransactFeatures -background -warn register ../xacts IDs.tbl
1600    
1601  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1602  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 1548  Line 1676 
1676      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1677      # Get the default tracing key.      # Get the default tracing key.
1678      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1679        # Save the command line.
1680        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1681      # Add the tracing options.      # Add the tracing options.
1682      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1683          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
# Line 1556  Line 1686 
1686      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1687      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1688      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1689        $options->{warn} = [0, "send errors to RSS feed"];
1690      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1691      # contains the default values rather than the default value      # contains the default values rather than the default value
1692      # 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 1594  Line 1725 
1725          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1726              push @cats, "SQL";              push @cats, "SQL";
1727          }          }
1728            if ($retOptions->{warn}) {
1729                push @cats, "Feed";
1730            }
1731          # Add the default categories.          # Add the default categories.
1732          push @cats, "Tracer";          push @cats, "Tracer";
1733          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
# Line 1620  Line 1754 
1754              # Close the test file.              # Close the test file.
1755              close TESTTRACE;              close TESTTRACE;
1756          } else {          } else {
1757              # 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.
1758                warn "Could not open trace file $traceFileName: $!\n";
1759                # We trace to the standard output if it's
1760              # okay, and the error log otherwise.              # okay, and the error log otherwise.
1761              if ($textOKFlag) {              if ($textOKFlag) {
1762                  $traceMode = "TEXT";                  $traceMode = "TEXT";
# Line 2584  Line 2720 
2720  }  }
2721    
2722    
2723    =head3 PrintLine
2724    
2725  =head2 Other Useful Methods      Tracer::PrintLine($line);
   
 =head3 ParseParm  
   
     my $listValue = Tracer::ParseParm($string);  
2726    
2727  Convert a parameter into a list reference. If the parameter is undefined,  Print a line of text with a trailing new-line.
2728  an undefined value will be returned. Otherwise, it will be parsed as a  
2729  comma-separated list of values.  =over 4
2730    
2731    =item line
2732    
2733    Line of text to print.
2734    
2735    =back
2736    
2737    =cut
2738    
2739    sub PrintLine {
2740        # Get the parameters.
2741        my ($line) = @_;
2742        # Print the line.
2743        print "$line\n";
2744    }
2745    
2746    
2747    =head2 Other Useful Methods
2748    
2749    =head3 ParseParm
2750    
2751        my $listValue = Tracer::ParseParm($string);
2752    
2753    Convert a parameter into a list reference. If the parameter is undefined,
2754    an undefined value will be returned. Otherwise, it will be parsed as a
2755    comma-separated list of values.
2756    
2757  =over 4  =over 4
2758    
# Line 2624  Line 2783 
2783      return $retVal;      return $retVal;
2784  }  }
2785    
   
   
   
2786  =head3 Now  =head3 Now
2787    
2788      my $string = Tracer::Now();      my $string = Tracer::Now();
2789    
2790  Return a displayable time stamp containing the local time.  Return a displayable time stamp containing the local time. Whatever format this
2791    method produces must be parseable by L</ParseDate>.
2792    
2793  =cut  =cut
2794    
2795  sub Now {  sub Now {
2796      my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);      return DisplayTime(time);
2797      my $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .  }
2798    
2799    =head3 DisplayTime
2800    
2801        my $string = Tracer::DisplayTime($time);
2802    
2803    Convert a time value to a displayable time stamp. Whatever format this
2804    method produces must be parseable by L</ParseDate>.
2805    
2806    =over 4
2807    
2808    =item time
2809    
2810    Time to display, in seconds since the epoch, or C<undef> if the time is unknown.
2811    
2812    =item RETURN
2813    
2814    Returns a displayable time, or C<(n/a)> if the incoming time is undefined.
2815    
2816    =back
2817    
2818    =cut
2819    
2820    sub DisplayTime {
2821        my ($time) = @_;
2822        my $retVal = "(n/a)";
2823        if (defined $time) {
2824            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
2825            $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .
2826                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);
2827        }
2828      return $retVal;      return $retVal;
2829  }  }
2830    
# Line 2802  Line 2988 
2988      return $retVal;      return $retVal;
2989  }  }
2990    
2991    =head3 Constrain
2992    
2993        my $constrained = Constrain($value, $min, $max);
2994    
2995    Modify a numeric value to bring it to a point in between a maximum and a minimum.
2996    
2997    =over 4
2998    
2999    =item value
3000    
3001    Value to constrain.
3002    
3003    =item min (optional)
3004    
3005    Minimum permissible value. If this parameter is undefined, no minimum constraint will be applied.
3006    
3007    =item max (optional)
3008    
3009    Maximum permissible value. If this parameter is undefined, no maximum constraint will be applied.
3010    
3011    =item RETURN
3012    
3013    Returns the incoming value, constrained according to the other parameters.
3014    
3015    =back
3016    
3017    =cut
3018    
3019    sub Constrain {
3020        # Get the parameters.
3021        my ($value, $min, $max) = @_;
3022        # Declare the return variable.
3023        my $retVal = $value;
3024        # Apply the minimum constraint.
3025        if (defined $min && $retVal < $min) {
3026            $retVal = $min;
3027        }
3028        # Apply the maximum constraint.
3029        if (defined $max && $retVal > $max) {
3030            $retVal = $max;
3031        }
3032        # Return the result.
3033        return $retVal;
3034    }
3035    
3036  =head3 Min  =head3 Min
3037    
3038      my $min = Min($value1, $value2, ... $valueN);      my $min = Min($value1, $value2, ... $valueN);
# Line 2868  Line 3099 
3099      return $retVal;      return $retVal;
3100  }  }
3101    
 =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;  
 }  
   
3102  =head3 Strip  =head3 Strip
3103    
3104      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
# Line 3147  Line 3348 
3348      return ($inserted, $deleted);      return ($inserted, $deleted);
3349  }  }
3350    
3351    =head3 Cmp
3352    
3353        my $cmp = Tracer::Cmp($a, $b);
3354    
3355    This method performs a universal sort comparison. Each value coming in is
3356    separated into a leading text part and a trailing number part. The text
3357    part is string compared, and if both parts are equal, then the number
3358    parts are compared numerically. A stream of just numbers or a stream of
3359    just strings will sort correctly, and a mixed stream will sort with the
3360    numbers first. Strings with a label and a number will sort in the
3361    expected manner instead of lexically.
3362    
3363    =over 4
3364    
3365    =item a
3366    
3367    First item to compare.
3368    
3369    =item b
3370    
3371    Second item to compare.
3372    
3373    =item RETURN
3374    
3375    Returns a negative number if the first item should sort first (is less), a positive
3376    number if the first item should sort second (is greater), and a zero if the items are
3377    equal.
3378    
3379    =back
3380    
3381    =cut
3382    
3383    sub Cmp {
3384        # Get the parameters.
3385        my ($a, $b) = @_;
3386        # Declare the return value.
3387        my $retVal;
3388        # Check for nulls.
3389        if (! defined($a)) {
3390            $retVal = (! defined($b) ? 0 : -1);
3391        } elsif (! defined($b)) {
3392            $retVal = 1;
3393        } else {
3394            # Here we have two real values. Parse the two strings.
3395            $a =~ /^(\D*)(\d*)$/;
3396            my $aParsed = [$1, $2];
3397            $b =~ /^(\D*)(\d*)$/;
3398            my $bParsed = [$1, $2];
3399            # Compare the string parts.
3400            $retVal = $aParsed->[0] cmp $bParsed->[0];
3401            if (! $retVal) {
3402                $retVal = $aParsed->[1] <=> $bParsed->[1];
3403            }
3404        }
3405        # Return the result.
3406        return $retVal;
3407    }
3408    
3409    =head3 ListEQ
3410    
3411        my $flag = Tracer::ListEQ(\@a, \@b);
3412    
3413    Return TRUE if the specified lists contain the same strings in the same
3414    order, else FALSE.
3415    
3416    =over 4
3417    
3418    =item a
3419    
3420    Reference to the first list.
3421    
3422    =item b
3423    
3424    Reference to the second list.
3425    
3426    =item RETURN
3427    
3428    Returns TRUE if the two parameters are identical string lists, else FALSE.
3429    
3430    =back
3431    
3432    =cut
3433    
3434    sub ListEQ {
3435        # Get the parameters.
3436        my ($a, $b) = @_;
3437        # Declare the return variable. Start by checking the lengths.
3438        my $n = scalar(@$a);
3439        my $retVal = ($n == scalar(@$b));
3440        # Now compare the list elements.
3441        for (my $i = 0; $retVal && $i < $n; $i++) {
3442            $retVal = ($a->[$i] eq $b->[$i]);
3443        }
3444        # Return the result.
3445        return $retVal;
3446    }
3447    
3448    =head2 CGI Script Utilities
3449    
3450    =head3 ScriptSetup (deprecated)
3451    
3452        my ($cgi, $varHash) = ScriptSetup($noTrace);
3453    
3454    Perform standard tracing and debugging setup for scripts. The value returned is
3455    the CGI object followed by a pre-built variable hash. At the end of the script,
3456    the client should call L</ScriptFinish> to output the web page.
3457    
3458    This method calls L</ETracing> to configure tracing, which allows the tracing
3459    to be configured via the emergency tracing form on the debugging control panel.
3460    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3461    method, which includes every program that uses this method or L</StandardSetup>.
3462    
3463    =over 4
3464    
3465    =item noTrace (optional)
3466    
3467    If specified, tracing will be suppressed. This is useful if the script wants to set up
3468    tracing manually.
3469    
3470    =item RETURN
3471    
3472    Returns a two-element list consisting of a CGI query object and a variable hash for
3473    the output page.
3474    
3475    =back
3476    
3477    =cut
3478    
3479    sub ScriptSetup {
3480        # Get the parameters.
3481        my ($noTrace) = @_;
3482        # Get the CGI query object.
3483        my $cgi = CGI->new();
3484        # Set up tracing if it's not suppressed.
3485        ETracing($cgi) unless $noTrace;
3486        # Create the variable hash.
3487        my $varHash = { results => '' };
3488        # Return the query object and variable hash.
3489        return ($cgi, $varHash);
3490    }
3491    
3492    =head3 ScriptFinish (deprecated)
3493    
3494        ScriptFinish($webData, $varHash);
3495    
3496    Output a web page at the end of a script. Either the string to be output or the
3497    name of a template file can be specified. If the second parameter is omitted,
3498    it is assumed we have a string to be output; otherwise, it is assumed we have the
3499    name of a template file. The template should have the variable C<DebugData>
3500    specified in any form that invokes a standard script. If debugging mode is turned
3501    on, a form field will be put in that allows the user to enter tracing data.
3502    Trace messages will be placed immediately before the terminal C<BODY> tag in
3503    the output, formatted as a list.
3504    
3505    A typical standard script would loook like the following.
3506    
3507        BEGIN {
3508            # Print the HTML header.
3509            print "CONTENT-TYPE: text/html\n\n";
3510        }
3511        use Tracer;
3512        use CGI;
3513        use FIG;
3514        # ... more uses ...
3515    
3516        my ($cgi, $varHash) = ScriptSetup();
3517        eval {
3518            # ... get data from $cgi, put it in $varHash ...
3519        };
3520        if ($@) {
3521            Trace("Script Error: $@") if T(0);
3522        }
3523        ScriptFinish("Html/MyTemplate.html", $varHash);
3524    
3525    The idea here is that even if the script fails, you'll see trace messages and
3526    useful output.
3527    
3528    =over 4
3529    
3530    =item webData
3531    
3532    A string containing either the full web page to be written to the output or the
3533    name of a template file from which the page is to be constructed. If the name
3534    of a template file is specified, then the second parameter must be present;
3535    otherwise, it must be absent.
3536    
3537    =item varHash (optional)
3538    
3539    If specified, then a reference to a hash mapping variable names for a template
3540    to their values. The template file will be read into memory, and variable markers
3541    will be replaced by data in this hash reference.
3542    
3543    =back
3544    
3545    =cut
3546    
3547    sub ScriptFinish {
3548        # Get the parameters.
3549        my ($webData, $varHash) = @_;
3550        # Check for a template file situation.
3551        my $outputString;
3552        if (defined $varHash) {
3553            # Here we have a template file. We need to determine the template type.
3554            my $template;
3555            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3556                $template = "$FIG_Config::template_url/$webData";
3557            } else {
3558                $template = "<<$webData";
3559            }
3560            $outputString = PageBuilder::Build($template, $varHash, "Html");
3561        } else {
3562            # Here the user gave us a raw string.
3563            $outputString = $webData;
3564        }
3565        # Check for trace messages.
3566        if ($Destination ne "NONE" && $TraceLevel > 0) {
3567            # We have trace messages, so we want to put them at the end of the body. This
3568            # is either at the end of the whole string or at the beginning of the BODY
3569            # end-tag.
3570            my $pos = length $outputString;
3571            if ($outputString =~ m#</body>#gi) {
3572                $pos = (pos $outputString) - 7;
3573            }
3574            # If the trace messages were queued, we unroll them. Otherwise, we display the
3575            # destination.
3576            my $traceHtml;
3577            if ($Destination eq "QUEUE") {
3578                $traceHtml = QTrace('Html');
3579            } elsif ($Destination =~ /^>>(.+)$/) {
3580                # Here the tracing output it to a file. We code it as a hyperlink so the user
3581                # can copy the file name into the clipboard easily.
3582                my $actualDest = $1;
3583                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3584            } else {
3585                # Here we have one of the special destinations.
3586                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3587            }
3588            substr $outputString, $pos, 0, $traceHtml;
3589        }
3590        # Write the output string.
3591        print $outputString;
3592    }
3593    
3594  =head3 GenerateURL  =head3 GenerateURL
3595    
3596      my $queryUrl = Tracer::GenerateURL($page, %parameters);      my $queryUrl = Tracer::GenerateURL($page, %parameters);
# Line 3281  Line 3725 
3725      return $retVal;      return $retVal;
3726  }  }
3727    
3728  =head3 Cmp  =head3 TrackingCode
3729    
3730      my $cmp = Tracer::Cmp($a, $b);      my $html = Tracer::TrackingCode();
3731    
3732  This method performs a universal sort comparison. Each value coming in is  Returns the HTML code for doing web page traffic monitoring. If the
3733  separated into a leading text part and a trailing number part. The text  current environment is a test system, then it returns a null string;
3734  part is string compared, and if both parts are equal, then the number  otherwise, it returns a bunch of javascript containing code for turning
3735  parts are compared numerically. A stream of just numbers or a stream of  on SiteMeter and Google Analytics.
 just strings will sort correctly, and a mixed stream will sort with the  
 numbers first. Strings with a label and a number will sort in the  
 expected manner instead of lexically.  
3736    
3737  =over 4  =cut
3738    
3739  =item a  sub TrackingCode {
3740        # Declare the return variable.
3741        my $retVal = "<!-- tracking off -->";
3742        # Determine if we're in production.
3743        if ($FIG_Config::site_meter) {
3744            $retVal = <<END_HTML
3745            <!-- Site Meter -->
3746            <script type="text/javascript" src="http://s20.sitemeter.com/js/counter.js?site=s20nmpdr">
3747            </script>
3748            <noscript>
3749            <a href="http://s20.sitemeter.com/stats.asp?site=s20nmpdr" target="_top">
3750            <img src="http://s20.sitemeter.com/meter.asp?site=s20nmpdr" alt="Site Meter" border="0"/></a>
3751            </noscript>
3752            <!-- Copyright (c)2006 Site Meter -->
3753    END_HTML
3754        }
3755        return $retVal;
3756    }
3757    
3758  First item to compare.  =head3 Clean
3759    
3760  =item b      my $cleaned = Tracer::Clean($string);
3761    
3762  Second item to compare.  Clean up a string for HTML display. This not only converts special
3763    characters to HTML entity names, it also removes control characters.
3764    
3765    =over 4
3766    
3767    =item string
3768    
3769    String to convert.
3770    
3771  =item RETURN  =item RETURN
3772    
3773  Returns a negative number if the first item should sort first (is less), a positive  Returns the input string with anything that might disrupt an HTML literal removed. An
3774  number if the first item should sort second (is greater), and a zero if the items are  undefined value will be converted to an empty string.
 equal.  
3775    
3776  =back  =back
3777    
3778  =cut  =cut
3779    
3780  sub Cmp {  sub Clean {
3781      # Get the parameters.      # Get the parameters.
3782      my ($a, $b) = @_;      my ($string) = @_;
3783      # Declare the return value.      # Declare the return variable.
3784      my $retVal;      my $retVal = "";
3785      # Check for nulls.      # Only proceed if the value exists.
3786      if (! defined($a)) {      if (defined $string) {
3787          $retVal = (! defined($b) ? 0 : -1);          # Get the string.
3788      } elsif (! defined($b)) {          $retVal = $string;
3789          $retVal = 1;          # Clean the control characters.
3790      } else {          $retVal =~ tr/\x00-\x1F/?/;
3791          # Here we have two real values. Parse the two strings.          # Escape the rest.
3792          $a =~ /^(\D*)(\d*)$/;          $retVal = CGI::escapeHTML($retVal);
         my $aParsed = [$1, $2];  
         $b =~ /^(\D*)(\d*)$/;  
         my $bParsed = [$1, $2];  
         # Compare the string parts.  
         $retVal = $aParsed->[0] cmp $bParsed->[0];  
         if (! $retVal) {  
             $retVal = $aParsed->[1] <=> $bParsed->[1];  
         }  
3793      }      }
3794      # Return the result.      # Return the result.
3795      return $retVal;      return $retVal;
3796  }  }
3797    
3798    
3799    
3800    
3801  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3