[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.105, Wed May 14 09:09:25 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    my $CommandLine;            # Command line passed to StandardSetup
212    umask 2;                    # Fix the damn umask so everything is group-writable.
213    
214  =head2 Tracing Methods  =head2 Tracing Methods
215    
# Line 366  Line 280 
280          }          }
281      }      }
282      # Now we need to process the destination information. The most important special      # Now we need to process the destination information. The most important special
283      # 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
284      # "+" prefix which indicates a double echo.      # ">>" (append). A leading "+" for either indicates that we are also writing to
285        # the standard output (tee mode).
286      if ($target =~ m/^\+?>>?/) {      if ($target =~ m/^\+?>>?/) {
287          if ($target =~ m/^\+/) {          if ($target =~ m/^\+/) {
288              $TeeFlag = 1;              $TeeFlag = 1;
289              $target = substr($target, 1);              $target = substr($target, 1);
290          }          }
291          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
292                # We need to initialize the file (which clears it).
293              open TRACEFILE, $target;              open TRACEFILE, $target;
294              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] [notice] [Tracer] Tracing initialized.\n";
295              close TRACEFILE;              close TRACEFILE;
296                # Set to append mode now that the file has been cleared.
297              $Destination = ">$target";              $Destination = ">$target";
298          } else {          } else {
299              $Destination = $target;              $Destination = $target;
# Line 408  Line 325 
325      $TraceLevel = $_[0];      $TraceLevel = $_[0];
326  }  }
327    
328  =head3 ParseTraceDate  =head3 ParseDate
329    
330        my $time = Tracer::ParseDate($dateString);
331    
332      my $time = Tracer::ParseTraceDate($dateString);  Convert a date into a PERL time number. This method expects a date-like string
333    and parses it into a number. The string must be vaguely date-like or it will
334    return an undefined value. Our requirement is that a month and day be
335    present and that three pieces of the date string (time of day, month and day,
336    year) be separated by likely delimiters, such as spaces, commas, and such-like.
337    
338  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
339    everything but the hour.
340    
341    The year must be exactly four digits.
342    
343    Additional stuff can be in the string. We presume it's time zones or weekdays or something
344    equally innocuous. This means, however, that a sufficiently long sentence with date-like
345    parts in it may be interpreted as a date. Hopefully this will not be a problem.
346    
347    It should be guaranteed that this method will parse the output of the L</Now> function.
348    
349    The parameters are as follows.
350    
351  =over 4  =over 4
352    
353  =item dateString  =item dateString
354    
355  The date string from the trace file. The format of the string is determined by the  The date string to convert.
 L</Now> method.  
356    
357  =item RETURN  =item RETURN
358    
359  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
360  the time string is invalid.  the date string is invalid. A valid date string must contain a month and day.
361    
362  =back  =back
363    
364  =cut  =cut
365    
366  sub ParseTraceDate {  # Universal month conversion table.
367    use constant MONTHS => {    Jan =>  0, January   =>  0, '01' =>  0,  '1' =>  0,
368                                Feb =>  1, February  =>  1, '02' =>  1,  '2' =>  1,
369                                Mar =>  2, March     =>  2, '03' =>  2,  '3' =>  2,
370                                Apr =>  3, April     =>  3, '04' =>  3,  '4' =>  3,
371                                May =>  4, May       =>  4, '05' =>  4,  '5' =>  4,
372                                Jun =>  5, June      =>  5, '06' =>  5,  '6' =>  5,
373                                Jul =>  6, July      =>  6, '07' =>  6,  '7' =>  6,
374                                Aug =>  7, August    =>  7, '08' =>  7,  '8' =>  7,
375                                Sep =>  8, September =>  8, '09' =>  8,  '9' =>  8,
376                                Oct =>  9, October  =>   9, '10' =>  9,
377                                Nov => 10, November =>  10, '11' => 10,
378                                Dec => 11, December =>  11, '12' => 11
379                            };
380    
381    sub ParseDate {
382      # Get the parameters.      # Get the parameters.
383      my ($dateString) = @_;      my ($dateString) = @_;
384      # Declare the return variable.      # Declare the return variable.
385      my $retVal;      my $retVal;
386      # Parse the date.      # Find the month and day of month. There are two ways that can happen. We check for the
387      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
388          # Create a time object. Note we need to convert the day, month,      # won't be fooled into thinking the month is Sunday.
389          # 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#) {
390          # the internal month value is relocated to January = 0.          my ($mon, $mday) = (MONTHS->{$1}, $2);
391          $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);          # Insist that the month and day are valid.
392            if (defined($mon) && $2 >= 1 && $2 <= 31) {
393                # Find the time.
394                my ($hour, $min, $sec) = (0, 0, 0);
395                if ($dateString =~ /\b(\d{1,2}):(\d{2}):(\d{2})\b/) {
396                    ($hour, $min, $sec) = ($1, $2, $3);
397                }
398                # Find the year.
399                my $year;
400                if ($dateString =~ /\b(\d{4})\b/) {
401                    $year = $1;
402                } else {
403                    # Get the default year, which is this one. Note we must convert it to
404                    # the four-digit value expected by "timelocal".
405                    (undef, undef, undef, undef, undef, $year) = localtime();
406                    $year += 1900;
407                }
408                $retVal = timelocal($sec, $min, $hour, $mday, $mon, $year);
409            }
410      }      }
411      # Return the result.      # Return the result.
412      return $retVal;      return $retVal;
# Line 489  Line 455 
455  sub Trace {  sub Trace {
456      # Get the parameters.      # Get the parameters.
457      my ($message) = @_;      my ($message) = @_;
458        # Strip off any line terminators at the end of the message. We will add
459        # new-line stuff ourselves.
460        my $stripped = Strip($message);
461        # Compute the caller information.
462        my ($callPackage, $callFile, $callLine) = caller();
463        my $callFileTitle = basename($callFile);
464        # Check the caller.
465        my $callerInfo = ($callFileTitle ne "Tracer.pm" ? " [$callFileTitle $callLine]" : "");
466      # Get the timestamp.      # Get the timestamp.
467      my $timeStamp = Now();      my $timeStamp = Now();
468      # Format the message. Note we strip off any line terminators at the end.      # Build the prefix.
469      my $prefix = "[$timeStamp] <$LastCategory>: ";      my $level = $LevelNames[$LastLevel] || "($LastLevel)";
470      my $formatted = $prefix . Strip($message);      my $prefix = "[$timeStamp] [$level] [$LastCategory]$callerInfo";
471        # Format the message.
472        my $formatted = "$prefix $stripped";
473      # Process according to the destination.      # Process according to the destination.
474      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
475          # Write the message to the standard output.          # Write the message to the standard output.
476          print "$formatted\n";          print "$formatted\n";
477      } elsif ($Destination eq "ERROR") {      } elsif ($Destination eq "ERROR") {
478          # Write the message to the error output.          # Write the message to the error output. Here, we want our prefix fields.
479          print STDERR "$formatted\n";          print STDERR "$formatted\n";
480        } elsif ($Destination eq "WARN") {
481            # Emit the message to the standard error output. It is presumed that the
482            # error logger will add its own prefix fields, the notable exception being
483            # the caller info.
484            print STDERR "$callerInfo$stripped\n";
485      } elsif ($Destination eq "QUEUE") {      } elsif ($Destination eq "QUEUE") {
486          # Push the message into the queue.          # Push the message into the queue.
487          push @Queue, "$formatted";          push @Queue, "$formatted";
488      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
489          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML and write it to the standard output.
490          my $escapedMessage = CGI::escapeHTML($message);          my $escapedMessage = CGI::escapeHTML($stripped);
491          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;  
492      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
493          # Write the trace message to an output file.          # Write the trace message to an output file.
494          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
495          print TRACING "$formatted\n";          print TRACING "$formatted\n";
496          close TRACING;          close TRACING;
497          # 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 554 
554                  $category = $cats[$#cats];                  $category = $cats[$#cats];
555              }              }
556          }          }
557          # Save the category name.          # Save the category name and level.
558          $LastCategory = $category;          $LastCategory = $category;
559            $LastLevel = $traceLevel;
560          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
561          $category = lc $category;          $category = lc $category;
562          # Use the category and tracelevel to compute the result.          # Validate the trace level.
563          if (ref $traceLevel) {          if (ref $traceLevel) {
564              Confess("Bad trace level.");              Confess("Bad trace level.");
565          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
566              Confess("Bad trace config.");              Confess("Bad trace config.");
567          }          }
568          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
569            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
570      }      }
571      # Return the computed result.      # Return the computed result.
572      return $retVal;      return $retVal;
# Line 660  Line 640 
640  sub Confess {  sub Confess {
641      # Get the parameters.      # Get the parameters.
642      my ($message) = @_;      my ($message) = @_;
643        # Set up the category and level.
644        $LastCategory = "(confess)";
645        $LastLevel = 0;
646      if (! defined($FIG_Config::no_tool_hdr)) {      if (! defined($FIG_Config::no_tool_hdr)) {
647          # 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.
648          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";
649          # Only proceed if the tool header file is actually present.          # Only proceed if the tool header file is actually present.
650          if (-f $toolHeaderFile) {          if (-f $toolHeaderFile) {
651              my @lines = GetFile($toolHeaderFile);              my $fh;
652                if (open $fh, "<$toolHeaderFile") {
653                    my @lines = <$fh>;
654              Trace("Tool header has " . scalar(@lines) . " lines.");              Trace("Tool header has " . scalar(@lines) . " lines.");
655          }          }
656      }      }
657        }
658      # Trace the call stack.      # Trace the call stack.
659      Cluck($message);      Cluck($message);
660      # Abort the program.      # Abort the program.
661      croak(">>> $message");      croak(">>> $message");
662  }  }
663    
664    =head3 Warn
665    
666        Warn($message);
667    
668    This method traces an important message. If an RSS feed is configured
669    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
670    then the message will be echoed to the feed. In general, a tracing
671    destination of C<WARN> indicates that the caller is running as a web
672    service in a production environment; however, this is not a requirement.
673    
674    To force warnings into the RSS feed even when the tracing destination
675    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
676    configured automatically when L</StandardSetup> is used.
677    
678    The L</Cluck> method calls this one for its final message. Since
679    L</Confess> calls L</Cluck>, this means that any error which is caught
680    and confessed will put something in the feed. This insures that someone
681    will be alerted relatively quickly when a failure occurs.
682    
683    =over 4
684    
685    =item message
686    
687    Message to be traced.
688    
689    =back
690    
691    =cut
692    
693    sub Warn {
694        # Get the parameters.
695        my ($message) = @_;
696        # Trace the message.
697        Trace($message);
698        # Check for feed forcing.
699        my $forceFeed = exists $Categories{feed};
700        # An error here would be disastrous. Note, however, that we aren't too worried
701        # about losing events. The error log is always available for the occasions where
702        # we mess up. Note that if debug mode is specified, we do this stuff even in a
703        # test environment.
704        eval {
705            # Do we need to put this in the RSS feed?
706            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
707                # Yes. We now need to compute the date, the link, and the title.
708                # First, the date, in a very specific format.
709                my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
710                    (tz_local_offset() / 30);
711                # Environment data goes in here. We start with the date.
712                my $environment = "$date.  ";
713                # If we need to recap the message (because it's too long to be a title), we'll
714                # put it in here.
715                my $recap;
716                # Copy the message and remove excess space.
717                my $title = $message;
718                $title =~ s/\s+/ /gs;
719                # If it's too long, we have to split it up.
720                if (length $title > 60) {
721                    # Put the full message in the environment string.
722                    $recap = $title;
723                    # Excerpt it as the title.
724                    $title = substr($title, 0, 50) . "...";
725                }
726                # If we have a CGI object, then this is a web error. Otherwise, it's
727                # command-line.
728                if (defined $SavedCGI) {
729                    # We're in a web service. The environment is the user's IP, and the link
730                    # is the URL that got us here.
731                    my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
732                    $environment .= "Event Reported at IP address $key.";
733                    my $url = $SavedCGI->url(-full => 1, -query => 1);
734                    # We need the user agent string and (if available) the referrer.
735                    # The referrer will be the link.
736                    $environment .= "User Agent $ENV{HTTP_USER_AGENT}";
737                    if ($ENV{HTTP_REFERER}) {
738                        my $link = $ENV{HTTP_REFERER};
739                        $environment .= " referred from <a href=\"$link\">$link</a>.";
740                    } else {
741                        $environment .= " referrer unknown.";
742                    }
743                    # Close off the sentence with the original link.
744                    $environment .= " URL of error is <a href=\"$url\">$url</a>.";
745                } else {
746                    # No CGI object, so we're a command-line tool. Use the tracing
747                    # key and the PID as the user identifier, and add the command.
748                    my $key = EmergencyKey();
749                    $environment .= "Event Reported by $key Process $$.";
750                    if ($CommandLine) {
751                        # We're in a StandardSetup script, so we have the real command line.
752                        $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
753                    } elsif ($ENV{_}) {
754                        # We're in a BASH script, so the command has been stored in the _ variable.
755                        $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
756                    }
757                }
758                # Build a GUID. We use the current time, the title, and the process ID,
759                # then digest the result.
760                my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
761                # Finally, the description. This is a stack trace plus various environmental stuff.
762                my $stackTrace = "";
763                my @trace = LongMess();
764                # Only proceed if we got something back.
765                if (scalar(@trace) > 0) {
766                    $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
767                    $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
768                }
769                # We got the stack trace. Now it's time to put it all together.
770                # We have a goofy thing here in that we need to HTML-escape some sections of the description
771                # twice. They will be escaped once here, and then once when written by XML::Simple. They are
772                # unescaped once when processed by the RSS reader, and stuff in the description is treated as
773                # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
774                # our <br>s and <pre>s are used to format the description.
775                $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
776                my $description = "$recap$environment  $stackTrace";
777                # Okay, we have all the pieces. Create a hash of the new event.
778                my $newItem = { title => $title,
779                                description => $description,
780                                category => $LastCategory,
781                                pubDate => $date,
782                                guid => $guid,
783                               };
784                # We need XML capability for this.
785                require XML::Simple;
786                # The RSS document goes in here.
787                my $rss;
788                # Get the name of the RSS file. It's in the FIG temporary directory.
789                my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
790                # Does it exist?
791                if (-s $fileName) {
792                    # Slurp it in.
793                    $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
794                } else {
795                    my $size = -s $fileName;
796                    # Create an empty channel.
797                    $rss = {
798                        channel => {
799                            title => 'NMPDR Warning Feed',
800                            link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
801                            description => "Important messages regarding the status of the NMPDR.",
802                            generator => "NMPDR Trace Facility",
803                            docs => "http://blogs.law.harvard.edu/tech/rss",
804                            item => []
805                        },
806                    };
807                }
808                # Get the channel object.
809                my $channel = $rss->{channel};
810                # Update the last-build date.
811                $channel->{lastBuildDate} = $date;
812                # Get the item array.
813                my $items = $channel->{item};
814                # Insure it has only 100 entries.
815                while (scalar @{$items} > 100) {
816                    pop @{$items};
817                }
818                # Add our new item at the front.
819                unshift @{$items}, $newItem;
820                # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
821                # the requirements for those.
822                my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => undef, XmlDecl => '');
823                # Here we put in the root and declaration. The problem is that the root has to have the version attribute
824                # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
825                $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
826                # We don't use Open here because we can't afford an error.
827                if (open XMLOUT, ">$fileName") {
828                    print XMLOUT $xml;
829                    close XMLOUT;
830                }
831            }
832        };
833        if ($@) {
834            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
835            # (which is a good thing).
836            my $error = $@;
837            Trace("Feed Error: $error") if T(Feed => 0);
838        }
839    }
840    
841  =head3 Assert  =head3 Assert
842    
843      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 725  Line 888 
888      my ($message) = @_;      my ($message) = @_;
889      # Trace what's happening.      # Trace what's happening.
890      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
891      my $confession = longmess($message);      # Get the stack trace.
892      # Convert the confession to a series of trace messages. Note we skip any      my @trace = LongMess();
893      # messages relating to calls into Tracer.      # Convert the trace to a series of messages.
894      for my $line (split /\s*\n/, $confession) {      for my $line (@trace) {
895          Trace($line) if ($line !~ /Tracer\.pm/);          # Replace the tab at the beginning with spaces.
896            $line =~ s/^\t/    /;
897            # Trace the line.
898            Trace($line);
899      }      }
900        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
901        Warn($message);
902  }  }
903    
904  =head3 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  
905    
906  Returns a two-element list consisting of a CGI query object and a variable hash for      my @lines = Tracer::LongMess();
 the output page.  
907    
908  =back  Return a stack trace with all tracing methods removed. The return will be in the form of a list
909    of message strings.
910    
911  =cut  =cut
912    
913  sub ScriptSetup {  sub LongMess {
914      # Get the parameters.      # Declare the return variable.
915      my ($noTrace) = @_;      my @retVal = ();
916      # Get the CGI query object.      my $confession = longmess("");
917      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
918      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
919      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
920      # Create the variable hash.              push @retVal, $line;
921      my $varHash = { results => '' };          }
922      # Return the query object and variable hash.      }
923      return ($cgi, $varHash);      # Return the result.
924        return @retVal;
925  }  }
926    
927  =head3 ETracing  =head3 ETracing
# Line 806  Line 955 
955      # Get the parameter.      # Get the parameter.
956      my ($parameter) = @_;      my ($parameter) = @_;
957      # Check for CGI mode.      # Check for CGI mode.
958      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
959            $SavedCGI = $parameter;
960        } else {
961            $SavedCGI = undef;
962        }
963      # Default to no tracing except errors.      # Default to no tracing except errors.
964      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
965      # Check for emergency tracing.      # Check for emergency tracing.
# Line 839  Line 992 
992              # Set the trace parameter.              # Set the trace parameter.
993              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
994          }          }
995      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
996          # 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
997          # for tracing from the form parameters.          # for tracing from the form parameters.
998          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
999              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1000              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1001              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1002          }          }
1003      }      }
1004      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1005      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1006      # Check to see if we're a web script.      # Check to see if we're a web script.
1007      if (defined $cgi) {      if (defined $SavedCGI) {
1008          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1009          TraceParms($cgi);          TraceParms($SavedCGI);
1010          # 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
1011          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1012          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 958  Line 1111 
1111          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
1112      } elsif ($myDest eq 'DUAL') {      } elsif ($myDest eq 'DUAL') {
1113          $retVal = "+>" . EmergencyFileTarget($tkey);          $retVal = "+>" . EmergencyFileTarget($tkey);
1114        } elsif ($myDest eq 'WARN') {
1115            $retVal = "WARN";
1116      }      }
1117      # Return the result.      # Return the result.
1118      return $retVal;      return $retVal;
# Line 1043  Line 1198 
1198      my $retVal;      my $retVal;
1199      # Determine the parameter type.      # Determine the parameter type.
1200      if (! defined $parameter) {      if (! defined $parameter) {
1201          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1202          $retVal = $ENV{TRACING};          # get the effective login ID.
1203            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1204      } else {      } else {
1205          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1206          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1086  Line 1242 
1242      my ($cgi) = @_;      my ($cgi) = @_;
1243      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1244          # Here we trace the GET-style URL for the script.          # Here we trace the GET-style URL for the script.
1245          Trace("URL: " . $cgi->url(-relative => 1, -query => 1));          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));
1246      }      }
1247      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1248          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1095  Line 1251 
1251              # Note we skip the Trace parameters, which are for our use only.              # Note we skip the Trace parameters, which are for our use only.
1252              if ($parmName ne 'Trace' && $parmName ne 'TF') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
1253                  my @values = $cgi->param($parmName);                  my @values = $cgi->param($parmName);
1254                  Trace("CGI: $parmName = " . join(", ", @values));                  Trace("[CGI] $parmName = " . join(", ", @values));
1255              }              }
1256          }          }
1257          # Display the request method.          # Display the request method.
# Line 1105  Line 1261 
1261      if (T(CGI => 4)) {      if (T(CGI => 4)) {
1262          # Here we want the environment data too.          # Here we want the environment data too.
1263          for my $envName (sort keys %ENV) {          for my $envName (sort keys %ENV) {
1264              Trace("ENV: $envName = $ENV{$envName}");              Trace("[ENV] $envName = $ENV{$envName}");
1265          }          }
1266      }      }
1267  }  }
# Line 1161  Line 1317 
1317      }      }
1318  }  }
1319    
   
 =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;  
 }  
   
1320  =head2 Command-Line Utility Methods  =head2 Command-Line Utility Methods
1321    
1322  =head3 SendSMS  =head3 SendSMS
# Line 1468  Line 1521 
1521  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
1522  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,
1523  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
1524  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
1525    login ID.
1526    
1527    Since the default situation in StandardSetup is to trace to the standard
1528    output, errors that occur in command-line scripts will not generate
1529    RSS events. To force the events, use the C<warn> option.
1530    
1531        TransactFeatures -background -warn register ../xacts IDs.tbl
1532    
1533  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1534  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 1608 
1608      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1609      # Get the default tracing key.      # Get the default tracing key.
1610      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1611        # Save the command line.
1612        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1613      # Add the tracing options.      # Add the tracing options.
1614      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1615          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
# Line 1556  Line 1618 
1618      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1619      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1620      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1621        $options->{warn} = [0, "send errors to RSS feed"];
1622      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1623      # contains the default values rather than the default value      # contains the default values rather than the default value
1624      # 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 1657 
1657          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1658              push @cats, "SQL";              push @cats, "SQL";
1659          }          }
1660            if ($retOptions->{warn}) {
1661                push @cats, "Feed";
1662            }
1663          # Add the default categories.          # Add the default categories.
1664          push @cats, "Tracer";          push @cats, "Tracer";
1665          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
# Line 1620  Line 1686 
1686              # Close the test file.              # Close the test file.
1687              close TESTTRACE;              close TESTTRACE;
1688          } else {          } else {
1689              # 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.
1690                warn "Could not open trace file $traceFileName: $!\n";
1691                # We trace to the standard output if it's
1692              # okay, and the error log otherwise.              # okay, and the error log otherwise.
1693              if ($textOKFlag) {              if ($textOKFlag) {
1694                  $traceMode = "TEXT";                  $traceMode = "TEXT";
# Line 2584  Line 2652 
2652  }  }
2653    
2654    
2655    =head3 PrintLine
2656    
2657        Tracer::PrintLine($line);
2658    
2659    Print a line of text with a trailing new-line.
2660    
2661    =over 4
2662    
2663    =item line
2664    
2665    Line of text to print.
2666    
2667    =back
2668    
2669    =cut
2670    
2671    sub PrintLine {
2672        # Get the parameters.
2673        my ($line) = @_;
2674        # Print the line.
2675        print "$line\n";
2676    }
2677    
2678    
2679  =head2 Other Useful Methods  =head2 Other Useful Methods
2680    
# Line 2624  Line 2715 
2715      return $retVal;      return $retVal;
2716  }  }
2717    
   
   
   
2718  =head3 Now  =head3 Now
2719    
2720      my $string = Tracer::Now();      my $string = Tracer::Now();
2721    
2722  Return a displayable time stamp containing the local time.  Return a displayable time stamp containing the local time. Whatever format this
2723    method produces must be parseable by L</ParseDate>.
2724    
2725  =cut  =cut
2726    
2727  sub Now {  sub Now {
2728      my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);      return DisplayTime(time);
2729      my $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .  }
2730    
2731    =head3 DisplayTime
2732    
2733        my $string = Tracer::DisplayTime($time);
2734    
2735    Convert a time value to a displayable time stamp. Whatever format this
2736    method produces must be parseable by L</ParseDate>.
2737    
2738    =over 4
2739    
2740    =item time
2741    
2742    Time to display, in seconds since the epoch, or C<undef> if the time is unknown.
2743    
2744    =item RETURN
2745    
2746    Returns a displayable time, or C<(n/a)> if the incoming time is undefined.
2747    
2748    =back
2749    
2750    =cut
2751    
2752    sub DisplayTime {
2753        my ($time) = @_;
2754        my $retVal = "(n/a)";
2755        if (defined $time) {
2756            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
2757            $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .
2758                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);
2759        }
2760      return $retVal;      return $retVal;
2761  }  }
2762    
# Line 2802  Line 2920 
2920      return $retVal;      return $retVal;
2921  }  }
2922    
2923  =head3 Min  =head3 Constrain
2924    
2925        my $constrained = Constrain($value, $min, $max);
2926    
2927    Modify a numeric value to bring it to a point in between a maximum and a minimum.
2928    
2929    =over 4
2930    
2931    =item value
2932    
2933    Value to constrain.
2934    
2935    =item min (optional)
2936    
2937    Minimum permissible value. If this parameter is undefined, no minimum constraint will be applied.
2938    
2939    =item max (optional)
2940    
2941    Maximum permissible value. If this parameter is undefined, no maximum constraint will be applied.
2942    
2943    =item RETURN
2944    
2945    Returns the incoming value, constrained according to the other parameters.
2946    
2947    =back
2948    
2949    =cut
2950    
2951    sub Constrain {
2952        # Get the parameters.
2953        my ($value, $min, $max) = @_;
2954        # Declare the return variable.
2955        my $retVal = $value;
2956        # Apply the minimum constraint.
2957        if (defined $min && $retVal < $min) {
2958            $retVal = $min;
2959        }
2960        # Apply the maximum constraint.
2961        if (defined $max && $retVal > $max) {
2962            $retVal = $max;
2963        }
2964        # Return the result.
2965        return $retVal;
2966    }
2967    
2968    =head3 Min
2969    
2970      my $min = Min($value1, $value2, ... $valueN);      my $min = Min($value1, $value2, ... $valueN);
2971    
# Line 2868  Line 3031 
3031      return $retVal;      return $retVal;
3032  }  }
3033    
 =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;  
 }  
   
3034  =head3 Strip  =head3 Strip
3035    
3036      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
# Line 3147  Line 3280 
3280      return ($inserted, $deleted);      return ($inserted, $deleted);
3281  }  }
3282    
3283    =head3 Cmp
3284    
3285        my $cmp = Tracer::Cmp($a, $b);
3286    
3287    This method performs a universal sort comparison. Each value coming in is
3288    separated into a leading text part and a trailing number part. The text
3289    part is string compared, and if both parts are equal, then the number
3290    parts are compared numerically. A stream of just numbers or a stream of
3291    just strings will sort correctly, and a mixed stream will sort with the
3292    numbers first. Strings with a label and a number will sort in the
3293    expected manner instead of lexically.
3294    
3295    =over 4
3296    
3297    =item a
3298    
3299    First item to compare.
3300    
3301    =item b
3302    
3303    Second item to compare.
3304    
3305    =item RETURN
3306    
3307    Returns a negative number if the first item should sort first (is less), a positive
3308    number if the first item should sort second (is greater), and a zero if the items are
3309    equal.
3310    
3311    =back
3312    
3313    =cut
3314    
3315    sub Cmp {
3316        # Get the parameters.
3317        my ($a, $b) = @_;
3318        # Declare the return value.
3319        my $retVal;
3320        # Check for nulls.
3321        if (! defined($a)) {
3322            $retVal = (! defined($b) ? 0 : -1);
3323        } elsif (! defined($b)) {
3324            $retVal = 1;
3325        } else {
3326            # Here we have two real values. Parse the two strings.
3327            $a =~ /^(\D*)(\d*)$/;
3328            my $aParsed = [$1, $2];
3329            $b =~ /^(\D*)(\d*)$/;
3330            my $bParsed = [$1, $2];
3331            # Compare the string parts.
3332            $retVal = $aParsed->[0] cmp $bParsed->[0];
3333            if (! $retVal) {
3334                $retVal = $aParsed->[1] <=> $bParsed->[1];
3335            }
3336        }
3337        # Return the result.
3338        return $retVal;
3339    }
3340    
3341    =head2 CGI Script Utilities
3342    
3343    =head3 ScriptSetup (deprecated)
3344    
3345        my ($cgi, $varHash) = ScriptSetup($noTrace);
3346    
3347    Perform standard tracing and debugging setup for scripts. The value returned is
3348    the CGI object followed by a pre-built variable hash. At the end of the script,
3349    the client should call L</ScriptFinish> to output the web page.
3350    
3351    This method calls L</ETracing> to configure tracing, which allows the tracing
3352    to be configured via the emergency tracing form on the debugging control panel.
3353    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3354    method, which includes every program that uses this method or L</StandardSetup>.
3355    
3356    =over 4
3357    
3358    =item noTrace (optional)
3359    
3360    If specified, tracing will be suppressed. This is useful if the script wants to set up
3361    tracing manually.
3362    
3363    =item RETURN
3364    
3365    Returns a two-element list consisting of a CGI query object and a variable hash for
3366    the output page.
3367    
3368    =back
3369    
3370    =cut
3371    
3372    sub ScriptSetup {
3373        # Get the parameters.
3374        my ($noTrace) = @_;
3375        # Get the CGI query object.
3376        my $cgi = CGI->new();
3377        # Set up tracing if it's not suppressed.
3378        ETracing($cgi) unless $noTrace;
3379        # Create the variable hash.
3380        my $varHash = { results => '' };
3381        # Return the query object and variable hash.
3382        return ($cgi, $varHash);
3383    }
3384    
3385    =head3 ScriptFinish (deprecated)
3386    
3387        ScriptFinish($webData, $varHash);
3388    
3389    Output a web page at the end of a script. Either the string to be output or the
3390    name of a template file can be specified. If the second parameter is omitted,
3391    it is assumed we have a string to be output; otherwise, it is assumed we have the
3392    name of a template file. The template should have the variable C<DebugData>
3393    specified in any form that invokes a standard script. If debugging mode is turned
3394    on, a form field will be put in that allows the user to enter tracing data.
3395    Trace messages will be placed immediately before the terminal C<BODY> tag in
3396    the output, formatted as a list.
3397    
3398    A typical standard script would loook like the following.
3399    
3400        BEGIN {
3401            # Print the HTML header.
3402            print "CONTENT-TYPE: text/html\n\n";
3403        }
3404        use Tracer;
3405        use CGI;
3406        use FIG;
3407        # ... more uses ...
3408    
3409        my ($cgi, $varHash) = ScriptSetup();
3410        eval {
3411            # ... get data from $cgi, put it in $varHash ...
3412        };
3413        if ($@) {
3414            Trace("Script Error: $@") if T(0);
3415        }
3416        ScriptFinish("Html/MyTemplate.html", $varHash);
3417    
3418    The idea here is that even if the script fails, you'll see trace messages and
3419    useful output.
3420    
3421    =over 4
3422    
3423    =item webData
3424    
3425    A string containing either the full web page to be written to the output or the
3426    name of a template file from which the page is to be constructed. If the name
3427    of a template file is specified, then the second parameter must be present;
3428    otherwise, it must be absent.
3429    
3430    =item varHash (optional)
3431    
3432    If specified, then a reference to a hash mapping variable names for a template
3433    to their values. The template file will be read into memory, and variable markers
3434    will be replaced by data in this hash reference.
3435    
3436    =back
3437    
3438    =cut
3439    
3440    sub ScriptFinish {
3441        # Get the parameters.
3442        my ($webData, $varHash) = @_;
3443        # Check for a template file situation.
3444        my $outputString;
3445        if (defined $varHash) {
3446            # Here we have a template file. We need to determine the template type.
3447            my $template;
3448            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3449                $template = "$FIG_Config::template_url/$webData";
3450            } else {
3451                $template = "<<$webData";
3452            }
3453            $outputString = PageBuilder::Build($template, $varHash, "Html");
3454        } else {
3455            # Here the user gave us a raw string.
3456            $outputString = $webData;
3457        }
3458        # Check for trace messages.
3459        if ($Destination ne "NONE" && $TraceLevel > 0) {
3460            # We have trace messages, so we want to put them at the end of the body. This
3461            # is either at the end of the whole string or at the beginning of the BODY
3462            # end-tag.
3463            my $pos = length $outputString;
3464            if ($outputString =~ m#</body>#gi) {
3465                $pos = (pos $outputString) - 7;
3466            }
3467            # If the trace messages were queued, we unroll them. Otherwise, we display the
3468            # destination.
3469            my $traceHtml;
3470            if ($Destination eq "QUEUE") {
3471                $traceHtml = QTrace('Html');
3472            } elsif ($Destination =~ /^>>(.+)$/) {
3473                # Here the tracing output it to a file. We code it as a hyperlink so the user
3474                # can copy the file name into the clipboard easily.
3475                my $actualDest = $1;
3476                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3477            } else {
3478                # Here we have one of the special destinations.
3479                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3480            }
3481            substr $outputString, $pos, 0, $traceHtml;
3482        }
3483        # Write the output string.
3484        print $outputString;
3485    }
3486    
3487  =head3 GenerateURL  =head3 GenerateURL
3488    
3489      my $queryUrl = Tracer::GenerateURL($page, %parameters);      my $queryUrl = Tracer::GenerateURL($page, %parameters);
# Line 3281  Line 3618 
3618      return $retVal;      return $retVal;
3619  }  }
3620    
3621  =head3 Cmp  =head3 TrackingCode
3622    
3623      my $cmp = Tracer::Cmp($a, $b);      my $html = Tracer::TrackingCode();
3624    
3625  This method performs a universal sort comparison. Each value coming in is  Returns the HTML code for doing web page traffic monitoring. If the
3626  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;
3627  part is string compared, and if both parts are equal, then the number  otherwise, it returns a bunch of javascript containing code for turning
3628  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.  
3629    
3630  =over 4  =cut
3631    
3632  =item a  sub TrackingCode {
3633        # Declare the return variable.
3634        my $retVal = "<!-- tracking off -->";
3635        # Determine if we're in production.
3636        if ($FIG_Config::site_meter) {
3637            $retVal = <<END_HTML
3638            <!-- Site Meter -->
3639            <script type="text/javascript" src="http://s20.sitemeter.com/js/counter.js?site=s20nmpdr">
3640            </script>
3641            <noscript>
3642            <a href="http://s20.sitemeter.com/stats.asp?site=s20nmpdr" target="_top">
3643            <img src="http://s20.sitemeter.com/meter.asp?site=s20nmpdr" alt="Site Meter" border="0"/></a>
3644            </noscript>
3645            <!-- Copyright (c)2006 Site Meter -->
3646    END_HTML
3647        }
3648        return $retVal;
3649    }
3650    
3651  First item to compare.  =head3 Clean
3652    
3653  =item b      my $cleaned = Tracer::Clean($string);
3654    
3655  Second item to compare.  Clean up a string for HTML display. This not only converts special
3656    characters to HTML entity names, it also removes control characters.
3657    
3658    =over 4
3659    
3660    =item string
3661    
3662    String to convert.
3663    
3664  =item RETURN  =item RETURN
3665    
3666  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
3667  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.  
3668    
3669  =back  =back
3670    
3671  =cut  =cut
3672    
3673  sub Cmp {  sub Clean {
3674      # Get the parameters.      # Get the parameters.
3675      my ($a, $b) = @_;      my ($string) = @_;
3676      # Declare the return value.      # Declare the return variable.
3677      my $retVal;      my $retVal = "";
3678      # Check for nulls.      # Only proceed if the value exists.
3679      if (! defined($a)) {      if (defined $string) {
3680          $retVal = (! defined($b) ? 0 : -1);          # Get the string.
3681      } elsif (! defined($b)) {          $retVal = $string;
3682          $retVal = 1;          # Clean the control characters.
3683      } else {          $retVal =~ tr/\x00-\x1F/?/;
3684          # Here we have two real values. Parse the two strings.          # Escape the rest.
3685          $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];  
         }  
3686      }      }
3687      # Return the result.      # Return the result.
3688      return $retVal;      return $retVal;
3689  }  }
3690    
3691    
3692    
3693    
3694  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3