[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.124, Thu Aug 27 19:47:14 2009 UTC
# Line 18  Line 18 
18    
19  package Tracer;  package Tracer;
20    
     require Exporter;  
     @ISA = ('Exporter');  
     @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing ScriptSetup ScriptFinish Insure ChDir Emergency);  
     @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);  
21      use strict;      use strict;
22      use Carp qw(longmess croak);      use base qw(Exporter);
23        use vars qw(@EXPORT @EXPORT_OK);
24        @EXPORT = qw(Trace T TSetup QTrace Confess MemTrace Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency Warn TraceDump IDHASH);
25        @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);
26        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 qw(:DEFAULT :flock);
42        use Data::Dumper;
43    
44    
45  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
46    
# Line 160  Line 165 
165    
166  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
167  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
168  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
169  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
170  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
171  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
172  the tracing in your environment without stepping on other users.  the tracing in your environment without stepping on other users.
# Line 184  Line 189 
189    
190  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
191  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
192  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing  using the L</StandardSetup> method or a [[WebApplication]], emergency tracing
193  will be configured automatically.  will be configured automatically.
194    
 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.  
   
195  =cut  =cut
196    
197  # Declare the configuration variables.  # Declare the configuration variables.
# Line 290  Line 201 
201                              # standard output                              # standard output
202  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
203                              # hash of active category names                              # hash of active category names
204    my @LevelNames = qw(error warn notice info detail);
205  my $TraceLevel = 0;         # trace level; a higher trace level produces more  my $TraceLevel = 0;         # trace level; a higher trace level produces more
206                              # messages                              # messages
207  my @Queue = ();             # queued list of trace messages.  my @Queue = ();             # queued list of trace messages.
208  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
209    my $LastLevel = 0;          # level of the last test call
210  my $SetupCount = 0;         # number of times TSetup called  my $SetupCount = 0;         # number of times TSetup called
211  my $AllTrace = 0;           # TRUE if we are tracing all categories.  my $AllTrace = 0;           # TRUE if we are tracing all categories.
212    my $SavedCGI;               # CGI object passed to ETracing
213    my $CommandLine;            # Command line passed to StandardSetup
214    my $Confessions = 0;        # confession count
215    umask 2;                    # Fix the damn umask so everything is group-writable.
216    
217  =head2 Tracing Methods  =head2 Tracing Methods
218    
# Line 366  Line 283 
283          }          }
284      }      }
285      # Now we need to process the destination information. The most important special      # Now we need to process the destination information. The most important special
286      # 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
287      # "+" prefix which indicates a double echo.      # ">>" (append). A leading "+" for either indicates that we are also writing to
288        # the standard output (tee mode).
289      if ($target =~ m/^\+?>>?/) {      if ($target =~ m/^\+?>>?/) {
290          if ($target =~ m/^\+/) {          if ($target =~ m/^\+/) {
291              $TeeFlag = 1;              $TeeFlag = 1;
292              $target = substr($target, 1);              $target = substr($target, 1);
293          }          }
294          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
295                # We need to initialize the file (which clears it).
296              open TRACEFILE, $target;              open TRACEFILE, $target;
297              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] [notice] [Tracer] Tracing initialized.\n";
298              close TRACEFILE;              close TRACEFILE;
299                # Set to append mode now that the file has been cleared.
300              $Destination = ">$target";              $Destination = ">$target";
301          } else {          } else {
302              $Destination = $target;              $Destination = $target;
# Line 408  Line 328 
328      $TraceLevel = $_[0];      $TraceLevel = $_[0];
329  }  }
330    
331  =head3 ParseTraceDate  =head3 ParseDate
332    
333        my $time = Tracer::ParseDate($dateString);
334    
335      my $time = Tracer::ParseTraceDate($dateString);  Convert a date into a PERL time number. This method expects a date-like string
336    and parses it into a number. The string must be vaguely date-like or it will
337    return an undefined value. Our requirement is that a month and day be
338    present and that three pieces of the date string (time of day, month and day,
339    year) be separated by likely delimiters, such as spaces, commas, and such-like.
340    
341  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
342    everything but the hour.
343    
344    The year must be exactly four digits.
345    
346    Additional stuff can be in the string. We presume it's time zones or weekdays or something
347    equally innocuous. This means, however, that a sufficiently long sentence with date-like
348    parts in it may be interpreted as a date. Hopefully this will not be a problem.
349    
350    It should be guaranteed that this method will parse the output of the L</Now> function.
351    
352    The parameters are as follows.
353    
354  =over 4  =over 4
355    
356  =item dateString  =item dateString
357    
358  The date string from the trace file. The format of the string is determined by the  The date string to convert.
 L</Now> method.  
359    
360  =item RETURN  =item RETURN
361    
362  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
363  the time string is invalid.  the date string is invalid. A valid date string must contain a month and day.
364    
365  =back  =back
366    
367  =cut  =cut
368    
369  sub ParseTraceDate {  # Universal month conversion table.
370    use constant MONTHS => {    Jan =>  0, January   =>  0, '01' =>  0,  '1' =>  0,
371                                Feb =>  1, February  =>  1, '02' =>  1,  '2' =>  1,
372                                Mar =>  2, March     =>  2, '03' =>  2,  '3' =>  2,
373                                Apr =>  3, April     =>  3, '04' =>  3,  '4' =>  3,
374                                May =>  4, May       =>  4, '05' =>  4,  '5' =>  4,
375                                Jun =>  5, June      =>  5, '06' =>  5,  '6' =>  5,
376                                Jul =>  6, July      =>  6, '07' =>  6,  '7' =>  6,
377                                Aug =>  7, August    =>  7, '08' =>  7,  '8' =>  7,
378                                Sep =>  8, September =>  8, '09' =>  8,  '9' =>  8,
379                                Oct =>  9, October  =>   9, '10' =>  9,
380                                Nov => 10, November =>  10, '11' => 10,
381                                Dec => 11, December =>  11, '12' => 11
382                            };
383    
384    sub ParseDate {
385      # Get the parameters.      # Get the parameters.
386      my ($dateString) = @_;      my ($dateString) = @_;
387      # Declare the return variable.      # Declare the return variable.
388      my $retVal;      my $retVal;
389      # Parse the date.      # Find the month and day of month. There are two ways that can happen. We check for the
390      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
391          # Create a time object. Note we need to convert the day, month,      # won't be fooled into thinking the month is Sunday.
392          # 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#) {
393          # the internal month value is relocated to January = 0.          my ($mon, $mday) = (MONTHS->{$1}, $2);
394          $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);          # Insist that the month and day are valid.
395            if (defined($mon) && $2 >= 1 && $2 <= 31) {
396                # Find the time.
397                my ($hour, $min, $sec) = (0, 0, 0);
398                if ($dateString =~ /\b(\d{1,2}):(\d{2}):(\d{2})\b/) {
399                    ($hour, $min, $sec) = ($1, $2, $3);
400                }
401                # Find the year.
402                my $year;
403                if ($dateString =~ /\b(\d{4})\b/) {
404                    $year = $1;
405                } else {
406                    # Get the default year, which is this one. Note we must convert it to
407                    # the four-digit value expected by "timelocal".
408                    (undef, undef, undef, undef, undef, $year) = localtime();
409                    $year += 1900;
410                }
411                $retVal = timelocal($sec, $min, $hour, $mday, $mon, $year);
412            }
413      }      }
414      # Return the result.      # Return the result.
415      return $retVal;      return $retVal;
# Line 489  Line 458 
458  sub Trace {  sub Trace {
459      # Get the parameters.      # Get the parameters.
460      my ($message) = @_;      my ($message) = @_;
461        # Strip off any line terminators at the end of the message. We will add
462        # new-line stuff ourselves.
463        my $stripped = Strip($message);
464        # Compute the caller information.
465        my ($callPackage, $callFile, $callLine) = caller();
466        my $callFileTitle = basename($callFile);
467        # Check the caller.
468        my $callerInfo = ($callFileTitle ne "Tracer.pm" ? " [$callFileTitle $callLine]" : "");
469      # Get the timestamp.      # Get the timestamp.
470      my $timeStamp = Now();      my $timeStamp = Now();
471      # Format the message. Note we strip off any line terminators at the end.      # Build the prefix.
472      my $prefix = "[$timeStamp] <$LastCategory>: ";      my $level = $LevelNames[$LastLevel] || "($LastLevel)";
473      my $formatted = $prefix . Strip($message);      my $prefix = "[$timeStamp] [$level] [$LastCategory]$callerInfo";
474        # Format the message.
475        my $formatted = "$prefix $stripped";
476      # Process according to the destination.      # Process according to the destination.
477      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
478          # Write the message to the standard output.          # Write the message to the standard output.
479          print "$formatted\n";          print "$formatted\n";
480      } elsif ($Destination eq "ERROR") {      } elsif ($Destination eq "ERROR") {
481          # Write the message to the error output.          # Write the message to the error output. Here, we want our prefix fields.
482          print STDERR "$formatted\n";          print STDERR "$formatted\n";
483        } elsif ($Destination eq "WARN") {
484            # Emit the message to the standard error output. It is presumed that the
485            # error logger will add its own prefix fields, the notable exception being
486            # the caller info.
487            print STDERR "$callerInfo$stripped\n";
488      } elsif ($Destination eq "QUEUE") {      } elsif ($Destination eq "QUEUE") {
489          # Push the message into the queue.          # Push the message into the queue.
490          push @Queue, "$formatted";          push @Queue, "$formatted";
491      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
492          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML.
493          my $escapedMessage = CGI::escapeHTML($message);          my $escapedMessage = CGI::escapeHTML($stripped);
494          print "<p>$timeStamp $LastCategory: $escapedMessage</p>\n";          # The stuff after the first line feed should be pre-formatted.
495      } elsif ($Destination eq "WARN") {          my @lines = split /\s*\n/, $escapedMessage;
496         # Emit the message as a warning.          # Get the normal portion.
497         carp $message;          my $line1 = shift @lines;
498            print "<p>$timeStamp $LastCategory $LastLevel: $line1</p>\n";
499            if (@lines) {
500                print "<pre>" . join("\n", @lines, "</pre>");
501            }
502      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
503          # Write the trace message to an output file.          # Write the trace message to an output file.
504          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
505            # Lock the file.
506            flock TRACING, LOCK_EX;
507          print TRACING "$formatted\n";          print TRACING "$formatted\n";
508          close TRACING;          close TRACING;
509          # 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 523  Line 513 
513      }      }
514  }  }
515    
516    =head3 MemTrace
517    
518        MemTrace($message);
519    
520    Output a trace message that includes memory size information.
521    
522    =over 4
523    
524    =item message
525    
526    Message to display. The message will be followed by a sentence about the memory size.
527    
528    =back
529    
530    =cut
531    
532    sub MemTrace {
533        # Get the parameters.
534        my ($message) = @_;
535        my $memory = GetMemorySize();
536        Trace("$message $memory in use.");
537    }
538    
539    
540    =head3 TraceDump
541    
542        TraceDump($title, $object);
543    
544    Dump an object to the trace log. This method simply calls the C<Dumper>
545    function, but routes the output to the trace log instead of returning it
546    as a string. The output is arranged so that it comes out monospaced when
547    it appears in an HTML trace dump.
548    
549    =over 4
550    
551    =item title
552    
553    Title to give to the object being dumped.
554    
555    =item object
556    
557    Reference to a list, hash, or object to dump.
558    
559    =back
560    
561    =cut
562    
563    sub TraceDump {
564        # Get the parameters.
565        my ($title, $object) = @_;
566        # Trace the object.
567        Trace("Object dump for $title:\n" . Dumper($object));
568    }
569    
570  =head3 T  =head3 T
571    
572      my $switch = T($category, $traceLevel);      my $switch = T($category, $traceLevel);
# Line 576  Line 620 
620                  $category = $cats[$#cats];                  $category = $cats[$#cats];
621              }              }
622          }          }
623          # Save the category name.          # Save the category name and level.
624          $LastCategory = $category;          $LastCategory = $category;
625            $LastLevel = $traceLevel;
626          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
627          $category = lc $category;          $category = lc $category;
628          # Use the category and tracelevel to compute the result.          # Validate the trace level.
629          if (ref $traceLevel) {          if (ref $traceLevel) {
630              Confess("Bad trace level.");              Confess("Bad trace level.");
631          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
632              Confess("Bad trace config.");              Confess("Bad trace config.");
633          }          }
634          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
635            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
636      }      }
637      # Return the computed result.      # Return the computed result.
638      return $retVal;      return $retVal;
# Line 660  Line 706 
706  sub Confess {  sub Confess {
707      # Get the parameters.      # Get the parameters.
708      my ($message) = @_;      my ($message) = @_;
709      if (! defined($FIG_Config::no_tool_hdr)) {      # Set up the category and level.
710          # Here we have a tool header. Display its length so that the user can adjust the line numbers.      $LastCategory = "(confess)";
711          my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";      $LastLevel = 0;
         # Only proceed if the tool header file is actually present.  
         if (-f $toolHeaderFile) {  
             my @lines = GetFile($toolHeaderFile);  
             Trace("Tool header has " . scalar(@lines) . " lines.");  
         }  
     }  
712      # Trace the call stack.      # Trace the call stack.
713      Cluck($message);      Cluck($message);
714        # Increment the confession count.
715        $Confessions++;
716      # Abort the program.      # Abort the program.
717      croak(">>> $message");      croak(">>> $message");
718  }  }
719    
720    =head3 Confessions
721    
722        my $count = Tracer::Confessions();
723    
724    Return the number of calls to L</Confess> by the current task.
725    
726    =cut
727    
728    sub Confessions {
729        return $Confessions;
730    }
731    
732    
733    =head3 SaveCGI
734    
735        Tracer::SaveCGI($cgi);
736    
737    This method saves the CGI object but does not activate emergency tracing.
738    It is used to allow L</Warn> to work in situations where emergency
739    tracing is contra-indicated (e.g. the wiki).
740    
741    =over 4
742    
743    =item cgi
744    
745    Active CGI query object.
746    
747    =back
748    
749    =cut
750    
751    sub SaveCGI {
752        $SavedCGI = $_[0];
753    }
754    
755    =head3 Warn
756    
757        Warn($message, @options);
758    
759    This method traces an important message. If an RSS feed is configured
760    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
761    then the message will be echoed to the feed. In general, a tracing
762    destination of C<WARN> indicates that the caller is running as a web
763    service in a production environment; however, this is not a requirement.
764    
765    To force warnings into the RSS feed even when the tracing destination
766    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
767    configured automatically when L</StandardSetup> is used.
768    
769    The L</Cluck> method calls this one for its final message. Since
770    L</Confess> calls L</Cluck>, this means that any error which is caught
771    and confessed will put something in the feed. This insures that someone
772    will be alerted relatively quickly when a failure occurs.
773    
774    =over 4
775    
776    =item message
777    
778    Message to be traced.
779    
780    =item options
781    
782    A list containing zero or more options.
783    
784    =back
785    
786    The permissible options are as follows.
787    
788    =over 4
789    
790    =item noStack
791    
792    If specified, then the stack trace is not included in the output.
793    
794    =back
795    
796    =cut
797    
798    sub Warn {
799        # Get the parameters.
800        my $message = shift @_;
801        my %options = map { $_ => 1 } @_;
802        # Save $@;
803        my $savedError = $@;
804        # Trace the message.
805        Trace($message);
806        # This will contain the lock handle. If it's defined, it means we need to unlock.
807        my $lock;
808        # Check for feed forcing.
809        my $forceFeed = exists $Categories{feed};
810        # An error here would be disastrous. Note that if debug mode is specified,
811        # we do this stuff even in a test environment.
812        eval {
813            # Do we need to put this in the RSS feed?
814            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
815                # Probably. We need to check first, however, to see if it's from an
816                # ignored IP. For non-CGI situations, we default the IP to the self-referent.
817                my $key = "127.0.0.1";
818                if (defined $SavedCGI) {
819                    # Get the IP address.
820                    $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
821                }
822                # Is the IP address in the ignore list?
823                my $found = scalar(grep { $_ eq $key } @FIG_Config::error_ignore_ips);
824                if (! $found) {
825                    # No. We're good. We now need to compute the date, the link, and the title.
826                    # First, the date, in a very specific format.
827                    my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
828                        (tz_local_offset() / 30);
829                    # Environment data goes in here. We start with the date.
830                    my $environment = "$date.  ";
831                    # If we need to recap the message (because it's too long to be a title), we'll
832                    # put it in here.
833                    my $recap;
834                    # Copy the message and remove excess space.
835                    my $title = $message;
836                    $title =~ s/\s+/ /gs;
837                    # If it's too long, we have to split it up.
838                    if (length $title > 60) {
839                        # Put the full message in the environment string.
840                        $recap = $title;
841                        # Excerpt it as the title.
842                        $title = substr($title, 0, 50) . "...";
843                    }
844                    # If we have a CGI object, then this is a web error. Otherwise, it's
845                    # command-line.
846                    if (defined $SavedCGI) {
847                        # We're in a web service. The environment is the user's IP, and the link
848                        # is the URL that got us here.
849                        $environment .= "Event Reported at IP address $key process $$.";
850                        my $url = $SavedCGI->self_url();
851                        # We need the user agent string and (if available) the referrer.
852                        # The referrer will be the link.
853                        $environment .= " User Agent $ENV{HTTP_USER_AGENT}";
854                        if ($ENV{HTTP_REFERER}) {
855                            my $link = $ENV{HTTP_REFERER};
856                            $environment .= " referred from <a href=\"$link\">$link</a>.";
857                        } else {
858                            $environment .= " referrer unknown.";
859                        }
860                        # Close off the sentence with the original link.
861                        $environment .= " URL of event is <a href=\"$url\">$url</a>.";
862                    } else {
863                        # No CGI object, so we're a command-line tool. Use the tracing
864                        # key and the PID as the user identifier, and add the command.
865                        my $key = EmergencyKey();
866                        $environment .= "Event Reported by $key process $$.";
867                        if ($CommandLine) {
868                            # We're in a StandardSetup script, so we have the real command line.
869                            $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
870                        } elsif ($ENV{_}) {
871                            # We're in a BASH script, so the command has been stored in the _ variable.
872                            $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
873                        }
874                    }
875                    # Build a GUID. We use the current time, the title, and the process ID,
876                    # then digest the result.
877                    my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
878                    # Finally, the description. This is a stack trace plus various environmental stuff.
879                    # The trace is optional.
880                    my $stackTrace;
881                    if ($options{noStack}) {
882                        $stackTrace = "";
883                    } else {
884                        my @trace = LongMess();
885                        # Only proceed if we got something back.
886                        if (scalar(@trace) > 0) {
887                            $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
888                            $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
889                        }
890                    }
891                    # We got the stack trace. Now it's time to put it all together.
892                    # We have a goofy thing here in that we need to HTML-escape some sections of the description
893                    # twice. They will be escaped once here, and then once when written by XML::Simple. They are
894                    # unescaped once when processed by the RSS reader, and stuff in the description is treated as
895                    # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
896                    # our <br>s and <pre>s are used to format the description.
897                    $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
898                    my $description = "$recap$environment  $stackTrace";
899                    # Okay, we have all the pieces. Create a hash of the new event.
900                    my $newItem = { title => $title,
901                                    description => $description,
902                                    category => $LastCategory,
903                                    pubDate => $date,
904                                    guid => $guid,
905                                  };
906                    # We need XML capability for this.
907                    require XML::Simple;
908                    # The RSS document goes in here.
909                    my $rss;
910                    # Get the name of the RSS file. It's in the FIG temporary directory.
911                    my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
912                    # Open the config file and lock it.
913                    $lock = Open(undef, "<$FIG_Config::fig_disk/config/FIG_Config.pm");
914                    flock $lock, LOCK_EX;
915                    # Does it exist?
916                    if (-s $fileName) {
917                        # Slurp it in.
918                        $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
919                    } else {
920                        my $size = -s $fileName;
921                        # Create an empty channel.
922                        $rss = {
923                            channel => {
924                                title => 'NMPDR Warning Feed',
925                                link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
926                                description => "Important messages regarding the status of the NMPDR.",
927                                generator => "NMPDR Trace Facility",
928                                docs => "http://blogs.law.harvard.edu/tech/rss",
929                                item => []
930                            },
931                        };
932                    }
933                    # Get the channel object.
934                    my $channel = $rss->{channel};
935                    # Update the last-build date.
936                    $channel->{lastBuildDate} = $date;
937                    # Get the item array.
938                    my $items = $channel->{item};
939                    # Insure it has only 100 entries.
940                    while (scalar @{$items} > 100) {
941                        pop @{$items};
942                    }
943                    # Add our new item at the front.
944                    unshift @{$items}, $newItem;
945                    # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
946                    # the requirements for those.
947                    my $xml = XML::Simple::XMLout($channel, NoAttr => 1, RootName => 'channel', XmlDecl => '');
948                    # Here we put in the root and declaration. The problem is that the root has to have the version attribute
949                    # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
950                    $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
951                    # We don't use Open here because we can't afford an error.
952                    if (open XMLOUT, ">$fileName") {
953                        print XMLOUT $xml;
954                        close XMLOUT;
955                    }
956                }
957            }
958        };
959        if ($@) {
960            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
961            # (which is a good thing).
962            my $error = $@;
963            Trace("Feed Error: $error") if T(Feed => 0);
964        }
965        # Be sure to unlock.
966        if ($lock) {
967            flock $lock, LOCK_UN;
968            undef $lock;
969        }
970        # Restore the error message.
971        $@ = $savedError;
972    }
973    
974    
975    
976    
977  =head3 Assert  =head3 Assert
978    
979      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 725  Line 1024 
1024      my ($message) = @_;      my ($message) = @_;
1025      # Trace what's happening.      # Trace what's happening.
1026      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
1027      my $confession = longmess($message);      # Get the stack trace.
1028      # Convert the confession to a series of trace messages. Note we skip any      my @trace = LongMess();
1029      # messages relating to calls into Tracer.      # Convert the trace to a series of messages.
1030      for my $line (split /\s*\n/, $confession) {      for my $line (@trace) {
1031          Trace($line) if ($line !~ /Tracer\.pm/);          # Replace the tab at the beginning with spaces.
1032            $line =~ s/^\t/    /;
1033            # Trace the line.
1034            Trace($line);
1035      }      }
1036        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
1037        Warn($message);
1038  }  }
1039    
1040  =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  
1041    
1042  Returns a two-element list consisting of a CGI query object and a variable hash for      my @lines = Tracer::LongMess();
 the output page.  
1043    
1044  =back  Return a stack trace with all tracing methods removed. The return will be in the form of a list
1045    of message strings.
1046    
1047  =cut  =cut
1048    
1049  sub ScriptSetup {  sub LongMess {
1050      # Get the parameters.      # Declare the return variable.
1051      my ($noTrace) = @_;      my @retVal = ();
1052      # Get the CGI query object.      my $confession = longmess("");
1053      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
1054      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
1055      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
1056      # Create the variable hash.              push @retVal, $line;
1057      my $varHash = { results => '' };          }
1058      # Return the query object and variable hash.      }
1059      return ($cgi, $varHash);      # Return the result.
1060        return @retVal;
1061  }  }
1062    
1063  =head3 ETracing  =head3 ETracing
1064    
1065      ETracing($parameter);      ETracing($parameter, $noParms);
1066    
1067  Set up emergency tracing. Emergency tracing is tracing that is turned  Set up emergency tracing. Emergency tracing is tracing that is turned
1068  on automatically for any program that calls this method. The emergency  on automatically for any program that calls this method. The emergency
# Line 798  Line 1083 
1083  is a CGI object and emergency tracing is not on, the C<Trace> and  is a CGI object and emergency tracing is not on, the C<Trace> and
1084  C<TF> parameters will be used to determine the type of tracing.  C<TF> parameters will be used to determine the type of tracing.
1085    
1086    =item noParms
1087    
1088    If TRUE, then CGI parameter tracing will be suppressed. The default is FALSE.
1089    
1090  =back  =back
1091    
1092  =cut  =cut
1093    
1094  sub ETracing {  sub ETracing {
1095      # Get the parameter.      # Get the parameter.
1096      my ($parameter) = @_;      my ($parameter, $noParms) = @_;
1097      # Check for CGI mode.      # Check for CGI mode.
1098      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
1099            $SavedCGI = $parameter;
1100        } else {
1101            $SavedCGI = undef;
1102        }
1103      # Default to no tracing except errors.      # Default to no tracing except errors.
1104      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
1105      # Check for emergency tracing.      # Check for emergency tracing.
# Line 839  Line 1132 
1132              # Set the trace parameter.              # Set the trace parameter.
1133              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1134          }          }
1135      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1136          # 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
1137          # for tracing from the form parameters.          # for tracing from the form parameters.
1138          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1139              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1140              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1141              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1142          }          }
1143      }      }
1144      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1145      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1146      # Check to see if we're a web script.      # Check to see if we're a web script.
1147      if (defined $cgi) {      if (defined $SavedCGI && ! $noParms) {
1148          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1149          TraceParms($cgi);          TraceParms($SavedCGI);
1150          # 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
1151          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1152          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 958  Line 1251 
1251          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
1252      } elsif ($myDest eq 'DUAL') {      } elsif ($myDest eq 'DUAL') {
1253          $retVal = "+>" . EmergencyFileTarget($tkey);          $retVal = "+>" . EmergencyFileTarget($tkey);
1254        } elsif ($myDest eq 'WARN') {
1255            $retVal = "WARN";
1256      }      }
1257      # Return the result.      # Return the result.
1258      return $retVal;      return $retVal;
# Line 1042  Line 1337 
1337      # Declare the return variable.      # Declare the return variable.
1338      my $retVal;      my $retVal;
1339      # Determine the parameter type.      # Determine the parameter type.
1340      if (! defined $parameter) {      if (! defined $parameter || defined($ENV{TRACING})) {
1341          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1342          $retVal = $ENV{TRACING};          # get the effective login ID.
1343            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1344      } else {      } else {
1345          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1346          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1085  Line 1381 
1381      # Get the parameters.      # Get the parameters.
1382      my ($cgi) = @_;      my ($cgi) = @_;
1383      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1384          # Here we trace the GET-style URL for the script.          # Here we trace the GET-style URL for the script, but only if it's
1385          Trace("URL: " . $cgi->url(-relative => 1, -query => 1));          # relatively small.
1386            my $url = $cgi->url(-relative => 1, -query => 1);
1387            my $len = length($url);
1388            if ($len < 500) {
1389                Trace("[URL] $url");
1390            } elsif ($len > 2048) {
1391                Trace("[URL] URL is too long to use with GET ($len characters).");
1392            } else {
1393                Trace("[URL] URL length is $len characters.");
1394            }
1395      }      }
1396      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1397          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1095  Line 1400 
1400              # Note we skip the Trace parameters, which are for our use only.              # Note we skip the Trace parameters, which are for our use only.
1401              if ($parmName ne 'Trace' && $parmName ne 'TF') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
1402                  my @values = $cgi->param($parmName);                  my @values = $cgi->param($parmName);
1403                  Trace("CGI: $parmName = " . join(", ", @values));                  Trace("[CGI] $parmName = " . join(", ", @values));
1404              }              }
1405          }          }
1406          # Display the request method.          # Display the request method.
# Line 1105  Line 1410 
1410      if (T(CGI => 4)) {      if (T(CGI => 4)) {
1411          # Here we want the environment data too.          # Here we want the environment data too.
1412          for my $envName (sort keys %ENV) {          for my $envName (sort keys %ENV) {
1413              Trace("ENV: $envName = $ENV{$envName}");              Trace("[ENV] $envName = $ENV{$envName}");
1414          }          }
1415      }      }
1416  }  }
# Line 1161  Line 1466 
1466      }      }
1467  }  }
1468    
1469    =head2 Command-Line Utility Methods
1470    
1471  =head3 ScriptFinish  =head3 SendSMS
   
     ScriptFinish($webData, $varHash);  
1472    
1473  Output a web page at the end of a script. Either the string to be output or the      my $msgID = Tracer::SendSMS($phoneNumber, $msg);
 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.  
1474    
1475  A typical standard script would loook like the following.  Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
1476    user name, password, and API ID for the relevant account in the hash reference variable
1477    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
1478    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
1479    is C<2561022>, then the FIG_Config file must contain
1480    
1481      BEGIN {      $phone =  { user => 'BruceTheHumanPet',
1482          # Print the HTML header.                  password => 'silly',
1483          print "CONTENT-TYPE: text/html\n\n";                  api_id => '2561022' };
     }  
     use Tracer;  
     use CGI;  
     use FIG;  
     # ... more uses ...  
1484    
1485      my ($cgi, $varHash) = ScriptSetup();  The original purpose of this method was to insure Bruce would be notified immediately when the
1486      eval {  Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
1487          # ... get data from $cgi, put it in $varHash ...  when you call this method.
     };  
     if ($@) {  
         Trace("Script Error: $@") if T(0);  
     }  
     ScriptFinish("Html/MyTemplate.html", $varHash);  
1488    
1489  The idea here is that even if the script fails, you'll see trace messages and  The message ID will be returned if successful, and C<undef> if an error occurs.
 useful output.  
1490    
1491  =over 4  =over 4
1492    
1493  =item webData  =item phoneNumber
1494    
1495  A string containing either the full web page to be written to the output or the  Phone number to receive the message, in international format. A United States phone number
1496  name of a template file from which the page is to be constructed. If the name  would be prefixed by "1". A British phone number would be prefixed by "44".
 of a template file is specified, then the second parameter must be present;  
 otherwise, it must be absent.  
1497    
1498  =item varHash (optional)  =item msg
1499    
1500  If specified, then a reference to a hash mapping variable names for a template  Message to send to the specified phone.
 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;  
 }  
   
 =head2 Command-Line Utility Methods  
   
 =head3 SendSMS  
   
     my $msgID = Tracer::SendSMS($phoneNumber, $msg);  
   
 Send a text message to a phone number using Clickatell. The FIG_Config file must contain the  
 user name, password, and API ID for the relevant account in the hash reference variable  
 I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For  
 example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID  
 is C<2561022>, then the FIG_Config file must contain  
   
     $phone =  { user => 'BruceTheHumanPet',  
                 password => 'silly',  
                 api_id => '2561022' };  
   
 The original purpose of this method was to insure Bruce would be notified immediately when the  
 Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately  
 when you call this method.  
   
 The message ID will be returned if successful, and C<undef> if an error occurs.  
   
 =over 4  
   
 =item phoneNumber  
   
 Phone number to receive the message, in international format. A United States phone number  
 would be prefixed by "1". A British phone number would be prefixed by "44".  
   
 =item msg  
   
 Message to send to the specified phone.  
1501    
1502  =item RETURN  =item RETURN
1503    
# Line 1468  Line 1670 
1670  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
1671  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,
1672  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
1673  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
1674    login ID.
1675    
1676    Since the default situation in StandardSetup is to trace to the standard
1677    output, errors that occur in command-line scripts will not generate
1678    RSS events. To force the events, use the C<warn> option.
1679    
1680        TransactFeatures -background -warn register ../xacts IDs.tbl
1681    
1682  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1683  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 1485  Line 1694 
1694          -noAlias  do not expect aliases in CHANGE transactions          -noAlias  do not expect aliases in CHANGE transactions
1695          -start    start with this genome          -start    start with this genome
1696          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
1697            -forked   do not erase the trace file before tracing
1698    
1699  The caller has the option of modifying the tracing scheme by placing a value  The caller has the option of modifying the tracing scheme by placing a value
1700  for C<trace> in the incoming options hash. The default value can be overridden,  for C<trace> in the incoming options hash. The default value can be overridden,
# Line 1548  Line 1758 
1758      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1759      # Get the default tracing key.      # Get the default tracing key.
1760      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1761        # Save the command line.
1762        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1763      # Add the tracing options.      # Add the tracing options.
1764      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1765          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
1766      }      }
1767        if (! exists $options->{forked}) {
1768            $options->{forked} = [0, "keep old trace file"];
1769        }
1770      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
1771      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1772      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1773      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1774        $options->{warn} = [0, "send errors to RSS feed"];
1775        $options->{moreTracing} = ["", "comma-delimited list of additional trace modules for debugging"];
1776      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1777      # contains the default values rather than the default value      # contains the default values rather than the default value
1778      # 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 1572  Line 1789 
1789      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
1790      # Get the logfile suffix.      # Get the logfile suffix.
1791      my $suffix = $retOptions->{user};      my $suffix = $retOptions->{user};
1792      # Check for background mode.      # We'll put the trace file name in here. We need it later if background
1793      if ($retOptions->{background}) {      # mode is on.
1794          my $outFileName = "$FIG_Config::temp/out$suffix.log";      my $traceFileName;
         my $errFileName = "$FIG_Config::temp/err$suffix.log";  
         open STDOUT, ">$outFileName";  
         open STDERR, ">$errFileName";  
         # Check for phone support. If we have phone support and a phone number,  
         # we want to turn it on.  
         if ($ENV{PHONE} && defined($FIG_Config::phone)) {  
             $retOptions->{phone} = $ENV{PHONE};  
         }  
     }  
1795      # Now we want to set up tracing. First, we need to know if the user      # Now we want to set up tracing. First, we need to know if the user
1796      # wants emergency tracing.      # wants emergency tracing.
1797      if ($retOptions->{trace} eq 'E') {      if ($retOptions->{trace} eq 'E') {
# Line 1594  Line 1802 
1802          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1803              push @cats, "SQL";              push @cats, "SQL";
1804          }          }
1805            if ($retOptions->{warn}) {
1806                push @cats, "Feed";
1807            }
1808          # Add the default categories.          # Add the default categories.
1809          push @cats, "Tracer";          push @cats, "Tracer";
1810            # Check for more tracing groups.
1811            if ($retOptions->{moreTracing}) {
1812                push @cats, split /,/, $retOptions->{moreTracing};
1813            }
1814          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
1815          my $cats = join(" ", @cats);          my $cats = join(" ", @cats);
1816          # Check to determine whether or not the caller wants to turn off tracing          # Check to determine whether or not the caller wants to turn off tracing
# Line 1610  Line 1825 
1825          my $traceMode;          my $traceMode;
1826          # Verify that we can open a file in the FIG temporary directory.          # Verify that we can open a file in the FIG temporary directory.
1827          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
1828          if (open TESTTRACE, ">$traceFileName") {          my $traceFileSpec = ($retOptions->{forked} ? ">>$traceFileName" : ">$traceFileName");
1829            if (open TESTTRACE, "$traceFileSpec") {
1830              # Here we can trace to a file.              # Here we can trace to a file.
1831              $traceMode = ">$traceFileName";              $traceMode = ">>$traceFileName";
1832              if ($textOKFlag) {              if ($textOKFlag) {
1833                  # Echo to standard output if the text-OK flag is set.                  # Echo to standard output if the text-OK flag is set.
1834                  $traceMode = "+$traceMode";                  $traceMode = "+$traceMode";
# Line 1620  Line 1836 
1836              # Close the test file.              # Close the test file.
1837              close TESTTRACE;              close TESTTRACE;
1838          } else {          } else {
1839              # 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.
1840                warn "Could not open trace file $traceFileName: $!\n";
1841                # We trace to the standard output if it's
1842              # okay, and the error log otherwise.              # okay, and the error log otherwise.
1843              if ($textOKFlag) {              if ($textOKFlag) {
1844                  $traceMode = "TEXT";                  $traceMode = "TEXT";
# Line 1631  Line 1849 
1849          # Now set up the tracing.          # Now set up the tracing.
1850          TSetup("$traceLevel $cats", $traceMode);          TSetup("$traceLevel $cats", $traceMode);
1851      }      }
1852        # Check for background mode.
1853        if ($retOptions->{background}) {
1854            my $outFileName = "$FIG_Config::temp/out$suffix$$.log";
1855            my $errFileName = "$FIG_Config::temp/err$suffix$$.log";
1856            # Spool the output.
1857            open STDOUT, ">$outFileName";
1858            # If we have a trace file, trace the errors to the log. Otherwise,
1859            # spool the errors.
1860            if (defined $traceFileName) {
1861                open STDERR, "| Tracer $traceFileName";
1862            } else {
1863                open STDERR, ">$errFileName";
1864            }
1865            # Check for phone support. If we have phone support and a phone number,
1866            # we want to turn it on.
1867            if ($ENV{PHONE} && defined($FIG_Config::phone)) {
1868                $retOptions->{phone} = $ENV{PHONE};
1869            }
1870        }
1871      # Check for the "help" option. If it is specified, dump the command-line      # Check for the "help" option. If it is specified, dump the command-line
1872      # options and exit the program.      # options and exit the program.
1873      if ($retOptions->{help}) {      if ($retOptions->{help}) {
# Line 1811  Line 2048 
2048      }      }
2049  }  }
2050    
2051    =head3 UnparseOptions
2052    
2053        my $optionString = Tracer::UnparseOptions(\%options);
2054    
2055    Convert an option hash into a command-line string. This will not
2056    necessarily be the same text that came in, but it will nonetheless
2057    produce the same ultimate result when parsed by L</StandardSetup>.
2058    
2059    =over 4
2060    
2061    =item options
2062    
2063    Reference to a hash of options to convert into an option string.
2064    
2065    =item RETURN
2066    
2067    Returns a string that will parse to the same set of options when
2068    parsed by L</StandardSetup>.
2069    
2070    =back
2071    
2072    =cut
2073    
2074    sub UnparseOptions {
2075        # Get the parameters.
2076        my ($options) = @_;
2077        # The option segments will be put in here.
2078        my @retVal = ();
2079        # Loop through the options.
2080        for my $key (keys %$options) {
2081            # Get the option value.
2082            my $value = $options->{$key};
2083            # Only use it if it's nonempty.
2084            if (defined $value && $value ne "") {
2085                my $segment = "--$key=$value";
2086                # Quote it if necessary.
2087                if ($segment =~ /[ |<>*]/) {
2088                    $segment = '"' . $segment . '"';
2089                }
2090                # Add it to the return list.
2091                push @retVal, $segment;
2092            }
2093        }
2094        # Return the result.
2095        return join(" ", @retVal);
2096    }
2097    
2098  =head3 ParseCommand  =head3 ParseCommand
2099    
2100      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);
# Line 2283  Line 2567 
2567          } else {          } else {
2568              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
2569          }          }
2570            closedir $dirHandle;
2571      } elsif (! $flag) {      } elsif (! $flag) {
2572          # Here the directory would not open and it's considered an error.          # Here the directory would not open and it's considered an error.
2573          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
# Line 2389  Line 2674 
2674  Map of search patterns to permission masks. If a directory name matches  Map of search patterns to permission masks. If a directory name matches
2675  one of the patterns, that directory and all its members and subdirectories  one of the patterns, that directory and all its members and subdirectories
2676  will be assigned the new pattern. For example, the following would  will be assigned the new pattern. For example, the following would
2677  assign 01664 to most files, but would use 01777 for directories named C<tmp>.  assign 0664 to most files, but would use 0777 for directories named C<tmp>.
2678    
2679      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2680    
# Line 2442  Line 2727 
2727                      $match = 1;                      $match = 1;
2728                  }                  }
2729              }              }
2730              # Check for a match. Note we use $i-1 because the loop added 2              # Find out if we have a match. Note we use $i-1 because the loop added 2
2731              # before terminating due to the match.              # before terminating due to the match.
2732              if ($match && $otherMasks[$i-1] != $mask) {              if ($match && $otherMasks[$i-1] != $mask) {
2733                  # This directory matches one of the incoming patterns, and it's                  # This directory matches one of the incoming patterns, and it's
# Line 2584  Line 2869 
2869  }  }
2870    
2871    
2872    =head3 PrintLine
2873    
2874        Tracer::PrintLine($line);
2875    
2876    Print a line of text with a trailing new-line.
2877    
2878    =over 4
2879    
2880    =item line
2881    
2882    Line of text to print.
2883    
2884    =back
2885    
2886    =cut
2887    
2888    sub PrintLine {
2889        # Get the parameters.
2890        my ($line) = @_;
2891        # Print the line.
2892        print "$line\n";
2893    }
2894    
2895    
2896  =head2 Other Useful Methods  =head2 Other Useful Methods
2897    
2898    =head3 IDHASH
2899    
2900        my $hash = SHTargetSearch::IDHASH(@keys);
2901    
2902    This is a dinky little method that converts a list of values to a reference
2903    to hash of values to labels. The values and labels are the same.
2904    
2905    =cut
2906    
2907    sub IDHASH {
2908        my %retVal = map { $_ => $_ } @_;
2909        return \%retVal;
2910    }
2911    
2912    =head3 Pluralize
2913    
2914        my $plural = Tracer::Pluralize($word);
2915    
2916    This is a very simple pluralization utility. It adds an C<s> at the end
2917    of the input word unless it already ends in an C<s>, in which case it
2918    adds C<es>.
2919    
2920    =over 4
2921    
2922    =item word
2923    
2924    Singular word to pluralize.
2925    
2926    =item RETURN
2927    
2928    Returns the probable plural form of the word.
2929    
2930    =back
2931    
2932    =cut
2933    
2934    sub Pluralize {
2935        # Get the parameters.
2936        my ($word) = @_;
2937        # Declare the return variable.
2938        my $retVal;
2939        if ($word =~ /s$/) {
2940            $retVal = $word . 'es';
2941        } else {
2942            $retVal = $word . 's';
2943        }
2944        # Return the result.
2945        return $retVal;
2946    }
2947    
2948    =head3 Numeric
2949    
2950        my $okFlag = Tracer::Numeric($string);
2951    
2952    Return the value of the specified string if it is numeric, or an undefined value
2953    if it is not numeric.
2954    
2955    =over 4
2956    
2957    =item string
2958    
2959    String to check.
2960    
2961    =item RETURN
2962    
2963    Returns the numeric value of the string if successful, or C<undef> if the string
2964    is not numeric.
2965    
2966    =back
2967    
2968    =cut
2969    
2970    sub Numeric {
2971        # Get the parameters.
2972        my ($string) = @_;
2973        # We'll put the value in here if we succeed.
2974        my $retVal;
2975        # Get a working copy of the string.
2976        my $copy = $string;
2977        # Trim leading and trailing spaces.
2978        $copy =~ s/^\s+//;
2979        $copy =~ s/\s+$//;
2980        # Check the result.
2981        if ($copy =~ /^[+-]?\d+$/) {
2982            $retVal = $copy;
2983        } elsif ($copy =~ /^([+-]\d+|\d*)[eE][+-]?\d+$/) {
2984            $retVal = $copy;
2985        } elsif ($copy =~ /^([+-]\d+|\d*)\.\d*([eE][+-]?\d+)?$/) {
2986            $retVal = $copy;
2987        }
2988        # Return the result.
2989        return $retVal;
2990    }
2991    
2992    
2993  =head3 ParseParm  =head3 ParseParm
2994    
2995      my $listValue = Tracer::ParseParm($string);      my $listValue = Tracer::ParseParm($string);
# Line 2624  Line 3027 
3027      return $retVal;      return $retVal;
3028  }  }
3029    
   
   
   
3030  =head3 Now  =head3 Now
3031    
3032      my $string = Tracer::Now();      my $string = Tracer::Now();
3033    
3034  Return a displayable time stamp containing the local time.  Return a displayable time stamp containing the local time. Whatever format this
3035    method produces must be parseable by L</ParseDate>.
3036    
3037  =cut  =cut
3038    
3039  sub Now {  sub Now {
3040      my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);      return DisplayTime(time);
3041      my $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .  }
3042    
3043    =head3 DisplayTime
3044    
3045        my $string = Tracer::DisplayTime($time);
3046    
3047    Convert a time value to a displayable time stamp. Whatever format this
3048    method produces must be parseable by L</ParseDate>.
3049    
3050    =over 4
3051    
3052    =item time
3053    
3054    Time to display, in seconds since the epoch, or C<undef> if the time is unknown.
3055    
3056    =item RETURN
3057    
3058    Returns a displayable time, or C<(n/a)> if the incoming time is undefined.
3059    
3060    =back
3061    
3062    =cut
3063    
3064    sub DisplayTime {
3065        my ($time) = @_;
3066        my $retVal = "(n/a)";
3067        if (defined $time) {
3068            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
3069            $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .
3070                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);
3071        }
3072      return $retVal;      return $retVal;
3073  }  }
3074    
# Line 2802  Line 3232 
3232      return $retVal;      return $retVal;
3233  }  }
3234    
3235    =head3 In
3236    
3237        my $flag = Tracer::In($value, $min, $max);
3238    
3239    Return TRUE if the value is between the minimum and the maximum, else FALSE.
3240    
3241    =cut
3242    
3243    sub In {
3244        return ($_[0] <= $_[2] && $_[0] >= $_[1]);
3245    }
3246    
3247    
3248    =head3 Constrain
3249    
3250        my $constrained = Constrain($value, $min, $max);
3251    
3252    Modify a numeric value to bring it to a point in between a maximum and a minimum.
3253    
3254    =over 4
3255    
3256    =item value
3257    
3258    Value to constrain.
3259    
3260    =item min (optional)
3261    
3262    Minimum permissible value. If this parameter is undefined, no minimum constraint will be applied.
3263    
3264    =item max (optional)
3265    
3266    Maximum permissible value. If this parameter is undefined, no maximum constraint will be applied.
3267    
3268    =item RETURN
3269    
3270    Returns the incoming value, constrained according to the other parameters.
3271    
3272    =back
3273    
3274    =cut
3275    
3276    sub Constrain {
3277        # Get the parameters.
3278        my ($value, $min, $max) = @_;
3279        # Declare the return variable.
3280        my $retVal = $value;
3281        # Apply the minimum constraint.
3282        if (defined $min && $retVal < $min) {
3283            $retVal = $min;
3284        }
3285        # Apply the maximum constraint.
3286        if (defined $max && $retVal > $max) {
3287            $retVal = $max;
3288        }
3289        # Return the result.
3290        return $retVal;
3291    }
3292    
3293  =head3 Min  =head3 Min
3294    
3295      my $min = Min($value1, $value2, ... $valueN);      my $min = Min($value1, $value2, ... $valueN);
# Line 2868  Line 3356 
3356      return $retVal;      return $retVal;
3357  }  }
3358    
 =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;  
 }  
   
3359  =head3 Strip  =head3 Strip
3360    
3361      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
# Line 2930  Line 3388 
3388      return $retVal;      return $retVal;
3389  }  }
3390    
3391    =head3 Trim
3392    
3393        my $string = Tracer::Trim($line);
3394    
3395    Trim all spaces from the beginning and ending of a string.
3396    
3397    =over 4
3398    
3399    =item line
3400    
3401    Line of text to be trimmed.
3402    
3403    =item RETURN
3404    
3405    The same line of text with all whitespace chopped off either end.
3406    
3407    =back
3408    
3409    =cut
3410    
3411    sub Trim {
3412        # Get a copy of the parameter string.
3413        my ($string) = @_;
3414        my $retVal = (defined $string ? $string : "");
3415        # Strip the front spaces.
3416        $retVal =~ s/^\s+//;
3417        # Strip the back spaces.
3418        $retVal =~ s/\s+$//;
3419        # Return the result.
3420        return $retVal;
3421    }
3422    
3423  =head3 Pad  =head3 Pad
3424    
3425      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);
# Line 2991  Line 3481 
3481      return $retVal;      return $retVal;
3482  }  }
3483    
3484    =head3 Quoted
3485    
3486        my $string = Tracer::Quoted($var);
3487    
3488    Convert the specified value to a string and enclose it in single quotes.
3489    If it's undefined, the string C<undef> in angle brackets will be used
3490    instead.
3491    
3492    =over 4
3493    
3494    =item var
3495    
3496    Value to quote.
3497    
3498    =item RETURN
3499    
3500    Returns a string enclosed in quotes, or an indication the value is undefined.
3501    
3502    =back
3503    
3504    =cut
3505    
3506    sub Quoted {
3507        # Get the parameters.
3508        my ($var) = @_;
3509        # Declare the return variable.
3510        my $retVal;
3511        # Are we undefined?
3512        if (! defined $var) {
3513            $retVal = "<undef>";
3514        } else {
3515            # No, so convert to a string and enclose in quotes.
3516            $retVal = $var;
3517            $retVal =~ s/'/\\'/;
3518            $retVal = "'$retVal'";
3519        }
3520        # Return the result.
3521        return $retVal;
3522    }
3523    
3524  =head3 EOF  =head3 EOF
3525    
3526  This is a constant that is lexically greater than any useful string.  This is a constant that is lexically greater than any useful string.
# Line 3080  Line 3610 
3610  }  }
3611    
3612    
3613    =head3 GetMemorySize
3614    
3615        my $string = Tracer::GetMemorySize();
3616    
3617    Return a memory size string for the current process. The string will be
3618    in comma format, with a size indicator (K, M, G) at the end.
3619    
3620    =cut
3621    
3622    sub GetMemorySize {
3623        # Get the memory size from Unix.
3624        my ($retVal) = `ps h -o vsz $$`;
3625        # Remove the ending new-line.
3626        chomp $retVal;
3627        # Format and return the result.
3628        return CommaFormat($retVal) . "K";
3629    }
3630    
3631  =head3 CompareLists  =head3 CompareLists
3632    
3633      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);
# Line 3147  Line 3695 
3695      return ($inserted, $deleted);      return ($inserted, $deleted);
3696  }  }
3697    
3698    =head3 Cmp
3699    
3700        my $cmp = Tracer::Cmp($a, $b);
3701    
3702    This method performs a universal sort comparison. Each value coming in is
3703    separated into a text parts and number parts. The text
3704    part is string compared, and if both parts are equal, then the number
3705    parts are compared numerically. A stream of just numbers or a stream of
3706    just strings will sort correctly, and a mixed stream will sort with the
3707    numbers first. Strings with a label and a number will sort in the
3708    expected manner instead of lexically. Undefined values sort last.
3709    
3710    =over 4
3711    
3712    =item a
3713    
3714    First item to compare.
3715    
3716    =item b
3717    
3718    Second item to compare.
3719    
3720    =item RETURN
3721    
3722    Returns a negative number if the first item should sort first (is less), a positive
3723    number if the first item should sort second (is greater), and a zero if the items are
3724    equal.
3725    
3726    =back
3727    
3728    =cut
3729    
3730    sub Cmp {
3731        # Get the parameters.
3732        my ($a, $b) = @_;
3733        # Declare the return value.
3734        my $retVal;
3735        # Check for nulls.
3736        if (! defined($a)) {
3737            $retVal = (! defined($b) ? 0 : -1);
3738        } elsif (! defined($b)) {
3739            $retVal = 1;
3740        } else {
3741            # Here we have two real values. Parse the two strings.
3742            my @aParsed = _Parse($a);
3743            my @bParsed = _Parse($b);
3744            # Loop through the first string.
3745            while (! $retVal && @aParsed) {
3746                # Extract the string parts.
3747                my $aPiece = shift(@aParsed);
3748                my $bPiece = shift(@bParsed) || '';
3749                # Extract the number parts.
3750                my $aNum = shift(@aParsed);
3751                my $bNum = shift(@bParsed) || 0;
3752                # Compare the string parts insensitively.
3753                $retVal = (lc($aPiece) cmp lc($bPiece));
3754                # If they're equal, compare them sensitively.
3755                if (! $retVal) {
3756                    $retVal = ($aPiece cmp $bPiece);
3757                    # If they're STILL equal, compare the number parts.
3758                    if (! $retVal) {
3759                        $retVal = $aNum <=> $bNum;
3760                    }
3761                }
3762            }
3763        }
3764        # Return the result.
3765        return $retVal;
3766    }
3767    
3768    # This method parses an input string into a string parts alternating with
3769    # number parts.
3770    sub _Parse {
3771        # Get the incoming string.
3772        my ($string) = @_;
3773        # The pieces will be put in here.
3774        my @retVal;
3775        # Loop through as many alpha/num sets as we can.
3776        while ($string =~ /^(\D*)(\d+)(.*)/) {
3777            # Push the alpha and number parts into the return string.
3778            push @retVal, $1, $2;
3779            # Save the residual.
3780            $string = $3;
3781        }
3782        # If there's still stuff left, add it to the end with a trailing
3783        # zero.
3784        if ($string) {
3785            push @retVal, $string, 0;
3786        }
3787        # Return the list.
3788        return @retVal;
3789    }
3790    
3791    =head3 ListEQ
3792    
3793        my $flag = Tracer::ListEQ(\@a, \@b);
3794    
3795    Return TRUE if the specified lists contain the same strings in the same
3796    order, else FALSE.
3797    
3798    =over 4
3799    
3800    =item a
3801    
3802    Reference to the first list.
3803    
3804    =item b
3805    
3806    Reference to the second list.
3807    
3808    =item RETURN
3809    
3810    Returns TRUE if the two parameters are identical string lists, else FALSE.
3811    
3812    =back
3813    
3814    =cut
3815    
3816    sub ListEQ {
3817        # Get the parameters.
3818        my ($a, $b) = @_;
3819        # Declare the return variable. Start by checking the lengths.
3820        my $n = scalar(@$a);
3821        my $retVal = ($n == scalar(@$b));
3822        # Now compare the list elements.
3823        for (my $i = 0; $retVal && $i < $n; $i++) {
3824            $retVal = ($a->[$i] eq $b->[$i]);
3825        }
3826        # Return the result.
3827        return $retVal;
3828    }
3829    
3830    =head2 CGI Script Utilities
3831    
3832    =head3 ScriptSetup (deprecated)
3833    
3834        my ($cgi, $varHash) = ScriptSetup($noTrace);
3835    
3836    Perform standard tracing and debugging setup for scripts. The value returned is
3837    the CGI object followed by a pre-built variable hash. At the end of the script,
3838    the client should call L</ScriptFinish> to output the web page.
3839    
3840    This method calls L</ETracing> to configure tracing, which allows the tracing
3841    to be configured via the emergency tracing form on the debugging control panel.
3842    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3843    method, which includes every program that uses this method or L</StandardSetup>.
3844    
3845    =over 4
3846    
3847    =item noTrace (optional)
3848    
3849    If specified, tracing will be suppressed. This is useful if the script wants to set up
3850    tracing manually.
3851    
3852    =item RETURN
3853    
3854    Returns a two-element list consisting of a CGI query object and a variable hash for
3855    the output page.
3856    
3857    =back
3858    
3859    =cut
3860    
3861    sub ScriptSetup {
3862        # Get the parameters.
3863        my ($noTrace) = @_;
3864        # Get the CGI query object.
3865        my $cgi = CGI->new();
3866        # Set up tracing if it's not suppressed.
3867        ETracing($cgi) unless $noTrace;
3868        # Create the variable hash.
3869        my $varHash = { results => '' };
3870        # Return the query object and variable hash.
3871        return ($cgi, $varHash);
3872    }
3873    
3874    =head3 ScriptFinish (deprecated)
3875    
3876        ScriptFinish($webData, $varHash);
3877    
3878    Output a web page at the end of a script. Either the string to be output or the
3879    name of a template file can be specified. If the second parameter is omitted,
3880    it is assumed we have a string to be output; otherwise, it is assumed we have the
3881    name of a template file. The template should have the variable C<DebugData>
3882    specified in any form that invokes a standard script. If debugging mode is turned
3883    on, a form field will be put in that allows the user to enter tracing data.
3884    Trace messages will be placed immediately before the terminal C<BODY> tag in
3885    the output, formatted as a list.
3886    
3887    A typical standard script would loook like the following.
3888    
3889        BEGIN {
3890            # Print the HTML header.
3891            print "CONTENT-TYPE: text/html\n\n";
3892        }
3893        use Tracer;
3894        use CGI;
3895        use FIG;
3896        # ... more uses ...
3897    
3898        my ($cgi, $varHash) = ScriptSetup();
3899        eval {
3900            # ... get data from $cgi, put it in $varHash ...
3901        };
3902        if ($@) {
3903            Trace("Script Error: $@") if T(0);
3904        }
3905        ScriptFinish("Html/MyTemplate.html", $varHash);
3906    
3907    The idea here is that even if the script fails, you'll see trace messages and
3908    useful output.
3909    
3910    =over 4
3911    
3912    =item webData
3913    
3914    A string containing either the full web page to be written to the output or the
3915    name of a template file from which the page is to be constructed. If the name
3916    of a template file is specified, then the second parameter must be present;
3917    otherwise, it must be absent.
3918    
3919    =item varHash (optional)
3920    
3921    If specified, then a reference to a hash mapping variable names for a template
3922    to their values. The template file will be read into memory, and variable markers
3923    will be replaced by data in this hash reference.
3924    
3925    =back
3926    
3927    =cut
3928    
3929    sub ScriptFinish {
3930        # Get the parameters.
3931        my ($webData, $varHash) = @_;
3932        # Check for a template file situation.
3933        my $outputString;
3934        if (defined $varHash) {
3935            # Here we have a template file. We need to determine the template type.
3936            my $template;
3937            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3938                $template = "$FIG_Config::template_url/$webData";
3939            } else {
3940                $template = "<<$webData";
3941            }
3942            $outputString = PageBuilder::Build($template, $varHash, "Html");
3943        } else {
3944            # Here the user gave us a raw string.
3945            $outputString = $webData;
3946        }
3947        # Check for trace messages.
3948        if ($Destination ne "NONE" && $TraceLevel > 0) {
3949            # We have trace messages, so we want to put them at the end of the body. This
3950            # is either at the end of the whole string or at the beginning of the BODY
3951            # end-tag.
3952            my $pos = length $outputString;
3953            if ($outputString =~ m#</body>#gi) {
3954                $pos = (pos $outputString) - 7;
3955            }
3956            # If the trace messages were queued, we unroll them. Otherwise, we display the
3957            # destination.
3958            my $traceHtml;
3959            if ($Destination eq "QUEUE") {
3960                $traceHtml = QTrace('Html');
3961            } elsif ($Destination =~ /^>>(.+)$/) {
3962                # Here the tracing output it to a file. We code it as a hyperlink so the user
3963                # can copy the file name into the clipboard easily.
3964                my $actualDest = $1;
3965                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3966            } else {
3967                # Here we have one of the special destinations.
3968                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3969            }
3970            substr $outputString, $pos, 0, $traceHtml;
3971        }
3972        # Write the output string.
3973        print $outputString;
3974    }
3975    
3976  =head3 GenerateURL  =head3 GenerateURL
3977    
3978      my $queryUrl = Tracer::GenerateURL($page, %parameters);      my $queryUrl = Tracer::GenerateURL($page, %parameters);
# Line 3281  Line 4107 
4107      return $retVal;      return $retVal;
4108  }  }
4109    
4110  =head3 Cmp  =head3 TrackingCode
4111    
4112      my $cmp = Tracer::Cmp($a, $b);      my $html = Tracer::TrackingCode();
4113    
4114  This method performs a universal sort comparison. Each value coming in is  Returns the HTML code for doing web page traffic monitoring. If the
4115  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;
4116  part is string compared, and if both parts are equal, then the number  otherwise, it returns a bunch of javascript containing code for turning
4117  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.  
4118    
4119  =over 4  =cut
4120    
4121  =item a  sub TrackingCode {
4122        # Declare the return variable.
4123        my $retVal = "<!-- tracking off -->";
4124        # Determine if we're in production.
4125        if ($FIG_Config::site_meter) {
4126            $retVal = <<END_HTML
4127            <!-- Site Meter -->
4128            <script type="text/javascript" src="http://s20.sitemeter.com/js/counter.js?site=s20nmpdr">
4129            </script>
4130            <noscript>
4131            <a href="http://s20.sitemeter.com/stats.asp?site=s20nmpdr" target="_top">
4132            <img src="http://s20.sitemeter.com/meter.asp?site=s20nmpdr" alt="Site Meter" border="0"/></a>
4133            </noscript>
4134            <!-- Copyright (c)2006 Site Meter -->
4135    END_HTML
4136        }
4137        return $retVal;
4138    }
4139    
4140  First item to compare.  =head3 Clean
4141    
4142  =item b      my $cleaned = Tracer::Clean($string);
4143    
4144  Second item to compare.  Clean up a string for HTML display. This not only converts special
4145    characters to HTML entity names, it also removes control characters.
4146    
4147    =over 4
4148    
4149    =item string
4150    
4151    String to convert.
4152    
4153  =item RETURN  =item RETURN
4154    
4155  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
4156  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.  
4157    
4158  =back  =back
4159    
4160  =cut  =cut
4161    
4162  sub Cmp {  sub Clean {
4163      # Get the parameters.      # Get the parameters.
4164      my ($a, $b) = @_;      my ($string) = @_;
4165      # Declare the return value.      # Declare the return variable.
4166      my $retVal;      my $retVal = "";
4167      # Check for nulls.      # Only proceed if the value exists.
4168      if (! defined($a)) {      if (defined $string) {
4169          $retVal = (! defined($b) ? 0 : -1);          # Get the string.
4170      } elsif (! defined($b)) {          $retVal = $string;
4171          $retVal = 1;          # Clean the control characters.
4172      } else {          $retVal =~ tr/\x00-\x1F/?/;
4173          # Here we have two real values. Parse the two strings.          # Escape the rest.
4174          $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];  
         }  
4175      }      }
4176      # Return the result.      # Return the result.
4177      return $retVal;      return $retVal;
4178  }  }
4179    
4180    =head3 SortByValue
4181    
4182        my @keys = Tracer::SortByValue(\%hash);
4183    
4184    Get a list of hash table keys sorted by hash table values.
4185    
4186    =over 4
4187    
4188    =item hash
4189    
4190    Hash reference whose keys are to be extracted.
4191    
4192    =item RETURN
4193    
4194    Returns a list of the hash keys, ordered so that the corresponding hash values
4195    are in alphabetical sequence.
4196    
4197    =back
4198    
4199    =cut
4200    
4201    sub SortByValue {
4202        # Get the parameters.
4203        my ($hash) = @_;
4204        # Sort the hash's keys using the values.
4205        my @retVal = sort { Cmp($hash->{$a}, $hash->{$b}) } keys %$hash;
4206        # Return the result.
4207        return @retVal;
4208    }
4209    
4210    =head3 GetSet
4211    
4212        my $value = Tracer::GetSet($object, $name => $newValue);
4213    
4214    Get or set the value of an object field. The object is treated as an
4215    ordinary hash reference. If a new value is specified, it is stored in the
4216    hash under the specified name and then returned. If no new value is
4217    specified, the current value is returned.
4218    
4219    =over 4
4220    
4221    =item object
4222    
4223    Reference to the hash that is to be interrogated or updated.
4224    
4225    =item name
4226    
4227    Name of the field. This is the hash key.
4228    
4229    =item newValue (optional)
4230    
4231    New value to be stored in the field. If no new value is specified, the current
4232    value of the field is returned.
4233    
4234    =item RETURN
4235    
4236    Returns the value of the named field in the specified hash.
4237    
4238    =back
4239    
4240    =cut
4241    
4242    sub GetSet {
4243        # Get the parameters.
4244        my ($object, $name, $newValue) = @_;
4245        # Is a new value specified?
4246        if (defined $newValue) {
4247            # Yes, so store it.
4248            $object->{$name} = $newValue;
4249        }
4250        # Return the result.
4251        return $object->{$name};
4252    }
4253    
4254  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3