[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.111, Tue Sep 30 15:20:36 2008 UTC
# Line 20  Line 20 
20    
21      require Exporter;      require Exporter;
22      @ISA = ('Exporter');      @ISA = ('Exporter');
23      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing ScriptSetup ScriptFinish Insure ChDir Emergency);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency Warn);
24      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);
25      use strict;      use strict;
26      use Carp qw(longmess croak);      use Carp qw(longmess croak carp);
27      use CGI;      use CGI;
28      use Cwd;      use Cwd;
29      use FIG_Config;      use FIG_Config;
# Line 36  Line 36 
36      use Time::HiRes 'gettimeofday';      use Time::HiRes 'gettimeofday';
37      use URI::Escape;      use URI::Escape;
38      use Time::Local;      use Time::Local;
39        use POSIX qw(strftime);
40        use Time::Zone;
41        use Fcntl qw(:DEFAULT :flock);
42    
43    
44  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
45    
# Line 160  Line 164 
164    
165  Sometimes, you need a way for tracing to happen automatically without putting parameters  Sometimes, you need a way for tracing to happen automatically without putting parameters
166  in a form or on the command line. Emergency tracing does this. You invoke emergency tracing  in a form or on the command line. Emergency tracing does this. You invoke emergency tracing
167  from the debug form, which is accessed from I<MySeedInstance>C</FIG/Html/SetPassword.html>.  from the debug form, which is accessed from the [[DebugConsole]]. Emergency tracing requires
168  Emergency tracing requires you specify a tracing key. For command-line tools, the key is  that you specify a tracing key. For command-line tools, the key is
169  taken from the C<TRACING> environment variable. For web services, the key is taken from  taken from the C<TRACING> environment variable. For web services, the key is taken from
170  a cookie. Either way, the key tells the tracing facility who you are, so that you control  a cookie. Either way, the key tells the tracing facility who you are, so that you control
171  the tracing in your environment without stepping on other users.  the tracing in your environment without stepping on other users.
# Line 184  Line 188 
188    
189  The web script will look for the tracing key in the cookies, and the command-line  The web script will look for the tracing key in the cookies, and the command-line
190  script will look for it in the C<TRACING> environment variable. If you are  script will look for it in the C<TRACING> environment variable. If you are
191  using the L</StandardScript> or L</StandardSetup> methods, emergency tracing  using the L</StandardSetup> method or a [[WebApplication]], emergency tracing
192  will be configured automatically.  will be configured automatically.
193    
 NOTE: to configure emergency tracing from the command line instead of the Debugging  
 Control Panel (see below), use the C<trace.pl> script.  
   
 =head3 Debugging Control Panel  
   
 The debugging control panel provides several tools to assist in development of  
 SEED and Sprout software. You access the debugging control panel from the URL  
 C</FIG/Html/SetPassword.html> in whichever seed instance you're using. (So,  
 for example, the panel access point for the development NMPDR system is  
 C<http://web-1.nmpdr.org/next/FIG/Html/SetPassword.html>. Contact Bruce to  
 find out what the password is. From this page, you can also specify a tracing  
 key. If you don't specify a key, one will be generated for you.  
   
 =head4 Emergency Tracing Form  
   
 At the bottom of the debugging control panel is a form that allows you to  
 specify a trace level and tracing categories. Special and common categories  
 are listed with check boxes. You can hold your mouse over a check box to see  
 what its category does. In general, however, a category name is the same as  
 the name of the package in which the trace message occurs.  
   
 Additional categories can be entered in an input box, delimited by spaces or commas.  
   
 The B<Activate> button turns on Emergency tracing at the level you specify with the  
 specified categories active. The B<Terminate> button turns tracing off. The  
 B<Show File> button displays the current contents of the trace file. The tracing  
 form at the bottom of the control panel is designed for emergency tracing, so it  
 will only affect programs that call L</ETracing>, L</StandardScript>,  
 or L</StandardSetup>.  
   
 =head4 Script Form  
   
 The top form of the debugging control panel allows you to enter a tiny script and  
 have the output generated in a formatted table. Certain object variables are  
 predefined in the script, including a FIG object (C<$fig>), a CGI object (C<$cgi>),  
 and-- if Sprout is active-- Sprout (C<$sprout>) and SFXlate (C<$sfx>) objects.  
   
 The last line of the script must be a scalar, but it can be a reference to a hash,  
 a list, a list of lists, and various other combinations. If you select the appropriate  
 data type in the dropdown box, the output will be formatted accordingly. The form  
 also has controls for specifying tracing. These controls override any emergency  
 tracing in effect.  
   
 =head4 Database Query Forms  
   
 The forms between the script form and the emergency tracing form allow you to  
 make queries against the database. The FIG query form allows simple queries against  
 a single FIG table. The Sprout query form uses the B<GetAll> method to do a  
 multi-table query against the Sprout database. B<GetAll> is located in the B<ERDB>  
 package, and it takes five parameters.  
   
     GetAll(\@objectNames, $filterClause, \@parameters, \@fields, $count);  
   
 Each of the five parameters corresponds to a text box on the query form:  
   
 =over 4  
   
 =item Objects  
   
 Comma-separated list containing the names of the entity and relationship objects to be retrieved.  
   
 =item Filter  
   
 WHERE/ORDER BY clause (without the WHERE) to be used to filter and sort the query. The WHERE clause can  
 be parameterized with parameter markers (C<?>). Each field used must be specified in the standard form  
 B<I<objectName>(I<fieldName>)> or B<$I<number>(I<fieldName>)> where I<fieldName> is the name of a  
 field, I<objectName> is the name of the entity or relationship object containing the field, and  
 I<number> is the 1-based position of the object in the object list. Any parameters  
 specified in the filter clause should be specified in the B<Params> field.  
 The fields in a filter clause can come from primary entity relations,  
 relationship relations, or secondary entity relations; however, all of the  
 entities and relationships involved must be included in the list of object names.  
   
 =item Params  
   
 List of the parameters to be substituted in for the parameters marks in the filter clause. This  
 is a comma-separated list without any quoting or escaping.  
   
 =item fields  
   
 Comma-separated list of the fields to be returned in each element of the list returned. Fields  
 are specified in the same manner as in the filter clause.  
   
 =item count  
   
 Maximum number of records to return. If omitted or 0, all available records will be returned.  
   
 =back  
   
 B<GetAll> automatically joins together the entities and relationships listed in the object  
 names. This simplifies the coding of the filter clause, but it means that some queries are  
 not possible, since they cannot be expressed in a linear sequence of joins. This is a limitation  
 that has yet to be addressed.  
   
194  =cut  =cut
195    
196  # Declare the configuration variables.  # Declare the configuration variables.
# Line 290  Line 200 
200                              # standard output                              # standard output
201  my %Categories = ( main => 1 );  my %Categories = ( main => 1 );
202                              # hash of active category names                              # hash of active category names
203    my @LevelNames = qw(error warn notice info detail);
204  my $TraceLevel = 0;         # trace level; a higher trace level produces more  my $TraceLevel = 0;         # trace level; a higher trace level produces more
205                              # messages                              # messages
206  my @Queue = ();             # queued list of trace messages.  my @Queue = ();             # queued list of trace messages.
207  my $LastCategory = "main";  # name of the last category interrogated  my $LastCategory = "main";  # name of the last category interrogated
208    my $LastLevel = 0;          # level of the last test call
209  my $SetupCount = 0;         # number of times TSetup called  my $SetupCount = 0;         # number of times TSetup called
210  my $AllTrace = 0;           # TRUE if we are tracing all categories.  my $AllTrace = 0;           # TRUE if we are tracing all categories.
211    my $SavedCGI;               # CGI object passed to ETracing
212    my $CommandLine;            # Command line passed to StandardSetup
213    umask 2;                    # Fix the damn umask so everything is group-writable.
214    
215  =head2 Tracing Methods  =head2 Tracing Methods
216    
# Line 366  Line 281 
281          }          }
282      }      }
283      # Now we need to process the destination information. The most important special      # Now we need to process the destination information. The most important special
284      # cases are the single ">", which requires we clear the file first, and the      # case is when we're writing to a file. This is indicated by ">" (overwrite) and
285      # "+" prefix which indicates a double echo.      # ">>" (append). A leading "+" for either indicates that we are also writing to
286        # the standard output (tee mode).
287      if ($target =~ m/^\+?>>?/) {      if ($target =~ m/^\+?>>?/) {
288          if ($target =~ m/^\+/) {          if ($target =~ m/^\+/) {
289              $TeeFlag = 1;              $TeeFlag = 1;
290              $target = substr($target, 1);              $target = substr($target, 1);
291          }          }
292          if ($target =~ m/^>[^>]/) {          if ($target =~ m/^>[^>]/) {
293                # We need to initialize the file (which clears it).
294              open TRACEFILE, $target;              open TRACEFILE, $target;
295              print TRACEFILE "[" . Now() . "] <Tracer>: Tracing initialized.\n";              print TRACEFILE "[" . Now() . "] [notice] [Tracer] Tracing initialized.\n";
296              close TRACEFILE;              close TRACEFILE;
297                # Set to append mode now that the file has been cleared.
298              $Destination = ">$target";              $Destination = ">$target";
299          } else {          } else {
300              $Destination = $target;              $Destination = $target;
# Line 408  Line 326 
326      $TraceLevel = $_[0];      $TraceLevel = $_[0];
327  }  }
328    
329  =head3 ParseTraceDate  =head3 ParseDate
330    
331        my $time = Tracer::ParseDate($dateString);
332    
333      my $time = Tracer::ParseTraceDate($dateString);  Convert a date into a PERL time number. This method expects a date-like string
334    and parses it into a number. The string must be vaguely date-like or it will
335    return an undefined value. Our requirement is that a month and day be
336    present and that three pieces of the date string (time of day, month and day,
337    year) be separated by likely delimiters, such as spaces, commas, and such-like.
338    
339  Convert a date from the trace file into a PERL timestamp.  If a time of day is present, it must be in military time with two digits for
340    everything but the hour.
341    
342    The year must be exactly four digits.
343    
344    Additional stuff can be in the string. We presume it's time zones or weekdays or something
345    equally innocuous. This means, however, that a sufficiently long sentence with date-like
346    parts in it may be interpreted as a date. Hopefully this will not be a problem.
347    
348    It should be guaranteed that this method will parse the output of the L</Now> function.
349    
350    The parameters are as follows.
351    
352  =over 4  =over 4
353    
354  =item dateString  =item dateString
355    
356  The date string from the trace file. The format of the string is determined by the  The date string to convert.
 L</Now> method.  
357    
358  =item RETURN  =item RETURN
359    
360  Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if  Returns a PERL time, that is, a number of seconds since the epoch, or C<undef> if
361  the time string is invalid.  the date string is invalid. A valid date string must contain a month and day.
362    
363  =back  =back
364    
365  =cut  =cut
366    
367  sub ParseTraceDate {  # Universal month conversion table.
368    use constant MONTHS => {    Jan =>  0, January   =>  0, '01' =>  0,  '1' =>  0,
369                                Feb =>  1, February  =>  1, '02' =>  1,  '2' =>  1,
370                                Mar =>  2, March     =>  2, '03' =>  2,  '3' =>  2,
371                                Apr =>  3, April     =>  3, '04' =>  3,  '4' =>  3,
372                                May =>  4, May       =>  4, '05' =>  4,  '5' =>  4,
373                                Jun =>  5, June      =>  5, '06' =>  5,  '6' =>  5,
374                                Jul =>  6, July      =>  6, '07' =>  6,  '7' =>  6,
375                                Aug =>  7, August    =>  7, '08' =>  7,  '8' =>  7,
376                                Sep =>  8, September =>  8, '09' =>  8,  '9' =>  8,
377                                Oct =>  9, October  =>   9, '10' =>  9,
378                                Nov => 10, November =>  10, '11' => 10,
379                                Dec => 11, December =>  11, '12' => 11
380                            };
381    
382    sub ParseDate {
383      # Get the parameters.      # Get the parameters.
384      my ($dateString) = @_;      my ($dateString) = @_;
385      # Declare the return variable.      # Declare the return variable.
386      my $retVal;      my $retVal;
387      # Parse the date.      # Find the month and day of month. There are two ways that can happen. We check for the
388      if ($dateString =~ m#(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)#) {      # numeric style first. That way, if the user's done something like "Sun 12/22", then we
389          # Create a time object. Note we need to convert the day, month,      # won't be fooled into thinking the month is Sunday.
390          # and year to a different base. Years count from 1900, and      if ($dateString =~ m#\b(\d{1,2})/(\d{1,2})\b# || $dateString =~ m#\b(\w+)\s(\d{1,2})\b#) {
391          # the internal month value is relocated to January = 0.          my ($mon, $mday) = (MONTHS->{$1}, $2);
392          $retVal = timelocal($6, $5, $4, $2, $1 - 1, $3 - 1900);          # Insist that the month and day are valid.
393            if (defined($mon) && $2 >= 1 && $2 <= 31) {
394                # Find the time.
395                my ($hour, $min, $sec) = (0, 0, 0);
396                if ($dateString =~ /\b(\d{1,2}):(\d{2}):(\d{2})\b/) {
397                    ($hour, $min, $sec) = ($1, $2, $3);
398                }
399                # Find the year.
400                my $year;
401                if ($dateString =~ /\b(\d{4})\b/) {
402                    $year = $1;
403                } else {
404                    # Get the default year, which is this one. Note we must convert it to
405                    # the four-digit value expected by "timelocal".
406                    (undef, undef, undef, undef, undef, $year) = localtime();
407                    $year += 1900;
408                }
409                $retVal = timelocal($sec, $min, $hour, $mday, $mon, $year);
410            }
411      }      }
412      # Return the result.      # Return the result.
413      return $retVal;      return $retVal;
# Line 489  Line 456 
456  sub Trace {  sub Trace {
457      # Get the parameters.      # Get the parameters.
458      my ($message) = @_;      my ($message) = @_;
459        # Strip off any line terminators at the end of the message. We will add
460        # new-line stuff ourselves.
461        my $stripped = Strip($message);
462        # Compute the caller information.
463        my ($callPackage, $callFile, $callLine) = caller();
464        my $callFileTitle = basename($callFile);
465        # Check the caller.
466        my $callerInfo = ($callFileTitle ne "Tracer.pm" ? " [$callFileTitle $callLine]" : "");
467      # Get the timestamp.      # Get the timestamp.
468      my $timeStamp = Now();      my $timeStamp = Now();
469      # Format the message. Note we strip off any line terminators at the end.      # Build the prefix.
470      my $prefix = "[$timeStamp] <$LastCategory>: ";      my $level = $LevelNames[$LastLevel] || "($LastLevel)";
471      my $formatted = $prefix . Strip($message);      my $prefix = "[$timeStamp] [$level] [$LastCategory]$callerInfo";
472        # Format the message.
473        my $formatted = "$prefix $stripped";
474      # Process according to the destination.      # Process according to the destination.
475      if ($Destination eq "TEXT") {      if ($Destination eq "TEXT") {
476          # Write the message to the standard output.          # Write the message to the standard output.
477          print "$formatted\n";          print "$formatted\n";
478      } elsif ($Destination eq "ERROR") {      } elsif ($Destination eq "ERROR") {
479          # Write the message to the error output.          # Write the message to the error output. Here, we want our prefix fields.
480          print STDERR "$formatted\n";          print STDERR "$formatted\n";
481        } elsif ($Destination eq "WARN") {
482            # Emit the message to the standard error output. It is presumed that the
483            # error logger will add its own prefix fields, the notable exception being
484            # the caller info.
485            print STDERR "$callerInfo$stripped\n";
486      } elsif ($Destination eq "QUEUE") {      } elsif ($Destination eq "QUEUE") {
487          # Push the message into the queue.          # Push the message into the queue.
488          push @Queue, "$formatted";          push @Queue, "$formatted";
489      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
490          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML and write it to the standard output.
491          my $escapedMessage = CGI::escapeHTML($message);          my $escapedMessage = CGI::escapeHTML($stripped);
492          print "<p>$timeStamp $LastCategory: $escapedMessage</p>\n";          print "<p>$timeStamp $LastCategory $LastLevel: $escapedMessage</p>\n";
     } elsif ($Destination eq "WARN") {  
        # Emit the message as a warning.  
        carp $message;  
493      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
494          # Write the trace message to an output file.          # Write the trace message to an output file.
495          (open TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
496            # Lock the file.
497            flock TRACING, LOCK_EX;
498          print TRACING "$formatted\n";          print TRACING "$formatted\n";
499          close TRACING;          close TRACING;
500          # If the Tee flag is on, echo it to the standard output.          # If the Tee flag is on, echo it to the standard output.
# Line 576  Line 557 
557                  $category = $cats[$#cats];                  $category = $cats[$#cats];
558              }              }
559          }          }
560          # Save the category name.          # Save the category name and level.
561          $LastCategory = $category;          $LastCategory = $category;
562            $LastLevel = $traceLevel;
563          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
564          $category = lc $category;          $category = lc $category;
565          # Use the category and tracelevel to compute the result.          # Validate the trace level.
566          if (ref $traceLevel) {          if (ref $traceLevel) {
567              Confess("Bad trace level.");              Confess("Bad trace level.");
568          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
569              Confess("Bad trace config.");              Confess("Bad trace config.");
570          }          }
571          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
572            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
573      }      }
574      # Return the computed result.      # Return the computed result.
575      return $retVal;      return $retVal;
# Line 660  Line 643 
643  sub Confess {  sub Confess {
644      # Get the parameters.      # Get the parameters.
645      my ($message) = @_;      my ($message) = @_;
646        # Set up the category and level.
647        $LastCategory = "(confess)";
648        $LastLevel = 0;
649      if (! defined($FIG_Config::no_tool_hdr)) {      if (! defined($FIG_Config::no_tool_hdr)) {
650          # Here we have a tool header. Display its length so that the user can adjust the line numbers.          # Here we have a tool header. Display its length so that the user can adjust the line numbers.
651          my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";          my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";
652          # Only proceed if the tool header file is actually present.          # Only proceed if the tool header file is actually present.
653          if (-f $toolHeaderFile) {          if (-f $toolHeaderFile) {
654              my @lines = GetFile($toolHeaderFile);              my $fh;
655                if (open $fh, "<$toolHeaderFile") {
656                    my @lines = <$fh>;
657              Trace("Tool header has " . scalar(@lines) . " lines.");              Trace("Tool header has " . scalar(@lines) . " lines.");
658          }          }
659      }      }
660        }
661      # Trace the call stack.      # Trace the call stack.
662      Cluck($message);      Cluck($message);
663      # Abort the program.      # Abort the program.
664      croak(">>> $message");      croak(">>> $message");
665  }  }
666    
667    =head3 SaveCGI
668    
669        Tracer::SaveCGI($cgi);
670    
671    This method saves the CGI object but does not activate emergency tracing.
672    It is used to allow L</Warn> to work in situations where emergency
673    tracing is contra-indicated (e.g. the wiki).
674    
675    =over 4
676    
677    =item cgi
678    
679    Active CGI query object.
680    
681    =back
682    
683    =cut
684    
685    sub SaveCGI {
686        $SavedCGI = $_[0];
687    }
688    
689    =head3 Warn
690    
691        Warn($message, @options);
692    
693    This method traces an important message. If an RSS feed is configured
694    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
695    then the message will be echoed to the feed. In general, a tracing
696    destination of C<WARN> indicates that the caller is running as a web
697    service in a production environment; however, this is not a requirement.
698    
699    To force warnings into the RSS feed even when the tracing destination
700    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
701    configured automatically when L</StandardSetup> is used.
702    
703    The L</Cluck> method calls this one for its final message. Since
704    L</Confess> calls L</Cluck>, this means that any error which is caught
705    and confessed will put something in the feed. This insures that someone
706    will be alerted relatively quickly when a failure occurs.
707    
708    =over 4
709    
710    =item message
711    
712    Message to be traced.
713    
714    =item options
715    
716    A list containing zero or more options.
717    
718    =back
719    
720    The permissible options are as follows.
721    
722    =over 4
723    
724    =item noStack
725    
726    If specified, then the stack trace is not included in the output.
727    
728    =back
729    
730    =cut
731    
732    sub Warn {
733        # Get the parameters.
734        my $message = shift @_;
735        my %options = map { $_ => 1 } @_;
736        # Save $@;
737        my $savedError = $@;
738        # Trace the message.
739        Trace($message);
740        # This will contain the lock handle. If it's defined, it means we need to unlock.
741        my $lock;
742        # Check for feed forcing.
743        my $forceFeed = exists $Categories{feed};
744        # An error here would be disastrous. Note that if debug mode is specified,
745        # we do this stuff even in a test environment.
746        eval {
747            # Do we need to put this in the RSS feed?
748            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
749                # Probably. We need to check first, however, to see if it's from an
750                # ignored IP. For non-CGI situations, we default the IP to the self-referent.
751                my $key = "127.0.0.1";
752                if (defined $SavedCGI) {
753                    # Get the IP address.
754                    $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
755                }
756                # Is the IP address in the ignore list?
757                my $found = scalar(grep { $_ eq $key } @FIG_Config::error_ignore_ips);
758                if (! $found) {
759                    # No. We're good. We now need to compute the date, the link, and the title.
760                    # First, the date, in a very specific format.
761                    my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
762                        (tz_local_offset() / 30);
763                    # Environment data goes in here. We start with the date.
764                    my $environment = "$date.  ";
765                    # If we need to recap the message (because it's too long to be a title), we'll
766                    # put it in here.
767                    my $recap;
768                    # Copy the message and remove excess space.
769                    my $title = $message;
770                    $title =~ s/\s+/ /gs;
771                    # If it's too long, we have to split it up.
772                    if (length $title > 60) {
773                        # Put the full message in the environment string.
774                        $recap = $title;
775                        # Excerpt it as the title.
776                        $title = substr($title, 0, 50) . "...";
777                    }
778                    # If we have a CGI object, then this is a web error. Otherwise, it's
779                    # command-line.
780                    if (defined $SavedCGI) {
781                        # We're in a web service. The environment is the user's IP, and the link
782                        # is the URL that got us here.
783                        $environment .= "Event Reported at IP address $key process $$.";
784                        my $url = $SavedCGI->self_url();
785                        # We need the user agent string and (if available) the referrer.
786                        # The referrer will be the link.
787                        $environment .= " User Agent $ENV{HTTP_USER_AGENT}";
788                        if ($ENV{HTTP_REFERER}) {
789                            my $link = $ENV{HTTP_REFERER};
790                            $environment .= " referred from <a href=\"$link\">$link</a>.";
791                        } else {
792                            $environment .= " referrer unknown.";
793                        }
794                        # Close off the sentence with the original link.
795                        $environment .= " URL of event is <a href=\"$url\">$url</a>.";
796                    } else {
797                        # No CGI object, so we're a command-line tool. Use the tracing
798                        # key and the PID as the user identifier, and add the command.
799                        my $key = EmergencyKey();
800                        $environment .= "Event Reported by $key process $$.";
801                        if ($CommandLine) {
802                            # We're in a StandardSetup script, so we have the real command line.
803                            $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
804                        } elsif ($ENV{_}) {
805                            # We're in a BASH script, so the command has been stored in the _ variable.
806                            $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
807                        }
808                    }
809                    # Build a GUID. We use the current time, the title, and the process ID,
810                    # then digest the result.
811                    my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
812                    # Finally, the description. This is a stack trace plus various environmental stuff.
813                    # The trace is optional.
814                    my $stackTrace;
815                    if ($options{noStack}) {
816                        $stackTrace = "";
817                    } else {
818                        my @trace = LongMess();
819                        # Only proceed if we got something back.
820                        if (scalar(@trace) > 0) {
821                            $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
822                            $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
823                        }
824                    }
825                    # We got the stack trace. Now it's time to put it all together.
826                    # We have a goofy thing here in that we need to HTML-escape some sections of the description
827                    # twice. They will be escaped once here, and then once when written by XML::Simple. They are
828                    # unescaped once when processed by the RSS reader, and stuff in the description is treated as
829                    # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
830                    # our <br>s and <pre>s are used to format the description.
831                    $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
832                    my $description = "$recap$environment  $stackTrace";
833                    # Okay, we have all the pieces. Create a hash of the new event.
834                    my $newItem = { title => $title,
835                                    description => $description,
836                                    category => $LastCategory,
837                                    pubDate => $date,
838                                    guid => $guid,
839                                  };
840                    # We need XML capability for this.
841                    require XML::Simple;
842                    # The RSS document goes in here.
843                    my $rss;
844                    # Get the name of the RSS file. It's in the FIG temporary directory.
845                    my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
846                    # Open the config file and lock it.
847                    $lock = Open(undef, "<$FIG_Config::fig_disk/config/FIG_Config.pm");
848                    flock $lock, LOCK_EX;
849                    # Does it exist?
850                    if (-s $fileName) {
851                        # Slurp it in.
852                        $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
853                    } else {
854                        my $size = -s $fileName;
855                        # Create an empty channel.
856                        $rss = {
857                            channel => {
858                                title => 'NMPDR Warning Feed',
859                                link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
860                                description => "Important messages regarding the status of the NMPDR.",
861                                generator => "NMPDR Trace Facility",
862                                docs => "http://blogs.law.harvard.edu/tech/rss",
863                                item => []
864                            },
865                        };
866                    }
867                    # Get the channel object.
868                    my $channel = $rss->{channel};
869                    # Update the last-build date.
870                    $channel->{lastBuildDate} = $date;
871                    # Get the item array.
872                    my $items = $channel->{item};
873                    # Insure it has only 100 entries.
874                    while (scalar @{$items} > 100) {
875                        pop @{$items};
876                    }
877                    # Add our new item at the front.
878                    unshift @{$items}, $newItem;
879                    # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
880                    # the requirements for those.
881                    my $xml = XML::Simple::XMLout($channel, NoAttr => 1, RootName => 'channel', XmlDecl => '');
882                    # Here we put in the root and declaration. The problem is that the root has to have the version attribute
883                    # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
884                    $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
885                    # We don't use Open here because we can't afford an error.
886                    if (open XMLOUT, ">$fileName") {
887                        print XMLOUT $xml;
888                        close XMLOUT;
889                    }
890                }
891            }
892        };
893        if ($@) {
894            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
895            # (which is a good thing).
896            my $error = $@;
897            Trace("Feed Error: $error") if T(Feed => 0);
898        }
899        # Be sure to unlock.
900        if ($lock) {
901            flock $lock, LOCK_UN;
902            undef $lock;
903        }
904        # Restore the error message.
905        $@ = $savedError;
906    }
907    
908    
909    
910    
911  =head3 Assert  =head3 Assert
912    
913      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 725  Line 958 
958      my ($message) = @_;      my ($message) = @_;
959      # Trace what's happening.      # Trace what's happening.
960      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
961      my $confession = longmess($message);      # Get the stack trace.
962      # Convert the confession to a series of trace messages. Note we skip any      my @trace = LongMess();
963      # messages relating to calls into Tracer.      # Convert the trace to a series of messages.
964      for my $line (split /\s*\n/, $confession) {      for my $line (@trace) {
965          Trace($line) if ($line !~ /Tracer\.pm/);          # Replace the tab at the beginning with spaces.
966            $line =~ s/^\t/    /;
967            # Trace the line.
968            Trace($line);
969      }      }
970        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
971        Warn($message);
972  }  }
973    
974  =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  
975    
976  Returns a two-element list consisting of a CGI query object and a variable hash for      my @lines = Tracer::LongMess();
 the output page.  
977    
978  =back  Return a stack trace with all tracing methods removed. The return will be in the form of a list
979    of message strings.
980    
981  =cut  =cut
982    
983  sub ScriptSetup {  sub LongMess {
984      # Get the parameters.      # Declare the return variable.
985      my ($noTrace) = @_;      my @retVal = ();
986      # Get the CGI query object.      my $confession = longmess("");
987      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
988      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
989      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
990      # Create the variable hash.              push @retVal, $line;
991      my $varHash = { results => '' };          }
992      # Return the query object and variable hash.      }
993      return ($cgi, $varHash);      # Return the result.
994        return @retVal;
995  }  }
996    
997  =head3 ETracing  =head3 ETracing
# Line 806  Line 1025 
1025      # Get the parameter.      # Get the parameter.
1026      my ($parameter) = @_;      my ($parameter) = @_;
1027      # Check for CGI mode.      # Check for CGI mode.
1028      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
1029            $SavedCGI = $parameter;
1030        } else {
1031            $SavedCGI = undef;
1032        }
1033      # Default to no tracing except errors.      # Default to no tracing except errors.
1034      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
1035      # Check for emergency tracing.      # Check for emergency tracing.
# Line 839  Line 1062 
1062              # Set the trace parameter.              # Set the trace parameter.
1063              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1064          }          }
1065      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1066          # 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
1067          # for tracing from the form parameters.          # for tracing from the form parameters.
1068          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1069              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1070              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1071              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1072          }          }
1073      }      }
1074      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1075      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1076      # Check to see if we're a web script.      # Check to see if we're a web script.
1077      if (defined $cgi) {      if (defined $SavedCGI) {
1078          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1079          TraceParms($cgi);          TraceParms($SavedCGI);
1080          # 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
1081          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1082          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 958  Line 1181 
1181          $retVal = ">>" . EmergencyFileTarget($tkey);          $retVal = ">>" . EmergencyFileTarget($tkey);
1182      } elsif ($myDest eq 'DUAL') {      } elsif ($myDest eq 'DUAL') {
1183          $retVal = "+>" . EmergencyFileTarget($tkey);          $retVal = "+>" . EmergencyFileTarget($tkey);
1184        } elsif ($myDest eq 'WARN') {
1185            $retVal = "WARN";
1186      }      }
1187      # Return the result.      # Return the result.
1188      return $retVal;      return $retVal;
# Line 1043  Line 1268 
1268      my $retVal;      my $retVal;
1269      # Determine the parameter type.      # Determine the parameter type.
1270      if (! defined $parameter) {      if (! defined $parameter) {
1271          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1272          $retVal = $ENV{TRACING};          # get the effective login ID.
1273            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1274      } else {      } else {
1275          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1276          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1086  Line 1312 
1312      my ($cgi) = @_;      my ($cgi) = @_;
1313      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1314          # Here we trace the GET-style URL for the script.          # Here we trace the GET-style URL for the script.
1315          Trace("URL: " . $cgi->url(-relative => 1, -query => 1));          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));
1316      }      }
1317      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1318          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1095  Line 1321 
1321              # Note we skip the Trace parameters, which are for our use only.              # Note we skip the Trace parameters, which are for our use only.
1322              if ($parmName ne 'Trace' && $parmName ne 'TF') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
1323                  my @values = $cgi->param($parmName);                  my @values = $cgi->param($parmName);
1324                  Trace("CGI: $parmName = " . join(", ", @values));                  Trace("[CGI] $parmName = " . join(", ", @values));
1325              }              }
1326          }          }
1327          # Display the request method.          # Display the request method.
# Line 1105  Line 1331 
1331      if (T(CGI => 4)) {      if (T(CGI => 4)) {
1332          # Here we want the environment data too.          # Here we want the environment data too.
1333          for my $envName (sort keys %ENV) {          for my $envName (sort keys %ENV) {
1334              Trace("ENV: $envName = $ENV{$envName}");              Trace("[ENV] $envName = $ENV{$envName}");
1335          }          }
1336      }      }
1337  }  }
# Line 1161  Line 1387 
1387      }      }
1388  }  }
1389    
   
 =head3 ScriptFinish  
   
     ScriptFinish($webData, $varHash);  
   
 Output a web page at the end of a script. Either the string to be output or the  
 name of a template file can be specified. If the second parameter is omitted,  
 it is assumed we have a string to be output; otherwise, it is assumed we have the  
 name of a template file. The template should have the variable C<DebugData>  
 specified in any form that invokes a standard script. If debugging mode is turned  
 on, a form field will be put in that allows the user to enter tracing data.  
 Trace messages will be placed immediately before the terminal C<BODY> tag in  
 the output, formatted as a list.  
   
 A typical standard script would loook like the following.  
   
     BEGIN {  
         # Print the HTML header.  
         print "CONTENT-TYPE: text/html\n\n";  
     }  
     use Tracer;  
     use CGI;  
     use FIG;  
     # ... more uses ...  
   
     my ($cgi, $varHash) = ScriptSetup();  
     eval {  
         # ... get data from $cgi, put it in $varHash ...  
     };  
     if ($@) {  
         Trace("Script Error: $@") if T(0);  
     }  
     ScriptFinish("Html/MyTemplate.html", $varHash);  
   
 The idea here is that even if the script fails, you'll see trace messages and  
 useful output.  
   
 =over 4  
   
 =item webData  
   
 A string containing either the full web page to be written to the output or the  
 name of a template file from which the page is to be constructed. If the name  
 of a template file is specified, then the second parameter must be present;  
 otherwise, it must be absent.  
   
 =item varHash (optional)  
   
 If specified, then a reference to a hash mapping variable names for a template  
 to their values. The template file will be read into memory, and variable markers  
 will be replaced by data in this hash reference.  
   
 =back  
   
 =cut  
   
 sub ScriptFinish {  
     # Get the parameters.  
     my ($webData, $varHash) = @_;  
     # Check for a template file situation.  
     my $outputString;  
     if (defined $varHash) {  
         # Here we have a template file. We need to determine the template type.  
         my $template;  
         if ($FIG_Config::template_url && $webData =~ /\.php$/) {  
             $template = "$FIG_Config::template_url/$webData";  
         } else {  
             $template = "<<$webData";  
         }  
         $outputString = PageBuilder::Build($template, $varHash, "Html");  
     } else {  
         # Here the user gave us a raw string.  
         $outputString = $webData;  
     }  
     # Check for trace messages.  
     if ($Destination ne "NONE" && $TraceLevel > 0) {  
         # We have trace messages, so we want to put them at the end of the body. This  
         # is either at the end of the whole string or at the beginning of the BODY  
         # end-tag.  
         my $pos = length $outputString;  
         if ($outputString =~ m#</body>#gi) {  
             $pos = (pos $outputString) - 7;  
         }  
         # If the trace messages were queued, we unroll them. Otherwise, we display the  
         # destination.  
         my $traceHtml;  
         if ($Destination eq "QUEUE") {  
             $traceHtml = QTrace('Html');  
         } elsif ($Destination =~ /^>>(.+)$/) {  
             # Here the tracing output it to a file. We code it as a hyperlink so the user  
             # can copy the file name into the clipboard easily.  
             my $actualDest = $1;  
             $traceHtml = "<p>Tracing output to $actualDest.</p>\n";  
         } else {  
             # Here we have one of the special destinations.  
             $traceHtml = "<P>Tracing output type is $Destination.</p>\n";  
         }  
         substr $outputString, $pos, 0, $traceHtml;  
     }  
     # Write the output string.  
     print $outputString;  
 }  
   
1390  =head2 Command-Line Utility Methods  =head2 Command-Line Utility Methods
1391    
1392  =head3 SendSMS  =head3 SendSMS
# Line 1468  Line 1591 
1591  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
1592  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,
1593  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
1594  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
1595    login ID.
1596    
1597    Since the default situation in StandardSetup is to trace to the standard
1598    output, errors that occur in command-line scripts will not generate
1599    RSS events. To force the events, use the C<warn> option.
1600    
1601        TransactFeatures -background -warn register ../xacts IDs.tbl
1602    
1603  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1604  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 1615 
1615          -noAlias  do not expect aliases in CHANGE transactions          -noAlias  do not expect aliases in CHANGE transactions
1616          -start    start with this genome          -start    start with this genome
1617          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
1618            -forked   do not erase the trace file before tracing
1619    
1620  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
1621  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 1679 
1679      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1680      # Get the default tracing key.      # Get the default tracing key.
1681      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1682        # Save the command line.
1683        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1684      # Add the tracing options.      # Add the tracing options.
1685      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1686          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
1687      }      }
1688        $options->{forked} = [0, "keep old trace file"];
1689      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
1690      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1691      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1692      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1693        $options->{warn} = [0, "send errors to RSS feed"];
1694      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1695      # contains the default values rather than the default value      # contains the default values rather than the default value
1696      # 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 1574  Line 1709 
1709      my $suffix = $retOptions->{user};      my $suffix = $retOptions->{user};
1710      # Check for background mode.      # Check for background mode.
1711      if ($retOptions->{background}) {      if ($retOptions->{background}) {
1712          my $outFileName = "$FIG_Config::temp/out$suffix.log";          my $outFileName = "$FIG_Config::temp/out$suffix$$.log";
1713          my $errFileName = "$FIG_Config::temp/err$suffix.log";          my $errFileName = "$FIG_Config::temp/err$suffix$$.log";
1714          open STDOUT, ">$outFileName";          open STDOUT, ">$outFileName";
1715          open STDERR, ">$errFileName";          open STDERR, ">$errFileName";
1716          # Check for phone support. If we have phone support and a phone number,          # Check for phone support. If we have phone support and a phone number,
# Line 1594  Line 1729 
1729          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1730              push @cats, "SQL";              push @cats, "SQL";
1731          }          }
1732            if ($retOptions->{warn}) {
1733                push @cats, "Feed";
1734            }
1735          # Add the default categories.          # Add the default categories.
1736          push @cats, "Tracer";          push @cats, "Tracer";
1737          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
# Line 1610  Line 1748 
1748          my $traceMode;          my $traceMode;
1749          # Verify that we can open a file in the FIG temporary directory.          # Verify that we can open a file in the FIG temporary directory.
1750          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
1751          if (open TESTTRACE, ">$traceFileName") {          my $traceFileSpec = ($retOptions->{forked} ? ">>$traceFileName" : ">$traceFileName");
1752            if (open TESTTRACE, "$traceFileSpec") {
1753              # Here we can trace to a file.              # Here we can trace to a file.
1754              $traceMode = ">$traceFileName";              $traceMode = ">>$traceFileName";
1755              if ($textOKFlag) {              if ($textOKFlag) {
1756                  # Echo to standard output if the text-OK flag is set.                  # Echo to standard output if the text-OK flag is set.
1757                  $traceMode = "+$traceMode";                  $traceMode = "+$traceMode";
# Line 1620  Line 1759 
1759              # Close the test file.              # Close the test file.
1760              close TESTTRACE;              close TESTTRACE;
1761          } else {          } else {
1762              # 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.
1763                warn "Could not open trace file $traceFileName: $!\n";
1764                # We trace to the standard output if it's
1765              # okay, and the error log otherwise.              # okay, and the error log otherwise.
1766              if ($textOKFlag) {              if ($textOKFlag) {
1767                  $traceMode = "TEXT";                  $traceMode = "TEXT";
# Line 1811  Line 1952 
1952      }      }
1953  }  }
1954    
1955  =head3 ParseCommand  =head3 UnparseOptions
1956    
1957      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);      my $optionString = Tracer::UnparseOptions(\%options);
1958    
1959  Parse a command line consisting of a list of parameters. The initial parameters may be option  Convert an option hash into a command-line string. This will not
1960  specifiers of the form C<->I<option> or C<->I<option>C<=>I<value>. The options are stripped  necessarily be the same text that came in, but it will nonetheless
1961  off and merged into a table of default options. The remainder of the command line is  produce the same ultimate result when parsed by L</StandardSetup>.
 returned as a list of positional arguments. For example, consider the following invocation.  
1962    
1963      my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words);  =over 4
1964    
1965    =item options
1966    
1967    Reference to a hash of options to convert into an option string.
1968    
1969    =item RETURN
1970    
1971    Returns a string that will parse to the same set of options when
1972    parsed by L</StandardSetup>.
1973    
1974    =back
1975    
1976    =cut
1977    
1978    sub UnparseOptions {
1979        # Get the parameters.
1980        my ($options) = @_;
1981        # The option segments will be put in here.
1982        my @retVal = ();
1983        # Loop through the options.
1984        for my $key (keys %$options) {
1985            # Get the option value.
1986            my $value = $options->{$key};
1987            # Only use it if it's nonempty.
1988            if (defined $value && $value ne "") {
1989                my $segment = "--$key=$value";
1990                # Quote it if necessary.
1991                if ($segment =~ /[ |<>*]/) {
1992                    $segment = '"' . $segment . '"';
1993                }
1994                # Add it to the return list.
1995                push @retVal, $segment;
1996            }
1997        }
1998        # Return the result.
1999        return join(" ", @retVal);
2000    }
2001    
2002    =head3 ParseCommand
2003    
2004        my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);
2005    
2006    Parse a command line consisting of a list of parameters. The initial parameters may be option
2007    specifiers of the form C<->I<option> or C<->I<option>C<=>I<value>. The options are stripped
2008    off and merged into a table of default options. The remainder of the command line is
2009    returned as a list of positional arguments. For example, consider the following invocation.
2010    
2011        my ($options, @arguments) = ParseCommand({ errors => 0, logFile => 'trace.log'}, @words);
2012    
2013  In this case, the list @words will be treated as a command line and there are two options available,  In this case, the list @words will be treated as a command line and there are two options available,
2014  B<errors> and B<logFile>. If @words has the following format  B<errors> and B<logFile>. If @words has the following format
# Line 2389  Line 2577 
2577  Map of search patterns to permission masks. If a directory name matches  Map of search patterns to permission masks. If a directory name matches
2578  one of the patterns, that directory and all its members and subdirectories  one of the patterns, that directory and all its members and subdirectories
2579  will be assigned the new pattern. For example, the following would  will be assigned the new pattern. For example, the following would
2580  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>.
2581    
2582      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2583    
# Line 2442  Line 2630 
2630                      $match = 1;                      $match = 1;
2631                  }                  }
2632              }              }
2633              # 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
2634              # before terminating due to the match.              # before terminating due to the match.
2635              if ($match && $otherMasks[$i-1] != $mask) {              if ($match && $otherMasks[$i-1] != $mask) {
2636                  # 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 2772 
2772  }  }
2773    
2774    
2775    =head3 PrintLine
2776    
2777        Tracer::PrintLine($line);
2778    
2779    Print a line of text with a trailing new-line.
2780    
2781    =over 4
2782    
2783    =item line
2784    
2785    Line of text to print.
2786    
2787    =back
2788    
2789    =cut
2790    
2791    sub PrintLine {
2792        # Get the parameters.
2793        my ($line) = @_;
2794        # Print the line.
2795        print "$line\n";
2796    }
2797    
2798    
2799  =head2 Other Useful Methods  =head2 Other Useful Methods
2800    
# Line 2624  Line 2835 
2835      return $retVal;      return $retVal;
2836  }  }
2837    
   
   
   
2838  =head3 Now  =head3 Now
2839    
2840      my $string = Tracer::Now();      my $string = Tracer::Now();
2841    
2842  Return a displayable time stamp containing the local time.  Return a displayable time stamp containing the local time. Whatever format this
2843    method produces must be parseable by L</ParseDate>.
2844    
2845  =cut  =cut
2846    
2847  sub Now {  sub Now {
2848      my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);      return DisplayTime(time);
2849      my $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .  }
2850    
2851    =head3 DisplayTime
2852    
2853        my $string = Tracer::DisplayTime($time);
2854    
2855    Convert a time value to a displayable time stamp. Whatever format this
2856    method produces must be parseable by L</ParseDate>.
2857    
2858    =over 4
2859    
2860    =item time
2861    
2862    Time to display, in seconds since the epoch, or C<undef> if the time is unknown.
2863    
2864    =item RETURN
2865    
2866    Returns a displayable time, or C<(n/a)> if the incoming time is undefined.
2867    
2868    =back
2869    
2870    =cut
2871    
2872    sub DisplayTime {
2873        my ($time) = @_;
2874        my $retVal = "(n/a)";
2875        if (defined $time) {
2876            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
2877            $retVal = _p2($mon+1) . "/" . _p2($mday) . "/" . ($year + 1900) . " " .
2878                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);                   _p2($hour) . ":" . _p2($min) . ":" . _p2($sec);
2879        }
2880      return $retVal;      return $retVal;
2881  }  }
2882    
# Line 2802  Line 3040 
3040      return $retVal;      return $retVal;
3041  }  }
3042    
3043    =head3 Constrain
3044    
3045        my $constrained = Constrain($value, $min, $max);
3046    
3047    Modify a numeric value to bring it to a point in between a maximum and a minimum.
3048    
3049    =over 4
3050    
3051    =item value
3052    
3053    Value to constrain.
3054    
3055    =item min (optional)
3056    
3057    Minimum permissible value. If this parameter is undefined, no minimum constraint will be applied.
3058    
3059    =item max (optional)
3060    
3061    Maximum permissible value. If this parameter is undefined, no maximum constraint will be applied.
3062    
3063    =item RETURN
3064    
3065    Returns the incoming value, constrained according to the other parameters.
3066    
3067    =back
3068    
3069    =cut
3070    
3071    sub Constrain {
3072        # Get the parameters.
3073        my ($value, $min, $max) = @_;
3074        # Declare the return variable.
3075        my $retVal = $value;
3076        # Apply the minimum constraint.
3077        if (defined $min && $retVal < $min) {
3078            $retVal = $min;
3079        }
3080        # Apply the maximum constraint.
3081        if (defined $max && $retVal > $max) {
3082            $retVal = $max;
3083        }
3084        # Return the result.
3085        return $retVal;
3086    }
3087    
3088  =head3 Min  =head3 Min
3089    
3090      my $min = Min($value1, $value2, ... $valueN);      my $min = Min($value1, $value2, ... $valueN);
# Line 2868  Line 3151 
3151      return $retVal;      return $retVal;
3152  }  }
3153    
 =head3 DebugMode  
   
     if (Tracer::DebugMode) { ...code... }  
   
 Return TRUE if debug mode has been turned on, else abort.  
   
 Certain CGI scripts are too dangerous to exist in the production  
 environment. This method provides a simple way to prevent them  
 from working unless they are explicitly turned on by creating a password  
 cookie via the B<SetPassword> script.  If debugging mode  
 is not turned on, an error will occur.  
   
 =cut  
   
 sub DebugMode {  
     # Declare the return variable.  
     my $retVal = 0;  
     # Check the debug configuration.  
     my $password = CGI::cookie("DebugMode");  
     my $encrypted = Digest::MD5::md5_hex($password);  
     if ($encrypted eq "252dec43280e0c0d6a75ffcec486e61d") {  
         $retVal = 1;  
     } else {  
         # Here debug mode is off, so we generate an error.  
         Confess("Cannot use this facility without logging in.");  
     }  
     # Return the determination indicator.  
     return $retVal;  
 }  
   
3154  =head3 Strip  =head3 Strip
3155    
3156      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
# Line 3147  Line 3400 
3400      return ($inserted, $deleted);      return ($inserted, $deleted);
3401  }  }
3402    
3403    =head3 Cmp
3404    
3405        my $cmp = Tracer::Cmp($a, $b);
3406    
3407    This method performs a universal sort comparison. Each value coming in is
3408    separated into a leading text part and a trailing number part. The text
3409    part is string compared, and if both parts are equal, then the number
3410    parts are compared numerically. A stream of just numbers or a stream of
3411    just strings will sort correctly, and a mixed stream will sort with the
3412    numbers first. Strings with a label and a number will sort in the
3413    expected manner instead of lexically.
3414    
3415    =over 4
3416    
3417    =item a
3418    
3419    First item to compare.
3420    
3421    =item b
3422    
3423    Second item to compare.
3424    
3425    =item RETURN
3426    
3427    Returns a negative number if the first item should sort first (is less), a positive
3428    number if the first item should sort second (is greater), and a zero if the items are
3429    equal.
3430    
3431    =back
3432    
3433    =cut
3434    
3435    sub Cmp {
3436        # Get the parameters.
3437        my ($a, $b) = @_;
3438        # Declare the return value.
3439        my $retVal;
3440        # Check for nulls.
3441        if (! defined($a)) {
3442            $retVal = (! defined($b) ? 0 : -1);
3443        } elsif (! defined($b)) {
3444            $retVal = 1;
3445        } else {
3446            # Here we have two real values. Parse the two strings.
3447            $a =~ /^(\D*)(\d*)$/;
3448            my $aParsed = [$1, $2];
3449            $b =~ /^(\D*)(\d*)$/;
3450            my $bParsed = [$1, $2];
3451            # Compare the string parts.
3452            $retVal = $aParsed->[0] cmp $bParsed->[0];
3453            if (! $retVal) {
3454                $retVal = $aParsed->[1] <=> $bParsed->[1];
3455            }
3456        }
3457        # Return the result.
3458        return $retVal;
3459    }
3460    
3461    =head3 ListEQ
3462    
3463        my $flag = Tracer::ListEQ(\@a, \@b);
3464    
3465    Return TRUE if the specified lists contain the same strings in the same
3466    order, else FALSE.
3467    
3468    =over 4
3469    
3470    =item a
3471    
3472    Reference to the first list.
3473    
3474    =item b
3475    
3476    Reference to the second list.
3477    
3478    =item RETURN
3479    
3480    Returns TRUE if the two parameters are identical string lists, else FALSE.
3481    
3482    =back
3483    
3484    =cut
3485    
3486    sub ListEQ {
3487        # Get the parameters.
3488        my ($a, $b) = @_;
3489        # Declare the return variable. Start by checking the lengths.
3490        my $n = scalar(@$a);
3491        my $retVal = ($n == scalar(@$b));
3492        # Now compare the list elements.
3493        for (my $i = 0; $retVal && $i < $n; $i++) {
3494            $retVal = ($a->[$i] eq $b->[$i]);
3495        }
3496        # Return the result.
3497        return $retVal;
3498    }
3499    
3500    =head2 CGI Script Utilities
3501    
3502    =head3 ScriptSetup (deprecated)
3503    
3504        my ($cgi, $varHash) = ScriptSetup($noTrace);
3505    
3506    Perform standard tracing and debugging setup for scripts. The value returned is
3507    the CGI object followed by a pre-built variable hash. At the end of the script,
3508    the client should call L</ScriptFinish> to output the web page.
3509    
3510    This method calls L</ETracing> to configure tracing, which allows the tracing
3511    to be configured via the emergency tracing form on the debugging control panel.
3512    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3513    method, which includes every program that uses this method or L</StandardSetup>.
3514    
3515    =over 4
3516    
3517    =item noTrace (optional)
3518    
3519    If specified, tracing will be suppressed. This is useful if the script wants to set up
3520    tracing manually.
3521    
3522    =item RETURN
3523    
3524    Returns a two-element list consisting of a CGI query object and a variable hash for
3525    the output page.
3526    
3527    =back
3528    
3529    =cut
3530    
3531    sub ScriptSetup {
3532        # Get the parameters.
3533        my ($noTrace) = @_;
3534        # Get the CGI query object.
3535        my $cgi = CGI->new();
3536        # Set up tracing if it's not suppressed.
3537        ETracing($cgi) unless $noTrace;
3538        # Create the variable hash.
3539        my $varHash = { results => '' };
3540        # Return the query object and variable hash.
3541        return ($cgi, $varHash);
3542    }
3543    
3544    =head3 ScriptFinish (deprecated)
3545    
3546        ScriptFinish($webData, $varHash);
3547    
3548    Output a web page at the end of a script. Either the string to be output or the
3549    name of a template file can be specified. If the second parameter is omitted,
3550    it is assumed we have a string to be output; otherwise, it is assumed we have the
3551    name of a template file. The template should have the variable C<DebugData>
3552    specified in any form that invokes a standard script. If debugging mode is turned
3553    on, a form field will be put in that allows the user to enter tracing data.
3554    Trace messages will be placed immediately before the terminal C<BODY> tag in
3555    the output, formatted as a list.
3556    
3557    A typical standard script would loook like the following.
3558    
3559        BEGIN {
3560            # Print the HTML header.
3561            print "CONTENT-TYPE: text/html\n\n";
3562        }
3563        use Tracer;
3564        use CGI;
3565        use FIG;
3566        # ... more uses ...
3567    
3568        my ($cgi, $varHash) = ScriptSetup();
3569        eval {
3570            # ... get data from $cgi, put it in $varHash ...
3571        };
3572        if ($@) {
3573            Trace("Script Error: $@") if T(0);
3574        }
3575        ScriptFinish("Html/MyTemplate.html", $varHash);
3576    
3577    The idea here is that even if the script fails, you'll see trace messages and
3578    useful output.
3579    
3580    =over 4
3581    
3582    =item webData
3583    
3584    A string containing either the full web page to be written to the output or the
3585    name of a template file from which the page is to be constructed. If the name
3586    of a template file is specified, then the second parameter must be present;
3587    otherwise, it must be absent.
3588    
3589    =item varHash (optional)
3590    
3591    If specified, then a reference to a hash mapping variable names for a template
3592    to their values. The template file will be read into memory, and variable markers
3593    will be replaced by data in this hash reference.
3594    
3595    =back
3596    
3597    =cut
3598    
3599    sub ScriptFinish {
3600        # Get the parameters.
3601        my ($webData, $varHash) = @_;
3602        # Check for a template file situation.
3603        my $outputString;
3604        if (defined $varHash) {
3605            # Here we have a template file. We need to determine the template type.
3606            my $template;
3607            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3608                $template = "$FIG_Config::template_url/$webData";
3609            } else {
3610                $template = "<<$webData";
3611            }
3612            $outputString = PageBuilder::Build($template, $varHash, "Html");
3613        } else {
3614            # Here the user gave us a raw string.
3615            $outputString = $webData;
3616        }
3617        # Check for trace messages.
3618        if ($Destination ne "NONE" && $TraceLevel > 0) {
3619            # We have trace messages, so we want to put them at the end of the body. This
3620            # is either at the end of the whole string or at the beginning of the BODY
3621            # end-tag.
3622            my $pos = length $outputString;
3623            if ($outputString =~ m#</body>#gi) {
3624                $pos = (pos $outputString) - 7;
3625            }
3626            # If the trace messages were queued, we unroll them. Otherwise, we display the
3627            # destination.
3628            my $traceHtml;
3629            if ($Destination eq "QUEUE") {
3630                $traceHtml = QTrace('Html');
3631            } elsif ($Destination =~ /^>>(.+)$/) {
3632                # Here the tracing output it to a file. We code it as a hyperlink so the user
3633                # can copy the file name into the clipboard easily.
3634                my $actualDest = $1;
3635                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3636            } else {
3637                # Here we have one of the special destinations.
3638                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3639            }
3640            substr $outputString, $pos, 0, $traceHtml;
3641        }
3642        # Write the output string.
3643        print $outputString;
3644    }
3645    
3646  =head3 GenerateURL  =head3 GenerateURL
3647    
3648      my $queryUrl = Tracer::GenerateURL($page, %parameters);      my $queryUrl = Tracer::GenerateURL($page, %parameters);
# Line 3281  Line 3777 
3777      return $retVal;      return $retVal;
3778  }  }
3779    
3780  =head3 Cmp  =head3 TrackingCode
3781    
3782      my $cmp = Tracer::Cmp($a, $b);      my $html = Tracer::TrackingCode();
3783    
3784  This method performs a universal sort comparison. Each value coming in is  Returns the HTML code for doing web page traffic monitoring. If the
3785  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;
3786  part is string compared, and if both parts are equal, then the number  otherwise, it returns a bunch of javascript containing code for turning
3787  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.  
3788    
3789  =over 4  =cut
3790    
3791  =item a  sub TrackingCode {
3792        # Declare the return variable.
3793        my $retVal = "<!-- tracking off -->";
3794        # Determine if we're in production.
3795        if ($FIG_Config::site_meter) {
3796            $retVal = <<END_HTML
3797            <!-- Site Meter -->
3798            <script type="text/javascript" src="http://s20.sitemeter.com/js/counter.js?site=s20nmpdr">
3799            </script>
3800            <noscript>
3801            <a href="http://s20.sitemeter.com/stats.asp?site=s20nmpdr" target="_top">
3802            <img src="http://s20.sitemeter.com/meter.asp?site=s20nmpdr" alt="Site Meter" border="0"/></a>
3803            </noscript>
3804            <!-- Copyright (c)2006 Site Meter -->
3805    END_HTML
3806        }
3807        return $retVal;
3808    }
3809    
3810  First item to compare.  =head3 Clean
3811    
3812  =item b      my $cleaned = Tracer::Clean($string);
3813    
3814  Second item to compare.  Clean up a string for HTML display. This not only converts special
3815    characters to HTML entity names, it also removes control characters.
3816    
3817    =over 4
3818    
3819    =item string
3820    
3821    String to convert.
3822    
3823  =item RETURN  =item RETURN
3824    
3825  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
3826  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.  
3827    
3828  =back  =back
3829    
3830  =cut  =cut
3831    
3832  sub Cmp {  sub Clean {
3833      # Get the parameters.      # Get the parameters.
3834      my ($a, $b) = @_;      my ($string) = @_;
3835      # Declare the return value.      # Declare the return variable.
3836      my $retVal;      my $retVal = "";
3837      # Check for nulls.      # Only proceed if the value exists.
3838      if (! defined($a)) {      if (defined $string) {
3839          $retVal = (! defined($b) ? 0 : -1);          # Get the string.
3840      } elsif (! defined($b)) {          $retVal = $string;
3841          $retVal = 1;          # Clean the control characters.
3842      } else {          $retVal =~ tr/\x00-\x1F/?/;
3843          # Here we have two real values. Parse the two strings.          # Escape the rest.
3844          $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];  
         }  
3845      }      }
3846      # Return the result.      # Return the result.
3847      return $retVal;      return $retVal;
3848  }  }
3849    
3850    
3851    
3852    
3853  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3