[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.118, Thu May 21 18:56:28 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    umask 2;                    # Fix the damn umask so everything is group-writable.
215    
216  =head2 Tracing Methods  =head2 Tracing Methods
217    
# Line 366  Line 282 
282          }          }
283      }      }
284      # Now we need to process the destination information. The most important special      # Now we need to process the destination information. The most important special
285      # 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
286      # "+" prefix which indicates a double echo.      # ">>" (append). A leading "+" for either indicates that we are also writing to
287        # the standard output (tee mode).
288      if ($target =~ m/^\+?>>?/) {      if ($target =~ m/^\+?>>?/) {
289          if ($target =~ m/^\+/) {          if ($target =~ m/^\+/) {
290              $TeeFlag = 1;              $TeeFlag = 1;
291              $target = substr($target, 1);              $target = substr($target, 1);
292          }          }
293          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
294                # We need to initialize the file (which clears it).
295              open TRACEFILE, $target;              open TRACEFILE, $target;
296              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] [notice] [Tracer] Tracing initialized.\n";
297              close TRACEFILE;              close TRACEFILE;
298                # Set to append mode now that the file has been cleared.
299              $Destination = ">$target";              $Destination = ">$target";
300          } else {          } else {
301              $Destination = $target;              $Destination = $target;
# Line 408  Line 327 
327      $TraceLevel = $_[0];      $TraceLevel = $_[0];
328  }  }
329    
330  =head3 ParseTraceDate  =head3 ParseDate
331    
332        my $time = Tracer::ParseDate($dateString);
333    
334      my $time = Tracer::ParseTraceDate($dateString);  Convert a date into a PERL time number. This method expects a date-like string
335    and parses it into a number. The string must be vaguely date-like or it will
336    return an undefined value. Our requirement is that a month and day be
337    present and that three pieces of the date string (time of day, month and day,
338    year) be separated by likely delimiters, such as spaces, commas, and such-like.
339    
340  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
341    everything but the hour.
342    
343    The year must be exactly four digits.
344    
345    Additional stuff can be in the string. We presume it's time zones or weekdays or something
346    equally innocuous. This means, however, that a sufficiently long sentence with date-like
347    parts in it may be interpreted as a date. Hopefully this will not be a problem.
348    
349    It should be guaranteed that this method will parse the output of the L</Now> function.
350    
351    The parameters are as follows.
352    
353  =over 4  =over 4
354    
355  =item dateString  =item dateString
356    
357  The date string from the trace file. The format of the string is determined by the  The date string to convert.
 L</Now> method.  
358    
359  =item RETURN  =item RETURN
360    
361  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
362  the time string is invalid.  the date string is invalid. A valid date string must contain a month and day.
363    
364  =back  =back
365    
366  =cut  =cut
367    
368  sub ParseTraceDate {  # Universal month conversion table.
369    use constant MONTHS => {    Jan =>  0, January   =>  0, '01' =>  0,  '1' =>  0,
370                                Feb =>  1, February  =>  1, '02' =>  1,  '2' =>  1,
371                                Mar =>  2, March     =>  2, '03' =>  2,  '3' =>  2,
372                                Apr =>  3, April     =>  3, '04' =>  3,  '4' =>  3,
373                                May =>  4, May       =>  4, '05' =>  4,  '5' =>  4,
374                                Jun =>  5, June      =>  5, '06' =>  5,  '6' =>  5,
375                                Jul =>  6, July      =>  6, '07' =>  6,  '7' =>  6,
376                                Aug =>  7, August    =>  7, '08' =>  7,  '8' =>  7,
377                                Sep =>  8, September =>  8, '09' =>  8,  '9' =>  8,
378                                Oct =>  9, October  =>   9, '10' =>  9,
379                                Nov => 10, November =>  10, '11' => 10,
380                                Dec => 11, December =>  11, '12' => 11
381                            };
382    
383    sub ParseDate {
384      # Get the parameters.      # Get the parameters.
385      my ($dateString) = @_;      my ($dateString) = @_;
386      # Declare the return variable.      # Declare the return variable.
387      my $retVal;      my $retVal;
388      # Parse the date.      # Find the month and day of month. There are two ways that can happen. We check for the
389      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
390          # Create a time object. Note we need to convert the day, month,      # won't be fooled into thinking the month is Sunday.
391          # 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#) {
392          # the internal month value is relocated to January = 0.          my ($mon, $mday) = (MONTHS->{$1}, $2);
393          $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);          # Insist that the month and day are valid.
394            if (defined($mon) && $2 >= 1 && $2 <= 31) {
395                # Find the time.
396                my ($hour, $min, $sec) = (0, 0, 0);
397                if ($dateString =~ /\b(\d{1,2}):(\d{2}):(\d{2})\b/) {
398                    ($hour, $min, $sec) = ($1, $2, $3);
399                }
400                # Find the year.
401                my $year;
402                if ($dateString =~ /\b(\d{4})\b/) {
403                    $year = $1;
404                } else {
405                    # Get the default year, which is this one. Note we must convert it to
406                    # the four-digit value expected by "timelocal".
407                    (undef, undef, undef, undef, undef, $year) = localtime();
408                    $year += 1900;
409                }
410                $retVal = timelocal($sec, $min, $hour, $mday, $mon, $year);
411            }
412      }      }
413      # Return the result.      # Return the result.
414      return $retVal;      return $retVal;
# Line 489  Line 457 
457  sub Trace {  sub Trace {
458      # Get the parameters.      # Get the parameters.
459      my ($message) = @_;      my ($message) = @_;
460        # Strip off any line terminators at the end of the message. We will add
461        # new-line stuff ourselves.
462        my $stripped = Strip($message);
463        # Compute the caller information.
464        my ($callPackage, $callFile, $callLine) = caller();
465        my $callFileTitle = basename($callFile);
466        # Check the caller.
467        my $callerInfo = ($callFileTitle ne "Tracer.pm" ? " [$callFileTitle $callLine]" : "");
468      # Get the timestamp.      # Get the timestamp.
469      my $timeStamp = Now();      my $timeStamp = Now();
470      # Format the message. Note we strip off any line terminators at the end.      # Build the prefix.
471      my $prefix = "[$timeStamp] <$LastCategory>: ";      my $level = $LevelNames[$LastLevel] || "($LastLevel)";
472      my $formatted = $prefix . Strip($message);      my $prefix = "[$timeStamp] [$level] [$LastCategory]$callerInfo";
473        # Format the message.
474        my $formatted = "$prefix $stripped";
475      # Process according to the destination.      # Process according to the destination.
476      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
477          # Write the message to the standard output.          # Write the message to the standard output.
478          print "$formatted\n";          print "$formatted\n";
479      } elsif ($Destination eq "ERROR") {      } elsif ($Destination eq "ERROR") {
480          # Write the message to the error output.          # Write the message to the error output. Here, we want our prefix fields.
481          print STDERR "$formatted\n";          print STDERR "$formatted\n";
482        } elsif ($Destination eq "WARN") {
483            # Emit the message to the standard error output. It is presumed that the
484            # error logger will add its own prefix fields, the notable exception being
485            # the caller info.
486            print STDERR "$callerInfo$stripped\n";
487      } elsif ($Destination eq "QUEUE") {      } elsif ($Destination eq "QUEUE") {
488          # Push the message into the queue.          # Push the message into the queue.
489          push @Queue, "$formatted";          push @Queue, "$formatted";
490      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
491          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML.
492          my $escapedMessage = CGI::escapeHTML($message);          my $escapedMessage = CGI::escapeHTML($stripped);
493          print "<p>$timeStamp $LastCategory: $escapedMessage</p>\n";          # The stuff after the first line feed should be pre-formatted.
494      } elsif ($Destination eq "WARN") {          my @lines = split /\s*\n/, $escapedMessage;
495         # Emit the message as a warning.          # Get the normal portion.
496         carp $message;          my $line1 = shift @lines;
497            print "<p>$timeStamp $LastCategory $LastLevel: $line1</p>\n";
498            if (@lines) {
499                print "<pre>" . join("\n", @lines, "<pre>");
500            }
501      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
502          # Write the trace message to an output file.          # Write the trace message to an output file.
503          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
504            # Lock the file.
505            flock TRACING, LOCK_EX;
506          print TRACING "$formatted\n";          print TRACING "$formatted\n";
507          close TRACING;          close TRACING;
508          # 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 512 
512      }      }
513  }  }
514    
515    =head3 MemTrace
516    
517        MemTrace($message);
518    
519    Output a trace message that includes memory size information.
520    
521    =over 4
522    
523    =item message
524    
525    Message to display. The message will be followed by a sentence about the memory size.
526    
527    =back
528    
529    =cut
530    
531    sub MemTrace {
532        # Get the parameters.
533        my ($message) = @_;
534        my $memory = GetMemorySize();
535        Trace("$message $memory in use.");
536    }
537    
538    
539    =head3 TraceDump
540    
541        TraceDump($title, $object);
542    
543    Dump an object to the trace log. This method simply calls the C<Dumper>
544    function, but routes the output to the trace log instead of returning it
545    as a string. The output is arranged so that it comes out monospaced when
546    it appears in an HTML trace dump.
547    
548    =over 4
549    
550    =item title
551    
552    Title to give to the object being dumped.
553    
554    =item object
555    
556    Reference to a list, hash, or object to dump.
557    
558    =back
559    
560    =cut
561    
562    sub TraceDump {
563        # Get the parameters.
564        my ($title, $object) = @_;
565        # Trace the object.
566        Trace("Object dump for $title:\n" . Dumper($object));
567    }
568    
569  =head3 T  =head3 T
570    
571      my $switch = T($category, $traceLevel);      my $switch = T($category, $traceLevel);
# Line 576  Line 619 
619                  $category = $cats[$#cats];                  $category = $cats[$#cats];
620              }              }
621          }          }
622          # Save the category name.          # Save the category name and level.
623          $LastCategory = $category;          $LastCategory = $category;
624            $LastLevel = $traceLevel;
625          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
626          $category = lc $category;          $category = lc $category;
627          # Use the category and tracelevel to compute the result.          # Validate the trace level.
628          if (ref $traceLevel) {          if (ref $traceLevel) {
629              Confess("Bad trace level.");              Confess("Bad trace level.");
630          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
631              Confess("Bad trace config.");              Confess("Bad trace config.");
632          }          }
633          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
634            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
635      }      }
636      # Return the computed result.      # Return the computed result.
637      return $retVal;      return $retVal;
# Line 660  Line 705 
705  sub Confess {  sub Confess {
706      # Get the parameters.      # Get the parameters.
707      my ($message) = @_;      my ($message) = @_;
708      if (! defined($FIG_Config::no_tool_hdr)) {      # Set up the category and level.
709          # Here we have a tool header. Display its length so that the user can adjust the line numbers.      $LastCategory = "(confess)";
710          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.");  
         }  
     }  
711      # Trace the call stack.      # Trace the call stack.
712      Cluck($message);      Cluck($message);
713      # Abort the program.      # Abort the program.
714      croak(">>> $message");      croak(">>> $message");
715  }  }
716    
717    =head3 SaveCGI
718    
719        Tracer::SaveCGI($cgi);
720    
721    This method saves the CGI object but does not activate emergency tracing.
722    It is used to allow L</Warn> to work in situations where emergency
723    tracing is contra-indicated (e.g. the wiki).
724    
725    =over 4
726    
727    =item cgi
728    
729    Active CGI query object.
730    
731    =back
732    
733    =cut
734    
735    sub SaveCGI {
736        $SavedCGI = $_[0];
737    }
738    
739    =head3 Warn
740    
741        Warn($message, @options);
742    
743    This method traces an important message. If an RSS feed is configured
744    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
745    then the message will be echoed to the feed. In general, a tracing
746    destination of C<WARN> indicates that the caller is running as a web
747    service in a production environment; however, this is not a requirement.
748    
749    To force warnings into the RSS feed even when the tracing destination
750    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
751    configured automatically when L</StandardSetup> is used.
752    
753    The L</Cluck> method calls this one for its final message. Since
754    L</Confess> calls L</Cluck>, this means that any error which is caught
755    and confessed will put something in the feed. This insures that someone
756    will be alerted relatively quickly when a failure occurs.
757    
758    =over 4
759    
760    =item message
761    
762    Message to be traced.
763    
764    =item options
765    
766    A list containing zero or more options.
767    
768    =back
769    
770    The permissible options are as follows.
771    
772    =over 4
773    
774    =item noStack
775    
776    If specified, then the stack trace is not included in the output.
777    
778    =back
779    
780    =cut
781    
782    sub Warn {
783        # Get the parameters.
784        my $message = shift @_;
785        my %options = map { $_ => 1 } @_;
786        # Save $@;
787        my $savedError = $@;
788        # Trace the message.
789        Trace($message);
790        # This will contain the lock handle. If it's defined, it means we need to unlock.
791        my $lock;
792        # Check for feed forcing.
793        my $forceFeed = exists $Categories{feed};
794        # An error here would be disastrous. Note that if debug mode is specified,
795        # we do this stuff even in a test environment.
796        eval {
797            # Do we need to put this in the RSS feed?
798            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
799                # Probably. We need to check first, however, to see if it's from an
800                # ignored IP. For non-CGI situations, we default the IP to the self-referent.
801                my $key = "127.0.0.1";
802                if (defined $SavedCGI) {
803                    # Get the IP address.
804                    $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
805                }
806                # Is the IP address in the ignore list?
807                my $found = scalar(grep { $_ eq $key } @FIG_Config::error_ignore_ips);
808                if (! $found) {
809                    # No. We're good. We now need to compute the date, the link, and the title.
810                    # First, the date, in a very specific format.
811                    my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
812                        (tz_local_offset() / 30);
813                    # Environment data goes in here. We start with the date.
814                    my $environment = "$date.  ";
815                    # If we need to recap the message (because it's too long to be a title), we'll
816                    # put it in here.
817                    my $recap;
818                    # Copy the message and remove excess space.
819                    my $title = $message;
820                    $title =~ s/\s+/ /gs;
821                    # If it's too long, we have to split it up.
822                    if (length $title > 60) {
823                        # Put the full message in the environment string.
824                        $recap = $title;
825                        # Excerpt it as the title.
826                        $title = substr($title, 0, 50) . "...";
827                    }
828                    # If we have a CGI object, then this is a web error. Otherwise, it's
829                    # command-line.
830                    if (defined $SavedCGI) {
831                        # We're in a web service. The environment is the user's IP, and the link
832                        # is the URL that got us here.
833                        $environment .= "Event Reported at IP address $key process $$.";
834                        my $url = $SavedCGI->self_url();
835                        # We need the user agent string and (if available) the referrer.
836                        # The referrer will be the link.
837                        $environment .= " User Agent $ENV{HTTP_USER_AGENT}";
838                        if ($ENV{HTTP_REFERER}) {
839                            my $link = $ENV{HTTP_REFERER};
840                            $environment .= " referred from <a href=\"$link\">$link</a>.";
841                        } else {
842                            $environment .= " referrer unknown.";
843                        }
844                        # Close off the sentence with the original link.
845                        $environment .= " URL of event is <a href=\"$url\">$url</a>.";
846                    } else {
847                        # No CGI object, so we're a command-line tool. Use the tracing
848                        # key and the PID as the user identifier, and add the command.
849                        my $key = EmergencyKey();
850                        $environment .= "Event Reported by $key process $$.";
851                        if ($CommandLine) {
852                            # We're in a StandardSetup script, so we have the real command line.
853                            $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
854                        } elsif ($ENV{_}) {
855                            # We're in a BASH script, so the command has been stored in the _ variable.
856                            $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
857                        }
858                    }
859                    # Build a GUID. We use the current time, the title, and the process ID,
860                    # then digest the result.
861                    my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
862                    # Finally, the description. This is a stack trace plus various environmental stuff.
863                    # The trace is optional.
864                    my $stackTrace;
865                    if ($options{noStack}) {
866                        $stackTrace = "";
867                    } else {
868                        my @trace = LongMess();
869                        # Only proceed if we got something back.
870                        if (scalar(@trace) > 0) {
871                            $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
872                            $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
873                        }
874                    }
875                    # We got the stack trace. Now it's time to put it all together.
876                    # We have a goofy thing here in that we need to HTML-escape some sections of the description
877                    # twice. They will be escaped once here, and then once when written by XML::Simple. They are
878                    # unescaped once when processed by the RSS reader, and stuff in the description is treated as
879                    # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
880                    # our <br>s and <pre>s are used to format the description.
881                    $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
882                    my $description = "$recap$environment  $stackTrace";
883                    # Okay, we have all the pieces. Create a hash of the new event.
884                    my $newItem = { title => $title,
885                                    description => $description,
886                                    category => $LastCategory,
887                                    pubDate => $date,
888                                    guid => $guid,
889                                  };
890                    # We need XML capability for this.
891                    require XML::Simple;
892                    # The RSS document goes in here.
893                    my $rss;
894                    # Get the name of the RSS file. It's in the FIG temporary directory.
895                    my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
896                    # Open the config file and lock it.
897                    $lock = Open(undef, "<$FIG_Config::fig_disk/config/FIG_Config.pm");
898                    flock $lock, LOCK_EX;
899                    # Does it exist?
900                    if (-s $fileName) {
901                        # Slurp it in.
902                        $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
903                    } else {
904                        my $size = -s $fileName;
905                        # Create an empty channel.
906                        $rss = {
907                            channel => {
908                                title => 'NMPDR Warning Feed',
909                                link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
910                                description => "Important messages regarding the status of the NMPDR.",
911                                generator => "NMPDR Trace Facility",
912                                docs => "http://blogs.law.harvard.edu/tech/rss",
913                                item => []
914                            },
915                        };
916                    }
917                    # Get the channel object.
918                    my $channel = $rss->{channel};
919                    # Update the last-build date.
920                    $channel->{lastBuildDate} = $date;
921                    # Get the item array.
922                    my $items = $channel->{item};
923                    # Insure it has only 100 entries.
924                    while (scalar @{$items} > 100) {
925                        pop @{$items};
926                    }
927                    # Add our new item at the front.
928                    unshift @{$items}, $newItem;
929                    # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
930                    # the requirements for those.
931                    my $xml = XML::Simple::XMLout($channel, NoAttr => 1, RootName => 'channel', XmlDecl => '');
932                    # Here we put in the root and declaration. The problem is that the root has to have the version attribute
933                    # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
934                    $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
935                    # We don't use Open here because we can't afford an error.
936                    if (open XMLOUT, ">$fileName") {
937                        print XMLOUT $xml;
938                        close XMLOUT;
939                    }
940                }
941            }
942        };
943        if ($@) {
944            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
945            # (which is a good thing).
946            my $error = $@;
947            Trace("Feed Error: $error") if T(Feed => 0);
948        }
949        # Be sure to unlock.
950        if ($lock) {
951            flock $lock, LOCK_UN;
952            undef $lock;
953        }
954        # Restore the error message.
955        $@ = $savedError;
956    }
957    
958    
959    
960    
961  =head3 Assert  =head3 Assert
962    
963      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 725  Line 1008 
1008      my ($message) = @_;      my ($message) = @_;
1009      # Trace what's happening.      # Trace what's happening.
1010      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
1011      my $confession = longmess($message);      # Get the stack trace.
1012      # Convert the confession to a series of trace messages. Note we skip any      my @trace = LongMess();
1013      # messages relating to calls into Tracer.      # Convert the trace to a series of messages.
1014      for my $line (split /\s*\n/, $confession) {      for my $line (@trace) {
1015          Trace($line) if ($line !~ /Tracer\.pm/);          # Replace the tab at the beginning with spaces.
1016            $line =~ s/^\t/    /;
1017            # Trace the line.
1018            Trace($line);
1019      }      }
1020        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
1021        Warn($message);
1022  }  }
1023    
1024  =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  
1025    
1026  Returns a two-element list consisting of a CGI query object and a variable hash for      my @lines = Tracer::LongMess();
 the output page.  
1027    
1028  =back  Return a stack trace with all tracing methods removed. The return will be in the form of a list
1029    of message strings.
1030    
1031  =cut  =cut
1032    
1033  sub ScriptSetup {  sub LongMess {
1034      # Get the parameters.      # Declare the return variable.
1035      my ($noTrace) = @_;      my @retVal = ();
1036      # Get the CGI query object.      my $confession = longmess("");
1037      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
1038      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
1039      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
1040      # Create the variable hash.              push @retVal, $line;
1041      my $varHash = { results => '' };          }
1042      # Return the query object and variable hash.      }
1043      return ($cgi, $varHash);      # Return the result.
1044        return @retVal;
1045  }  }
1046    
1047  =head3 ETracing  =head3 ETracing
# Line 806  Line 1075 
1075      # Get the parameter.      # Get the parameter.
1076      my ($parameter) = @_;      my ($parameter) = @_;
1077      # Check for CGI mode.      # Check for CGI mode.
1078      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
1079            $SavedCGI = $parameter;
1080        } else {
1081            $SavedCGI = undef;
1082        }
1083      # Default to no tracing except errors.      # Default to no tracing except errors.
1084      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
1085      # Check for emergency tracing.      # Check for emergency tracing.
# Line 839  Line 1112 
1112              # Set the trace parameter.              # Set the trace parameter.
1113              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1114          }          }
1115      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1116          # 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
1117          # for tracing from the form parameters.          # for tracing from the form parameters.
1118          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1119              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1120              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1121              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1122          }          }
1123      }      }
1124      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1125      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1126      # Check to see if we're a web script.      # Check to see if we're a web script.
1127      if (defined $cgi) {      if (defined $SavedCGI) {
1128          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1129          TraceParms($cgi);          TraceParms($SavedCGI);
1130          # 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
1131          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1132          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 958  Line 1231 
1231          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
1232      } elsif ($myDest eq 'DUAL') {      } elsif ($myDest eq 'DUAL') {
1233          $retVal = "+>" . EmergencyFileTarget($tkey);          $retVal = "+>" . EmergencyFileTarget($tkey);
1234        } elsif ($myDest eq 'WARN') {
1235            $retVal = "WARN";
1236      }      }
1237      # Return the result.      # Return the result.
1238      return $retVal;      return $retVal;
# Line 1042  Line 1317 
1317      # Declare the return variable.      # Declare the return variable.
1318      my $retVal;      my $retVal;
1319      # Determine the parameter type.      # Determine the parameter type.
1320      if (! defined $parameter) {      if (! defined $parameter || defined($ENV{TRACING})) {
1321          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1322          $retVal = $ENV{TRACING};          # get the effective login ID.
1323            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1324      } else {      } else {
1325          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1326          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1085  Line 1361 
1361      # Get the parameters.      # Get the parameters.
1362      my ($cgi) = @_;      my ($cgi) = @_;
1363      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1364          # 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
1365          Trace("URL: " . $cgi->url(-relative => 1, -query => 1));          # relatively small.
1366            my $url = $cgi->url(-relative => 1, -query => 1);
1367            my $len = length($url);
1368            if ($len < 500) {
1369                Trace("[URL] $url");
1370            } elsif ($len > 2048) {
1371                Trace("[URL] URL is too long to use with GET ($len characters).");
1372            } else {
1373                Trace("[URL] URL length is $len characters.");
1374            }
1375      }      }
1376      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1377          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1095  Line 1380 
1380              # Note we skip the Trace parameters, which are for our use only.              # Note we skip the Trace parameters, which are for our use only.
1381              if ($parmName ne 'Trace' && $parmName ne 'TF') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
1382                  my @values = $cgi->param($parmName);                  my @values = $cgi->param($parmName);
1383                  Trace("CGI: $parmName = " . join(", ", @values));                  Trace("[CGI] $parmName = " . join(", ", @values));
1384              }              }
1385          }          }
1386          # Display the request method.          # Display the request method.
# Line 1105  Line 1390 
1390      if (T(CGI => 4)) {      if (T(CGI => 4)) {
1391          # Here we want the environment data too.          # Here we want the environment data too.
1392          for my $envName (sort keys %ENV) {          for my $envName (sort keys %ENV) {
1393              Trace("ENV: $envName = $ENV{$envName}");              Trace("[ENV] $envName = $ENV{$envName}");
1394          }          }
1395      }      }
1396  }  }
# Line 1161  Line 1446 
1446      }      }
1447  }  }
1448    
1449    =head2 Command-Line Utility Methods
1450    
1451  =head3 ScriptFinish  =head3 SendSMS
   
     ScriptFinish($webData, $varHash);  
1452    
1453  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.  
1454    
1455  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
1456    user name, password, and API ID for the relevant account in the hash reference variable
1457    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
1458    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
1459    is C<2561022>, then the FIG_Config file must contain
1460    
1461      BEGIN {      $phone =  { user => 'BruceTheHumanPet',
1462          # Print the HTML header.                  password => 'silly',
1463          print "CONTENT-TYPE: text/html\n\n";                  api_id => '2561022' };
     }  
     use Tracer;  
     use CGI;  
     use FIG;  
     # ... more uses ...  
1464    
1465      my ($cgi, $varHash) = ScriptSetup();  The original purpose of this method was to insure Bruce would be notified immediately when the
1466      eval {  Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
1467          # ... 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);  
1468    
1469  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.  
1470    
1471  =over 4  =over 4
1472    
1473  =item webData  =item phoneNumber
1474    
1475  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
1476  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.  
1477    
1478  =item varHash (optional)  =item msg
1479    
1480  If specified, then a reference to a hash mapping variable names for a template  Message to send to the specified phone.
1481  to their values. The template file will be read into memory, and variable markers  
1482  will be replaced by data in this hash reference.  =item RETURN
1483    
1484    Returns the message ID if successful, and C<undef> if the message could not be sent.
1485    
1486  =back  =back
1487    
1488  =cut  =cut
1489    
1490  sub ScriptFinish {  sub SendSMS {
     # 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.  
   
 =item RETURN  
   
 Returns the message ID if successful, and C<undef> if the message could not be sent.  
   
 =back  
   
 =cut  
   
 sub SendSMS {  
1491      # Get the parameters.      # Get the parameters.
1492      my ($phoneNumber, $msg) = @_;      my ($phoneNumber, $msg) = @_;
1493      # Declare the return variable. If we do not change it, C<undef> will be returned.      # Declare the return variable. If we do not change it, C<undef> will be returned.
# Line 1468  Line 1650 
1650  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
1651  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,
1652  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
1653  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
1654    login ID.
1655    
1656    Since the default situation in StandardSetup is to trace to the standard
1657    output, errors that occur in command-line scripts will not generate
1658    RSS events. To force the events, use the C<warn> option.
1659    
1660        TransactFeatures -background -warn register ../xacts IDs.tbl
1661    
1662  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1663  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 1674 
1674          -noAlias  do not expect aliases in CHANGE transactions          -noAlias  do not expect aliases in CHANGE transactions
1675          -start    start with this genome          -start    start with this genome
1676          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
1677            -forked   do not erase the trace file before tracing
1678    
1679  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
1680  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 1738 
1738      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1739      # Get the default tracing key.      # Get the default tracing key.
1740      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1741        # Save the command line.
1742        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1743      # Add the tracing options.      # Add the tracing options.
1744      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1745          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
1746      }      }
1747        if (! exists $options->{forked}) {
1748            $options->{forked} = [0, "keep old trace file"];
1749        }
1750      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
1751      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1752      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1753      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1754        $options->{warn} = [0, "send errors to RSS feed"];
1755        $options->{moreTracing} = ["", "comma-delimited list of additional trace modules for debugging"];
1756      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1757      # contains the default values rather than the default value      # contains the default values rather than the default value
1758      # 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 1769 
1769      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
1770      # Get the logfile suffix.      # Get the logfile suffix.
1771      my $suffix = $retOptions->{user};      my $suffix = $retOptions->{user};
1772      # Check for background mode.      # We'll put the trace file name in here. We need it later if background
1773      if ($retOptions->{background}) {      # mode is on.
1774          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};  
         }  
     }  
1775      # 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
1776      # wants emergency tracing.      # wants emergency tracing.
1777      if ($retOptions->{trace} eq 'E') {      if ($retOptions->{trace} eq 'E') {
# Line 1594  Line 1782 
1782          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1783              push @cats, "SQL";              push @cats, "SQL";
1784          }          }
1785            if ($retOptions->{warn}) {
1786                push @cats, "Feed";
1787            }
1788          # Add the default categories.          # Add the default categories.
1789          push @cats, "Tracer";          push @cats, "Tracer";
1790            # Check for more tracing groups.
1791            if ($retOptions->{moreTracing}) {
1792                push @cats, split /,/, $retOptions->{moreTracing};
1793            }
1794          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
1795          my $cats = join(" ", @cats);          my $cats = join(" ", @cats);
1796          # 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 1805 
1805          my $traceMode;          my $traceMode;
1806          # Verify that we can open a file in the FIG temporary directory.          # Verify that we can open a file in the FIG temporary directory.
1807          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
1808          if (open TESTTRACE, ">$traceFileName") {          my $traceFileSpec = ($retOptions->{forked} ? ">>$traceFileName" : ">$traceFileName");
1809            if (open TESTTRACE, "$traceFileSpec") {
1810              # Here we can trace to a file.              # Here we can trace to a file.
1811              $traceMode = ">$traceFileName";              $traceMode = ">>$traceFileName";
1812              if ($textOKFlag) {              if ($textOKFlag) {
1813                  # Echo to standard output if the text-OK flag is set.                  # Echo to standard output if the text-OK flag is set.
1814                  $traceMode = "+$traceMode";                  $traceMode = "+$traceMode";
# Line 1620  Line 1816 
1816              # Close the test file.              # Close the test file.
1817              close TESTTRACE;              close TESTTRACE;
1818          } else {          } else {
1819              # 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.
1820                warn "Could not open trace file $traceFileName: $!\n";
1821                # We trace to the standard output if it's
1822              # okay, and the error log otherwise.              # okay, and the error log otherwise.
1823              if ($textOKFlag) {              if ($textOKFlag) {
1824                  $traceMode = "TEXT";                  $traceMode = "TEXT";
# Line 1631  Line 1829 
1829          # Now set up the tracing.          # Now set up the tracing.
1830          TSetup("$traceLevel $cats", $traceMode);          TSetup("$traceLevel $cats", $traceMode);
1831      }      }
1832        # Check for background mode.
1833        if ($retOptions->{background}) {
1834            my $outFileName = "$FIG_Config::temp/out$suffix$$.log";
1835            my $errFileName = "$FIG_Config::temp/err$suffix$$.log";
1836            # Spool the output.
1837            open STDOUT, ">$outFileName";
1838            # If we have a trace file, trace the errors to the log. Otherwise,
1839            # spool the errors.
1840            if (defined $traceFileName) {
1841                open STDERR, "| Tracer $traceFileName";
1842            } else {
1843                open STDERR, ">$errFileName";
1844            }
1845            # Check for phone support. If we have phone support and a phone number,
1846            # we want to turn it on.
1847            if ($ENV{PHONE} && defined($FIG_Config::phone)) {
1848                $retOptions->{phone} = $ENV{PHONE};
1849            }
1850        }
1851      # 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
1852      # options and exit the program.      # options and exit the program.
1853      if ($retOptions->{help}) {      if ($retOptions->{help}) {
# Line 1811  Line 2028 
2028      }      }
2029  }  }
2030    
2031    =head3 UnparseOptions
2032    
2033        my $optionString = Tracer::UnparseOptions(\%options);
2034    
2035    Convert an option hash into a command-line string. This will not
2036    necessarily be the same text that came in, but it will nonetheless
2037    produce the same ultimate result when parsed by L</StandardSetup>.
2038    
2039    =over 4
2040    
2041    =item options
2042    
2043    Reference to a hash of options to convert into an option string.
2044    
2045    =item RETURN
2046    
2047    Returns a string that will parse to the same set of options when
2048    parsed by L</StandardSetup>.
2049    
2050    =back
2051    
2052    =cut
2053    
2054    sub UnparseOptions {
2055        # Get the parameters.
2056        my ($options) = @_;
2057        # The option segments will be put in here.
2058        my @retVal = ();
2059        # Loop through the options.
2060        for my $key (keys %$options) {
2061            # Get the option value.
2062            my $value = $options->{$key};
2063            # Only use it if it's nonempty.
2064            if (defined $value && $value ne "") {
2065                my $segment = "--$key=$value";
2066                # Quote it if necessary.
2067                if ($segment =~ /[ |<>*]/) {
2068                    $segment = '"' . $segment . '"';
2069                }
2070                # Add it to the return list.
2071                push @retVal, $segment;
2072            }
2073        }
2074        # Return the result.
2075        return join(" ", @retVal);
2076    }
2077    
2078  =head3 ParseCommand  =head3 ParseCommand
2079    
2080      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);
# Line 2283  Line 2547 
2547          } else {          } else {
2548              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
2549          }          }
2550            closedir $dirHandle;
2551      } elsif (! $flag) {      } elsif (! $flag) {
2552          # Here the directory would not open and it's considered an error.          # Here the directory would not open and it's considered an error.
2553          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
# Line 2389  Line 2654 
2654  Map of search patterns to permission masks. If a directory name matches  Map of search patterns to permission masks. If a directory name matches
2655  one of the patterns, that directory and all its members and subdirectories  one of the patterns, that directory and all its members and subdirectories
2656  will be assigned the new pattern. For example, the following would  will be assigned the new pattern. For example, the following would
2657  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>.
2658    
2659      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2660    
# Line 2442  Line 2707 
2707                      $match = 1;                      $match = 1;
2708                  }                  }
2709              }              }
2710              # 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
2711              # before terminating due to the match.              # before terminating due to the match.
2712              if ($match && $otherMasks[$i-1] != $mask) {              if ($match && $otherMasks[$i-1] != $mask) {
2713                  # 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 2849 
2849  }  }
2850    
2851    
2852    =head3 PrintLine
2853    
2854        Tracer::PrintLine($line);
2855    
2856    Print a line of text with a trailing new-line.
2857    
2858    =over 4
2859    
2860    =item line
2861    
2862    Line of text to print.
2863    
2864    =back
2865    
2866    =cut
2867    
2868    sub PrintLine {
2869        # Get the parameters.
2870        my ($line) = @_;
2871        # Print the line.
2872        print "$line\n";
2873    }
2874    
2875    
2876  =head2 Other Useful Methods  =head2 Other Useful Methods
2877    
2878    =head3 IDHASH
2879    
2880        my $hash = SHTargetSearch::IDHASH(@keys);
2881    
2882    This is a dinky little method that converts a list of values to a reference
2883    to hash of values to labels. The values and labels are the same.
2884    
2885    =cut
2886    
2887    sub IDHASH {
2888        my %retVal = map { $_ => $_ } @_;
2889        return \%retVal;
2890    }
2891    
2892    =head3 Pluralize
2893    
2894        my $plural = Tracer::Pluralize($word);
2895    
2896    This is a very simple pluralization utility. It adds an C<s> at the end
2897    of the input word unless it already ends in an C<s>, in which case it
2898    adds C<es>.
2899    
2900    =over 4
2901    
2902    =item word
2903    
2904    Singular word to pluralize.
2905    
2906    =item RETURN
2907    
2908    Returns the probable plural form of the word.
2909    
2910    =back
2911    
2912    =cut
2913    
2914    sub Pluralize {
2915        # Get the parameters.
2916        my ($word) = @_;
2917        # Declare the return variable.
2918        my $retVal;
2919        if ($word =~ /s$/) {
2920            $retVal = $word . 'es';
2921        } else {
2922            $retVal = $word . 's';
2923        }
2924        # Return the result.
2925        return $retVal;
2926    }
2927    
2928    =head3 Numeric
2929    
2930        my $okFlag = Tracer::Numeric($string);
2931    
2932    Return the value of the specified string if it is numeric, or an undefined value
2933    if it is not numeric.
2934    
2935    =over 4
2936    
2937    =item string
2938    
2939    String to check.
2940    
2941    =item RETURN
2942    
2943    Returns the numeric value of the string if successful, or C<undef> if the string
2944    is not numeric.
2945    
2946    =back
2947    
2948    =cut
2949    
2950    sub Numeric {
2951        # Get the parameters.
2952        my ($string) = @_;
2953        # We'll put the value in here if we succeed.
2954        my $retVal;
2955        # Get a working copy of the string.
2956        my $copy = $string;
2957        # Trim leading and trailing spaces.
2958        $copy =~ s/^\s+//;
2959        $copy =~ s/\s+$//;
2960        # Check the result.
2961        if ($copy =~ /^[+-]?\d+$/) {
2962            $retVal = $copy;
2963        } elsif ($copy =~ /^([+-]\d+|\d*)[eE][+-]?\d+$/) {
2964            $retVal = $copy;
2965        } elsif ($copy =~ /^([+-]\d+|\d*)\.\d*([eE][+-]?\d+)?$/) {
2966            $retVal = $copy;
2967        }
2968        # Return the result.
2969        return $retVal;
2970    }
2971    
2972    
2973  =head3 ParseParm  =head3 ParseParm
2974    
2975      my $listValue = Tracer::ParseParm($string);      my $listValue = Tracer::ParseParm($string);
# Line 2624  Line 3007 
3007      return $retVal;      return $retVal;
3008  }  }
3009    
   
   
   
3010  =head3 Now  =head3 Now
3011    
3012      my $string = Tracer::Now();      my $string = Tracer::Now();
3013    
3014  Return a displayable time stamp containing the local time.  Return a displayable time stamp containing the local time. Whatever format this
3015    method produces must be parseable by L</ParseDate>.
3016    
3017  =cut  =cut
3018    
3019  sub Now {  sub Now {
3020      my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);      return DisplayTime(time);
3021      my $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .  }
3022    
3023    =head3 DisplayTime
3024    
3025        my $string = Tracer::DisplayTime($time);
3026    
3027    Convert a time value to a displayable time stamp. Whatever format this
3028    method produces must be parseable by L</ParseDate>.
3029    
3030    =over 4
3031    
3032    =item time
3033    
3034    Time to display, in seconds since the epoch, or C<undef> if the time is unknown.
3035    
3036    =item RETURN
3037    
3038    Returns a displayable time, or C<(n/a)> if the incoming time is undefined.
3039    
3040    =back
3041    
3042    =cut
3043    
3044    sub DisplayTime {
3045        my ($time) = @_;
3046        my $retVal = "(n/a)";
3047        if (defined $time) {
3048            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
3049            $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .
3050                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);
3051        }
3052      return $retVal;      return $retVal;
3053  }  }
3054    
# Line 2802  Line 3212 
3212      return $retVal;      return $retVal;
3213  }  }
3214    
3215    =head3 In
3216    
3217        my $flag = Tracer::In($value, $min, $max);
3218    
3219    Return TRUE if the value is between the minimum and the maximum, else FALSE.
3220    
3221    =cut
3222    
3223    sub In {
3224        return ($_[0] <= $_[2] && $_[0] >= $_[1]);
3225    }
3226    
3227    
3228    =head3 Constrain
3229    
3230        my $constrained = Constrain($value, $min, $max);
3231    
3232    Modify a numeric value to bring it to a point in between a maximum and a minimum.
3233    
3234    =over 4
3235    
3236    =item value
3237    
3238    Value to constrain.
3239    
3240    =item min (optional)
3241    
3242    Minimum permissible value. If this parameter is undefined, no minimum constraint will be applied.
3243    
3244    =item max (optional)
3245    
3246    Maximum permissible value. If this parameter is undefined, no maximum constraint will be applied.
3247    
3248    =item RETURN
3249    
3250    Returns the incoming value, constrained according to the other parameters.
3251    
3252    =back
3253    
3254    =cut
3255    
3256    sub Constrain {
3257        # Get the parameters.
3258        my ($value, $min, $max) = @_;
3259        # Declare the return variable.
3260        my $retVal = $value;
3261        # Apply the minimum constraint.
3262        if (defined $min && $retVal < $min) {
3263            $retVal = $min;
3264        }
3265        # Apply the maximum constraint.
3266        if (defined $max && $retVal > $max) {
3267            $retVal = $max;
3268        }
3269        # Return the result.
3270        return $retVal;
3271    }
3272    
3273  =head3 Min  =head3 Min
3274    
3275      my $min = Min($value1, $value2, ... $valueN);      my $min = Min($value1, $value2, ... $valueN);
# Line 2868  Line 3336 
3336      return $retVal;      return $retVal;
3337  }  }
3338    
3339  =head3 DebugMode  =head3 Strip
   
     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;  
 }  
   
 =head3 Strip  
3340    
3341      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
3342    
# Line 2930  Line 3368 
3368      return $retVal;      return $retVal;
3369  }  }
3370    
3371    =head3 Trim
3372    
3373        my $string = Tracer::Trim($line);
3374    
3375    Trim all spaces from the beginning and ending of a string.
3376    
3377    =over 4
3378    
3379    =item line
3380    
3381    Line of text to be trimmed.
3382    
3383    =item RETURN
3384    
3385    The same line of text with all whitespace chopped off either end.
3386    
3387    =back
3388    
3389    =cut
3390    
3391    sub Trim {
3392        # Get a copy of the parameter string.
3393        my ($string) = @_;
3394        my $retVal = (defined $string ? $string : "");
3395        # Strip the front spaces.
3396        $retVal =~ s/^\s+//;
3397        # Strip the back spaces.
3398        $retVal =~ s/\s+$//;
3399        # Return the result.
3400        return $retVal;
3401    }
3402    
3403  =head3 Pad  =head3 Pad
3404    
3405      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);
# Line 2991  Line 3461 
3461      return $retVal;      return $retVal;
3462  }  }
3463    
3464    =head3 Quoted
3465    
3466        my $string = Tracer::Quoted($var);
3467    
3468    Convert the specified value to a string and enclose it in single quotes.
3469    If it's undefined, the string C<undef> in angle brackets will be used
3470    instead.
3471    
3472    =over 4
3473    
3474    =item var
3475    
3476    Value to quote.
3477    
3478    =item RETURN
3479    
3480    Returns a string enclosed in quotes, or an indication the value is undefined.
3481    
3482    =back
3483    
3484    =cut
3485    
3486    sub Quoted {
3487        # Get the parameters.
3488        my ($var) = @_;
3489        # Declare the return variable.
3490        my $retVal;
3491        # Are we undefined?
3492        if (! defined $var) {
3493            $retVal = "<undef>";
3494        } else {
3495            # No, so convert to a string and enclose in quotes.
3496            $retVal = $var;
3497            $retVal =~ s/'/\\'/;
3498            $retVal = "'$retVal'";
3499        }
3500        # Return the result.
3501        return $retVal;
3502    }
3503    
3504  =head3 EOF  =head3 EOF
3505    
3506  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 3590 
3590  }  }
3591    
3592    
3593    =head3 GetMemorySize
3594    
3595        my $string = Tracer::GetMemorySize();
3596    
3597    Return a memory size string for the current process. The string will be
3598    in comma format, with a size indicator (K, M, G) at the end.
3599    
3600    =cut
3601    
3602    sub GetMemorySize {
3603        # Get the memory size from Unix.
3604        my ($retVal) = `ps h -o vsz $$`;
3605        # Remove the ending new-line.
3606        chomp $retVal;
3607        # Format and return the result.
3608        return CommaFormat($retVal) . "K";
3609    }
3610    
3611  =head3 CompareLists  =head3 CompareLists
3612    
3613      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);
# Line 3147  Line 3675 
3675      return ($inserted, $deleted);      return ($inserted, $deleted);
3676  }  }
3677    
3678    =head3 Cmp
3679    
3680        my $cmp = Tracer::Cmp($a, $b);
3681    
3682    This method performs a universal sort comparison. Each value coming in is
3683    separated into a leading text part and a trailing number part. The text
3684    part is string compared, and if both parts are equal, then the number
3685    parts are compared numerically. A stream of just numbers or a stream of
3686    just strings will sort correctly, and a mixed stream will sort with the
3687    numbers first. Strings with a label and a number will sort in the
3688    expected manner instead of lexically.
3689    
3690    =over 4
3691    
3692    =item a
3693    
3694    First item to compare.
3695    
3696    =item b
3697    
3698    Second item to compare.
3699    
3700    =item RETURN
3701    
3702    Returns a negative number if the first item should sort first (is less), a positive
3703    number if the first item should sort second (is greater), and a zero if the items are
3704    equal.
3705    
3706    =back
3707    
3708    =cut
3709    
3710    sub Cmp {
3711        # Get the parameters.
3712        my ($a, $b) = @_;
3713        # Declare the return value.
3714        my $retVal;
3715        # Check for nulls.
3716        if (! defined($a)) {
3717            $retVal = (! defined($b) ? 0 : -1);
3718        } elsif (! defined($b)) {
3719            $retVal = 1;
3720        } else {
3721            # Here we have two real values. Parse the two strings.
3722            my $aParsed = _Parse($a);
3723            my $bParsed = _Parse($b);
3724            # Compare the string parts insensitively.
3725            $retVal = (lc $aParsed->[0] cmp lc $bParsed->[0]);
3726            # If they're equal, compare them sensitively.
3727            if (! $retVal) {
3728                $retVal = ($aParsed->[0] cmp $bParsed->[0]);
3729            }
3730            # If they're STILL equal, compare the number parts.
3731            if (! $retVal) {
3732                $retVal = $aParsed->[1] <=> $bParsed->[1];
3733            }
3734        }
3735        # Return the result.
3736        return $retVal;
3737    }
3738    
3739    # This method parses an input string into a string part and a number part.
3740    sub _Parse {
3741        my ($string) = @_;
3742        my ($alpha, $num);
3743        if ($string =~ /^(.*?)(\d+(?:\.\d+)?)$/) {
3744            $alpha = $1;
3745            $num = $2;
3746        } else {
3747            $alpha = $string;
3748            $num = 0;
3749        }
3750        return [$alpha, $num];
3751    }
3752    
3753    =head3 ListEQ
3754    
3755        my $flag = Tracer::ListEQ(\@a, \@b);
3756    
3757    Return TRUE if the specified lists contain the same strings in the same
3758    order, else FALSE.
3759    
3760    =over 4
3761    
3762    =item a
3763    
3764    Reference to the first list.
3765    
3766    =item b
3767    
3768    Reference to the second list.
3769    
3770    =item RETURN
3771    
3772    Returns TRUE if the two parameters are identical string lists, else FALSE.
3773    
3774    =back
3775    
3776    =cut
3777    
3778    sub ListEQ {
3779        # Get the parameters.
3780        my ($a, $b) = @_;
3781        # Declare the return variable. Start by checking the lengths.
3782        my $n = scalar(@$a);
3783        my $retVal = ($n == scalar(@$b));
3784        # Now compare the list elements.
3785        for (my $i = 0; $retVal && $i < $n; $i++) {
3786            $retVal = ($a->[$i] eq $b->[$i]);
3787        }
3788        # Return the result.
3789        return $retVal;
3790    }
3791    
3792    =head2 CGI Script Utilities
3793    
3794    =head3 ScriptSetup (deprecated)
3795    
3796        my ($cgi, $varHash) = ScriptSetup($noTrace);
3797    
3798    Perform standard tracing and debugging setup for scripts. The value returned is
3799    the CGI object followed by a pre-built variable hash. At the end of the script,
3800    the client should call L</ScriptFinish> to output the web page.
3801    
3802    This method calls L</ETracing> to configure tracing, which allows the tracing
3803    to be configured via the emergency tracing form on the debugging control panel.
3804    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3805    method, which includes every program that uses this method or L</StandardSetup>.
3806    
3807    =over 4
3808    
3809    =item noTrace (optional)
3810    
3811    If specified, tracing will be suppressed. This is useful if the script wants to set up
3812    tracing manually.
3813    
3814    =item RETURN
3815    
3816    Returns a two-element list consisting of a CGI query object and a variable hash for
3817    the output page.
3818    
3819    =back
3820    
3821    =cut
3822    
3823    sub ScriptSetup {
3824        # Get the parameters.
3825        my ($noTrace) = @_;
3826        # Get the CGI query object.
3827        my $cgi = CGI->new();
3828        # Set up tracing if it's not suppressed.
3829        ETracing($cgi) unless $noTrace;
3830        # Create the variable hash.
3831        my $varHash = { results => '' };
3832        # Return the query object and variable hash.
3833        return ($cgi, $varHash);
3834    }
3835    
3836    =head3 ScriptFinish (deprecated)
3837    
3838        ScriptFinish($webData, $varHash);
3839    
3840    Output a web page at the end of a script. Either the string to be output or the
3841    name of a template file can be specified. If the second parameter is omitted,
3842    it is assumed we have a string to be output; otherwise, it is assumed we have the
3843    name of a template file. The template should have the variable C<DebugData>
3844    specified in any form that invokes a standard script. If debugging mode is turned
3845    on, a form field will be put in that allows the user to enter tracing data.
3846    Trace messages will be placed immediately before the terminal C<BODY> tag in
3847    the output, formatted as a list.
3848    
3849    A typical standard script would loook like the following.
3850    
3851        BEGIN {
3852            # Print the HTML header.
3853            print "CONTENT-TYPE: text/html\n\n";
3854        }
3855        use Tracer;
3856        use CGI;
3857        use FIG;
3858        # ... more uses ...
3859    
3860        my ($cgi, $varHash) = ScriptSetup();
3861        eval {
3862            # ... get data from $cgi, put it in $varHash ...
3863        };
3864        if ($@) {
3865            Trace("Script Error: $@") if T(0);
3866        }
3867        ScriptFinish("Html/MyTemplate.html", $varHash);
3868    
3869    The idea here is that even if the script fails, you'll see trace messages and
3870    useful output.
3871    
3872    =over 4
3873    
3874    =item webData
3875    
3876    A string containing either the full web page to be written to the output or the
3877    name of a template file from which the page is to be constructed. If the name
3878    of a template file is specified, then the second parameter must be present;
3879    otherwise, it must be absent.
3880    
3881    =item varHash (optional)
3882    
3883    If specified, then a reference to a hash mapping variable names for a template
3884    to their values. The template file will be read into memory, and variable markers
3885    will be replaced by data in this hash reference.
3886    
3887    =back
3888    
3889    =cut
3890    
3891    sub ScriptFinish {
3892        # Get the parameters.
3893        my ($webData, $varHash) = @_;
3894        # Check for a template file situation.
3895        my $outputString;
3896        if (defined $varHash) {
3897            # Here we have a template file. We need to determine the template type.
3898            my $template;
3899            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3900                $template = "$FIG_Config::template_url/$webData";
3901            } else {
3902                $template = "<<$webData";
3903            }
3904            $outputString = PageBuilder::Build($template, $varHash, "Html");
3905        } else {
3906            # Here the user gave us a raw string.
3907            $outputString = $webData;
3908        }
3909        # Check for trace messages.
3910        if ($Destination ne "NONE" && $TraceLevel > 0) {
3911            # We have trace messages, so we want to put them at the end of the body. This
3912            # is either at the end of the whole string or at the beginning of the BODY
3913            # end-tag.
3914            my $pos = length $outputString;
3915            if ($outputString =~ m#</body>#gi) {
3916                $pos = (pos $outputString) - 7;
3917            }
3918            # If the trace messages were queued, we unroll them. Otherwise, we display the
3919            # destination.
3920            my $traceHtml;
3921            if ($Destination eq "QUEUE") {
3922                $traceHtml = QTrace('Html');
3923            } elsif ($Destination =~ /^>>(.+)$/) {
3924                # Here the tracing output it to a file. We code it as a hyperlink so the user
3925                # can copy the file name into the clipboard easily.
3926                my $actualDest = $1;
3927                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3928            } else {
3929                # Here we have one of the special destinations.
3930                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3931            }
3932            substr $outputString, $pos, 0, $traceHtml;
3933        }
3934        # Write the output string.
3935        print $outputString;
3936    }
3937    
3938  =head3 GenerateURL  =head3 GenerateURL
3939    
3940      my $queryUrl = Tracer::GenerateURL($page, %parameters);      my $queryUrl = Tracer::GenerateURL($page, %parameters);
# Line 3281  Line 4069 
4069      return $retVal;      return $retVal;
4070  }  }
4071    
4072  =head3 Cmp  =head3 TrackingCode
4073    
4074      my $cmp = Tracer::Cmp($a, $b);      my $html = Tracer::TrackingCode();
4075    
4076  This method performs a universal sort comparison. Each value coming in is  Returns the HTML code for doing web page traffic monitoring. If the
4077  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;
4078  part is string compared, and if both parts are equal, then the number  otherwise, it returns a bunch of javascript containing code for turning
4079  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.  
4080    
4081  =over 4  =cut
4082    
4083  =item a  sub TrackingCode {
4084        # Declare the return variable.
4085        my $retVal = "<!-- tracking off -->";
4086        # Determine if we're in production.
4087        if ($FIG_Config::site_meter) {
4088            $retVal = <<END_HTML
4089            <!-- Site Meter -->
4090            <script type="text/javascript" src="http://s20.sitemeter.com/js/counter.js?site=s20nmpdr">
4091            </script>
4092            <noscript>
4093            <a href="http://s20.sitemeter.com/stats.asp?site=s20nmpdr" target="_top">
4094            <img src="http://s20.sitemeter.com/meter.asp?site=s20nmpdr" alt="Site Meter" border="0"/></a>
4095            </noscript>
4096            <!-- Copyright (c)2006 Site Meter -->
4097    END_HTML
4098        }
4099        return $retVal;
4100    }
4101    
4102  First item to compare.  =head3 Clean
4103    
4104  =item b      my $cleaned = Tracer::Clean($string);
4105    
4106  Second item to compare.  Clean up a string for HTML display. This not only converts special
4107    characters to HTML entity names, it also removes control characters.
4108    
4109    =over 4
4110    
4111    =item string
4112    
4113    String to convert.
4114    
4115  =item RETURN  =item RETURN
4116    
4117  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
4118  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.  
4119    
4120  =back  =back
4121    
4122  =cut  =cut
4123    
4124  sub Cmp {  sub Clean {
4125      # Get the parameters.      # Get the parameters.
4126      my ($a, $b) = @_;      my ($string) = @_;
4127      # Declare the return value.      # Declare the return variable.
4128      my $retVal;      my $retVal = "";
4129      # Check for nulls.      # Only proceed if the value exists.
4130      if (! defined($a)) {      if (defined $string) {
4131          $retVal = (! defined($b) ? 0 : -1);          # Get the string.
4132      } elsif (! defined($b)) {          $retVal = $string;
4133          $retVal = 1;          # Clean the control characters.
4134      } else {          $retVal =~ tr/\x00-\x1F/?/;
4135          # Here we have two real values. Parse the two strings.          # Escape the rest.
4136          $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];  
         }  
4137      }      }
4138      # Return the result.      # Return the result.
4139      return $retVal;      return $retVal;
4140  }  }
4141    
4142    =head3 SortByValue
4143    
4144        my @keys = Tracer::SortByValue(\%hash);
4145    
4146    Get a list of hash table keys sorted by hash table values.
4147    
4148    =over 4
4149    
4150    =item hash
4151    
4152    Hash reference whose keys are to be extracted.
4153    
4154    =item RETURN
4155    
4156    Returns a list of the hash keys, ordered so that the corresponding hash values
4157    are in alphabetical sequence.
4158    
4159    =back
4160    
4161    =cut
4162    
4163    sub SortByValue {
4164        # Get the parameters.
4165        my ($hash) = @_;
4166        # Sort the hash's keys using the values.
4167        my @retVal = sort { Cmp($hash->{$a}, $hash->{$b}) } keys %$hash;
4168        # Return the result.
4169        return @retVal;
4170    }
4171    
4172    =head3 GetSet
4173    
4174        my $value = Tracer::GetSet($object, $name => $newValue);
4175    
4176    Get or set the value of an object field. The object is treated as an
4177    ordinary hash reference. If a new value is specified, it is stored in the
4178    hash under the specified name and then returned. If no new value is
4179    specified, the current value is returned.
4180    
4181    =over 4
4182    
4183    =item object
4184    
4185    Reference to the hash that is to be interrogated or updated.
4186    
4187    =item name
4188    
4189    Name of the field. This is the hash key.
4190    
4191    =item newValue (optional)
4192    
4193    New value to be stored in the field. If no new value is specified, the current
4194    value of the field is returned.
4195    
4196    =item RETURN
4197    
4198    Returns the value of the named field in the specified hash.
4199    
4200    =back
4201    
4202    =cut
4203    
4204    sub GetSet {
4205        # Get the parameters.
4206        my ($object, $name, $newValue) = @_;
4207        # Is a new value specified?
4208        if (defined $newValue) {
4209            # Yes, so store it.
4210            $object->{$name} = $newValue;
4211        }
4212        # Return the result.
4213        return $object->{$name};
4214    }
4215    
4216  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3