[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.98, Thu May 1 07:52:10 2008 UTC revision 1.109, Tue Sep 23 15:33:54 2008 UTC
# Line 20  Line 20 
20    
21      require Exporter;      require Exporter;
22      @ISA = ('Exporter');      @ISA = ('Exporter');
23      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain 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 PrintLine PutLine);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);
25      use strict;      use strict;
26      use Carp qw(longmess croak carp);      use Carp qw(longmess croak carp);
# Line 36  Line 36 
36      use Time::HiRes 'gettimeofday';      use Time::HiRes 'gettimeofday';
37      use URI::Escape;      use URI::Escape;
38      use Time::Local;      use Time::Local;
39        use POSIX qw(strftime);
40        use Time::Zone;
41        use Fcntl ':flock';
42    
43    
44  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
45    
# Line 204  Line 208 
208  my $LastLevel = 0;          # level of the last test call  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 553  Line 560 
560          $LastLevel = $traceLevel;          $LastLevel = $traceLevel;
561          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
562          $category = lc $category;          $category = lc $category;
563          # Use the category and tracelevel to compute the result.          # Validate the trace level.
564          if (ref $traceLevel) {          if (ref $traceLevel) {
565              Confess("Bad trace level.");              Confess("Bad trace level.");
566          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
567              Confess("Bad trace config.");              Confess("Bad trace config.");
568          }          }
569          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
570            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
571      }      }
572      # Return the computed result.      # Return the computed result.
573      return $retVal;      return $retVal;
# Line 654  Line 662 
662      croak(">>> $message");      croak(">>> $message");
663  }  }
664    
665    =head3 SaveCGI
666    
667        Tracer::SaveCGI($cgi);
668    
669    This method saves the CGI object but does not activate emergency tracing.
670    It is used to allow L</Warn> to work in situations where emergency
671    tracing is contra-indicated (e.g. the wiki).
672    
673    =over 4
674    
675    =item cgi
676    
677    Active CGI query object.
678    
679    =back
680    
681    =cut
682    
683    sub SaveCGI {
684        $SavedCGI = $_[0];
685    }
686    
687    =head3 Warn
688    
689        Warn($message, @options);
690    
691    This method traces an important message. If an RSS feed is configured
692    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
693    then the message will be echoed to the feed. In general, a tracing
694    destination of C<WARN> indicates that the caller is running as a web
695    service in a production environment; however, this is not a requirement.
696    
697    To force warnings into the RSS feed even when the tracing destination
698    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
699    configured automatically when L</StandardSetup> is used.
700    
701    The L</Cluck> method calls this one for its final message. Since
702    L</Confess> calls L</Cluck>, this means that any error which is caught
703    and confessed will put something in the feed. This insures that someone
704    will be alerted relatively quickly when a failure occurs.
705    
706    =over 4
707    
708    =item message
709    
710    Message to be traced.
711    
712    =item options
713    
714    A list containing zero or more options.
715    
716    =back
717    
718    The permissible options are as follows.
719    
720    =over 4
721    
722    =item noStack
723    
724    If specified, then the stack trace is not included in the output.
725    
726    =back
727    
728    =cut
729    
730    sub Warn {
731        # Get the parameters.
732        my $message = shift @_;
733        my %options = map { $_ => 1 } @_;
734        # Save $@;
735        my $savedError = $@;
736        # Trace the message.
737        Trace($message);
738        # This will contain the lock handle. If it's defined, it means we need to unlock.
739        my $lock;
740        # Check for feed forcing.
741        my $forceFeed = exists $Categories{feed};
742        # An error here would be disastrous. Note that if debug mode is specified,
743        # we do this stuff even in a test environment.
744        eval {
745            # Do we need to put this in the RSS feed?
746            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
747                # Probably. We need to check first, however, to see if it's from an
748                # ignored IP. For non-CGI situations, we default the IP to the self-referent.
749                my $key = "127.0.0.1";
750                if (defined $SavedCGI) {
751                    # Get the IP address.
752                    $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
753                }
754                # Is the IP address in the ignore list?
755                my $found = scalar(grep { $_ eq $key } @FIG_Config::error_ignore_ips);
756                if (! $found) {
757                    # No. We're good. We now need to compute the date, the link, and the title.
758                    # First, the date, in a very specific format.
759                    my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
760                        (tz_local_offset() / 30);
761                    # Environment data goes in here. We start with the date.
762                    my $environment = "$date.  ";
763                    # If we need to recap the message (because it's too long to be a title), we'll
764                    # put it in here.
765                    my $recap;
766                    # Copy the message and remove excess space.
767                    my $title = $message;
768                    $title =~ s/\s+/ /gs;
769                    # If it's too long, we have to split it up.
770                    if (length $title > 60) {
771                        # Put the full message in the environment string.
772                        $recap = $title;
773                        # Excerpt it as the title.
774                        $title = substr($title, 0, 50) . "...";
775                    }
776                    # If we have a CGI object, then this is a web error. Otherwise, it's
777                    # command-line.
778                    if (defined $SavedCGI) {
779                        # We're in a web service. The environment is the user's IP, and the link
780                        # is the URL that got us here.
781                        $environment .= "Event Reported at IP address $key process $$.";
782                        my $url = $SavedCGI->self_url();
783                        # We need the user agent string and (if available) the referrer.
784                        # The referrer will be the link.
785                        $environment .= " User Agent $ENV{HTTP_USER_AGENT}";
786                        if ($ENV{HTTP_REFERER}) {
787                            my $link = $ENV{HTTP_REFERER};
788                            $environment .= " referred from <a href=\"$link\">$link</a>.";
789                        } else {
790                            $environment .= " referrer unknown.";
791                        }
792                        # Close off the sentence with the original link.
793                        $environment .= " URL of event is <a href=\"$url\">$url</a>.";
794                    } else {
795                        # No CGI object, so we're a command-line tool. Use the tracing
796                        # key and the PID as the user identifier, and add the command.
797                        my $key = EmergencyKey();
798                        $environment .= "Event Reported by $key process $$.";
799                        if ($CommandLine) {
800                            # We're in a StandardSetup script, so we have the real command line.
801                            $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
802                        } elsif ($ENV{_}) {
803                            # We're in a BASH script, so the command has been stored in the _ variable.
804                            $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
805                        }
806                    }
807                    # Build a GUID. We use the current time, the title, and the process ID,
808                    # then digest the result.
809                    my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
810                    # Finally, the description. This is a stack trace plus various environmental stuff.
811                    # The trace is optional.
812                    my $stackTrace;
813                    if ($options{noStack}) {
814                        $stackTrace = "";
815                    } else {
816                        my @trace = LongMess();
817                        # Only proceed if we got something back.
818                        if (scalar(@trace) > 0) {
819                            $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
820                            $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
821                        }
822                    }
823                    # We got the stack trace. Now it's time to put it all together.
824                    # We have a goofy thing here in that we need to HTML-escape some sections of the description
825                    # twice. They will be escaped once here, and then once when written by XML::Simple. They are
826                    # unescaped once when processed by the RSS reader, and stuff in the description is treated as
827                    # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
828                    # our <br>s and <pre>s are used to format the description.
829                    $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
830                    my $description = "$recap$environment  $stackTrace";
831                    # Okay, we have all the pieces. Create a hash of the new event.
832                    my $newItem = { title => $title,
833                                    description => $description,
834                                    category => $LastCategory,
835                                    pubDate => $date,
836                                    guid => $guid,
837                                  };
838                    # We need XML capability for this.
839                    require XML::Simple;
840                    # The RSS document goes in here.
841                    my $rss;
842                    # Get the name of the RSS file. It's in the FIG temporary directory.
843                    my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
844                    # Open the config file and lock it.
845                    $lock = Open(undef, "<$FIG_Config::fig_disk/config/FIG_Config.pm");
846                    flock $lock, LOCK_EX;
847                    # Does it exist?
848                    if (-s $fileName) {
849                        # Slurp it in.
850                        $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
851                    } else {
852                        my $size = -s $fileName;
853                        # Create an empty channel.
854                        $rss = {
855                            channel => {
856                                title => 'NMPDR Warning Feed',
857                                link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
858                                description => "Important messages regarding the status of the NMPDR.",
859                                generator => "NMPDR Trace Facility",
860                                docs => "http://blogs.law.harvard.edu/tech/rss",
861                                item => []
862                            },
863                        };
864                    }
865                    # Get the channel object.
866                    my $channel = $rss->{channel};
867                    # Update the last-build date.
868                    $channel->{lastBuildDate} = $date;
869                    # Get the item array.
870                    my $items = $channel->{item};
871                    # Insure it has only 100 entries.
872                    while (scalar @{$items} > 100) {
873                        pop @{$items};
874                    }
875                    # Add our new item at the front.
876                    unshift @{$items}, $newItem;
877                    # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
878                    # the requirements for those.
879                    my $xml = XML::Simple::XMLout($channel, NoAttr => 1, RootName => 'channel', XmlDecl => '');
880                    # Here we put in the root and declaration. The problem is that the root has to have the version attribute
881                    # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
882                    $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
883                    # We don't use Open here because we can't afford an error.
884                    if (open XMLOUT, ">$fileName") {
885                        print XMLOUT $xml;
886                        close XMLOUT;
887                    }
888                }
889            }
890        };
891        if ($@) {
892            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
893            # (which is a good thing).
894            my $error = $@;
895            Trace("Feed Error: $error") if T(Feed => 0);
896        }
897        # Be sure to unlock.
898        if ($lock) {
899            flock $lock, LOCK_UN;
900            undef $lock;
901        }
902        # Restore the error message.
903        $@ = $savedError;
904    }
905    
906    
907    
908    
909  =head3 Assert  =head3 Assert
910    
911      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 956 
956      my ($message) = @_;      my ($message) = @_;
957      # Trace what's happening.      # Trace what's happening.
958      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
959      my $confession = longmess($message);      # Get the stack trace.
960      # Convert the confession to a series of trace messages.      my @trace = LongMess();
961      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
962          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
963          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
964              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
965              # Trace the line.              # Trace the line.
966              Trace($line);              Trace($line);
967          }          }
968        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
969        Warn($message);
970      }      }
 }  
   
 =head3 ScriptSetup (deprecated)  
   
     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.  
971    
972  =item RETURN  =head3 LongMess
973    
974  Returns a two-element list consisting of a CGI query object and a variable hash for      my @lines = Tracer::LongMess();
 the output page.  
975    
976  =back  Return a stack trace with all tracing methods removed. The return will be in the form of a list
977    of message strings.
978    
979  =cut  =cut
980    
981  sub ScriptSetup {  sub LongMess {
982      # Get the parameters.      # Declare the return variable.
983      my ($noTrace) = @_;      my @retVal = ();
984      # Get the CGI query object.      my $confession = longmess("");
985      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
986      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
987      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
988      # Create the variable hash.              push @retVal, $line;
989      my $varHash = { results => '' };          }
990      # Return the query object and variable hash.      }
991      return ($cgi, $varHash);      # Return the result.
992        return @retVal;
993  }  }
994    
995  =head3 ETracing  =head3 ETracing
# Line 790  Line 1023 
1023      # Get the parameter.      # Get the parameter.
1024      my ($parameter) = @_;      my ($parameter) = @_;
1025      # Check for CGI mode.      # Check for CGI mode.
1026      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
1027            $SavedCGI = $parameter;
1028        } else {
1029            $SavedCGI = undef;
1030        }
1031      # Default to no tracing except errors.      # Default to no tracing except errors.
1032      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
1033      # Check for emergency tracing.      # Check for emergency tracing.
# Line 823  Line 1060 
1060              # Set the trace parameter.              # Set the trace parameter.
1061              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1062          }          }
1063      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1064          # There's no emergency tracing, but we have a CGI object, so check          # There's no emergency tracing, but we have a CGI object, so check
1065          # for tracing from the form parameters.          # for tracing from the form parameters.
1066          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1067              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1068              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1069              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1070          }          }
1071      }      }
1072      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1073      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1074      # Check to see if we're a web script.      # Check to see if we're a web script.
1075      if (defined $cgi) {      if (defined $SavedCGI) {
1076          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1077          TraceParms($cgi);          TraceParms($SavedCGI);
1078          # Check for RAW mode. In raw mode, we print a fake header so that we see everything          # Check for RAW mode. In raw mode, we print a fake header so that we see everything
1079          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1080          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1029  Line 1266 
1266      my $retVal;      my $retVal;
1267      # Determine the parameter type.      # Determine the parameter type.
1268      if (! defined $parameter) {      if (! defined $parameter) {
1269          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1270          $retVal = $ENV{TRACING};          # get the effective login ID.
1271            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1272      } else {      } else {
1273          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1274          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1147  Line 1385 
1385      }      }
1386  }  }
1387    
   
 =head3 ScriptFinish (deprecated)  
   
     ScriptFinish($webData, $varHash);  
   
 Output a web page at the end of a script. Either the string to be output or the  
 name of a template file can be specified. If the second parameter is omitted,  
 it is assumed we have a string to be output; otherwise, it is assumed we have the  
 name of a template file. The template should have the variable C<DebugData>  
 specified in any form that invokes a standard script. If debugging mode is turned  
 on, a form field will be put in that allows the user to enter tracing data.  
 Trace messages will be placed immediately before the terminal C<BODY> tag in  
 the output, formatted as a list.  
   
 A typical standard script would loook like the following.  
   
     BEGIN {  
         # Print the HTML header.  
         print "CONTENT-TYPE: text/html\n\n";  
     }  
     use Tracer;  
     use CGI;  
     use FIG;  
     # ... more uses ...  
   
     my ($cgi, $varHash) = ScriptSetup();  
     eval {  
         # ... get data from $cgi, put it in $varHash ...  
     };  
     if ($@) {  
         Trace("Script Error: $@") if T(0);  
     }  
     ScriptFinish("Html/MyTemplate.html", $varHash);  
   
 The idea here is that even if the script fails, you'll see trace messages and  
 useful output.  
   
 =over 4  
   
 =item webData  
   
 A string containing either the full web page to be written to the output or the  
 name of a template file from which the page is to be constructed. If the name  
 of a template file is specified, then the second parameter must be present;  
 otherwise, it must be absent.  
   
 =item varHash (optional)  
   
 If specified, then a reference to a hash mapping variable names for a template  
 to their values. The template file will be read into memory, and variable markers  
 will be replaced by data in this hash reference.  
   
 =back  
   
 =cut  
   
 sub ScriptFinish {  
     # Get the parameters.  
     my ($webData, $varHash) = @_;  
     # Check for a template file situation.  
     my $outputString;  
     if (defined $varHash) {  
         # Here we have a template file. We need to determine the template type.  
         my $template;  
         if ($FIG_Config::template_url && $webData =~ /\.php$/) {  
             $template = "$FIG_Config::template_url/$webData";  
         } else {  
             $template = "<<$webData";  
         }  
         $outputString = PageBuilder::Build($template, $varHash, "Html");  
     } else {  
         # Here the user gave us a raw string.  
         $outputString = $webData;  
     }  
     # Check for trace messages.  
     if ($Destination ne "NONE" && $TraceLevel > 0) {  
         # We have trace messages, so we want to put them at the end of the body. This  
         # is either at the end of the whole string or at the beginning of the BODY  
         # end-tag.  
         my $pos = length $outputString;  
         if ($outputString =~ m#</body>#gi) {  
             $pos = (pos $outputString) - 7;  
         }  
         # If the trace messages were queued, we unroll them. Otherwise, we display the  
         # destination.  
         my $traceHtml;  
         if ($Destination eq "QUEUE") {  
             $traceHtml = QTrace('Html');  
         } elsif ($Destination =~ /^>>(.+)$/) {  
             # Here the tracing output it to a file. We code it as a hyperlink so the user  
             # can copy the file name into the clipboard easily.  
             my $actualDest = $1;  
             $traceHtml = "<p>Tracing output to $actualDest.</p>\n";  
         } else {  
             # Here we have one of the special destinations.  
             $traceHtml = "<P>Tracing output type is $Destination.</p>\n";  
         }  
         substr $outputString, $pos, 0, $traceHtml;  
     }  
     # Write the output string.  
     print $outputString;  
 }  
   
1388  =head2 Command-Line Utility Methods  =head2 Command-Line Utility Methods
1389    
1390  =head3 SendSMS  =head3 SendSMS
# Line 1454  Line 1589 
1589  Specifying a value of C<E> for the trace level causes emergency tracing to  Specifying a value of C<E> for the trace level causes emergency tracing to
1590  be used instead of custom tracing. If the user name is not specified,  be used instead of custom tracing. If the user name is not specified,
1591  the tracing key is taken from the C<Tracing> environment variable. If there  the tracing key is taken from the C<Tracing> environment variable. If there
1592  is no value for that variable, the tracing key will be computed from the PID.  is no value for that variable, the tracing key will be computed from the active
1593    login ID.
1594    
1595    Since the default situation in StandardSetup is to trace to the standard
1596    output, errors that occur in command-line scripts will not generate
1597    RSS events. To force the events, use the C<warn> option.
1598    
1599        TransactFeatures -background -warn register ../xacts IDs.tbl
1600    
1601  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1602  names will be traced at level 0 and the program will exit without processing.  names will be traced at level 0 and the program will exit without processing.
# Line 1534  Line 1676 
1676      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1677      # Get the default tracing key.      # Get the default tracing key.
1678      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1679        # Save the command line.
1680        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1681      # Add the tracing options.      # Add the tracing options.
1682      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1683          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
# Line 1542  Line 1686 
1686      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1687      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1688      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1689        $options->{warn} = [0, "send errors to RSS feed"];
1690      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1691      # contains the default values rather than the default value      # contains the default values rather than the default value
1692      # and the description. While we're at it, we'll memorize the      # and the description. While we're at it, we'll memorize the
# Line 1580  Line 1725 
1725          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1726              push @cats, "SQL";              push @cats, "SQL";
1727          }          }
1728            if ($retOptions->{warn}) {
1729                push @cats, "Feed";
1730            }
1731          # Add the default categories.          # Add the default categories.
1732          push @cats, "Tracer";          push @cats, "Tracer";
1733          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
# Line 2951  Line 3099 
3099      return $retVal;      return $retVal;
3100  }  }
3101    
   
3102  =head3 Strip  =head3 Strip
3103    
3104      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
# Line 3201  Line 3348 
3348      return ($inserted, $deleted);      return ($inserted, $deleted);
3349  }  }
3350    
3351  =head3 GenerateURL  =head3 Cmp
   
     my $queryUrl = Tracer::GenerateURL($page, %parameters);  
   
 Generate a GET-style URL for the specified page with the specified parameter  
 names and values. The values will be URL-escaped automatically. So, for  
 example  
   
     Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")  
3352    
3353  would return      my $cmp = Tracer::Cmp($a, $b);
3354    
3355      form.cgi?type=1;string=%22high%20pass%22%20or%20highway  This method performs a universal sort comparison. Each value coming in is
3356    separated into a leading text part and a trailing number part. The text
3357    part is string compared, and if both parts are equal, then the number
3358    parts are compared numerically. A stream of just numbers or a stream of
3359    just strings will sort correctly, and a mixed stream will sort with the
3360    numbers first. Strings with a label and a number will sort in the
3361    expected manner instead of lexically.
3362    
3363  =over 4  =over 4
3364    
3365  =item page  =item a
3366    
3367  Page URL.  First item to compare.
3368    
3369  =item parameters  =item b
3370    
3371  Hash mapping parameter names to parameter values.  Second item to compare.
3372    
3373  =item RETURN  =item RETURN
3374    
3375  Returns a GET-style URL that goes to the specified page and passes in the  Returns a negative number if the first item should sort first (is less), a positive
3376  specified parameters and values.  number if the first item should sort second (is greater), and a zero if the items are
3377    equal.
3378    
3379  =back  =back
3380    
3381  =cut  =cut
3382    
3383  sub GenerateURL {  sub Cmp {
3384      # Get the parameters.      # Get the parameters.
3385      my ($page, %parameters) = @_;      my ($a, $b) = @_;
3386      # Prime the return variable with the page URL.      # Declare the return value.
3387      my $retVal = $page;      my $retVal;
3388      # Loop through the parameters, creating parameter elements in a list.      # Check for nulls.
3389      my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;      if (! defined($a)) {
3390      # If the list is nonempty, tack it on.          $retVal = (! defined($b) ? 0 : -1);
3391      if (@parmList) {      } elsif (! defined($b)) {
3392          $retVal .= "?" . join(";", @parmList);          $retVal = 1;
3393      }      } else {
3394      # Return the result.          # Here we have two real values. Parse the two strings.
3395      return $retVal;          $a =~ /^(\D*)(\d*)$/;
3396            my $aParsed = [$1, $2];
3397            $b =~ /^(\D*)(\d*)$/;
3398            my $bParsed = [$1, $2];
3399            # Compare the string parts.
3400            $retVal = $aParsed->[0] cmp $bParsed->[0];
3401            if (! $retVal) {
3402                $retVal = $aParsed->[1] <=> $bParsed->[1];
3403            }
3404        }
3405        # Return the result.
3406        return $retVal;
3407    }
3408    
3409    =head3 ListEQ
3410    
3411        my $flag = Tracer::ListEQ(\@a, \@b);
3412    
3413    Return TRUE if the specified lists contain the same strings in the same
3414    order, else FALSE.
3415    
3416    =over 4
3417    
3418    =item a
3419    
3420    Reference to the first list.
3421    
3422    =item b
3423    
3424    Reference to the second list.
3425    
3426    =item RETURN
3427    
3428    Returns TRUE if the two parameters are identical string lists, else FALSE.
3429    
3430    =back
3431    
3432    =cut
3433    
3434    sub ListEQ {
3435        # Get the parameters.
3436        my ($a, $b) = @_;
3437        # Declare the return variable. Start by checking the lengths.
3438        my $n = scalar(@$a);
3439        my $retVal = ($n == scalar(@$b));
3440        # Now compare the list elements.
3441        for (my $i = 0; $retVal && $i < $n; $i++) {
3442            $retVal = ($a->[$i] eq $b->[$i]);
3443        }
3444        # Return the result.
3445        return $retVal;
3446    }
3447    
3448    =head2 CGI Script Utilities
3449    
3450    =head3 ScriptSetup (deprecated)
3451    
3452        my ($cgi, $varHash) = ScriptSetup($noTrace);
3453    
3454    Perform standard tracing and debugging setup for scripts. The value returned is
3455    the CGI object followed by a pre-built variable hash. At the end of the script,
3456    the client should call L</ScriptFinish> to output the web page.
3457    
3458    This method calls L</ETracing> to configure tracing, which allows the tracing
3459    to be configured via the emergency tracing form on the debugging control panel.
3460    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3461    method, which includes every program that uses this method or L</StandardSetup>.
3462    
3463    =over 4
3464    
3465    =item noTrace (optional)
3466    
3467    If specified, tracing will be suppressed. This is useful if the script wants to set up
3468    tracing manually.
3469    
3470    =item RETURN
3471    
3472    Returns a two-element list consisting of a CGI query object and a variable hash for
3473    the output page.
3474    
3475    =back
3476    
3477    =cut
3478    
3479    sub ScriptSetup {
3480        # Get the parameters.
3481        my ($noTrace) = @_;
3482        # Get the CGI query object.
3483        my $cgi = CGI->new();
3484        # Set up tracing if it's not suppressed.
3485        ETracing($cgi) unless $noTrace;
3486        # Create the variable hash.
3487        my $varHash = { results => '' };
3488        # Return the query object and variable hash.
3489        return ($cgi, $varHash);
3490    }
3491    
3492    =head3 ScriptFinish (deprecated)
3493    
3494        ScriptFinish($webData, $varHash);
3495    
3496    Output a web page at the end of a script. Either the string to be output or the
3497    name of a template file can be specified. If the second parameter is omitted,
3498    it is assumed we have a string to be output; otherwise, it is assumed we have the
3499    name of a template file. The template should have the variable C<DebugData>
3500    specified in any form that invokes a standard script. If debugging mode is turned
3501    on, a form field will be put in that allows the user to enter tracing data.
3502    Trace messages will be placed immediately before the terminal C<BODY> tag in
3503    the output, formatted as a list.
3504    
3505    A typical standard script would loook like the following.
3506    
3507        BEGIN {
3508            # Print the HTML header.
3509            print "CONTENT-TYPE: text/html\n\n";
3510        }
3511        use Tracer;
3512        use CGI;
3513        use FIG;
3514        # ... more uses ...
3515    
3516        my ($cgi, $varHash) = ScriptSetup();
3517        eval {
3518            # ... get data from $cgi, put it in $varHash ...
3519        };
3520        if ($@) {
3521            Trace("Script Error: $@") if T(0);
3522        }
3523        ScriptFinish("Html/MyTemplate.html", $varHash);
3524    
3525    The idea here is that even if the script fails, you'll see trace messages and
3526    useful output.
3527    
3528    =over 4
3529    
3530    =item webData
3531    
3532    A string containing either the full web page to be written to the output or the
3533    name of a template file from which the page is to be constructed. If the name
3534    of a template file is specified, then the second parameter must be present;
3535    otherwise, it must be absent.
3536    
3537    =item varHash (optional)
3538    
3539    If specified, then a reference to a hash mapping variable names for a template
3540    to their values. The template file will be read into memory, and variable markers
3541    will be replaced by data in this hash reference.
3542    
3543    =back
3544    
3545    =cut
3546    
3547    sub ScriptFinish {
3548        # Get the parameters.
3549        my ($webData, $varHash) = @_;
3550        # Check for a template file situation.
3551        my $outputString;
3552        if (defined $varHash) {
3553            # Here we have a template file. We need to determine the template type.
3554            my $template;
3555            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3556                $template = "$FIG_Config::template_url/$webData";
3557            } else {
3558                $template = "<<$webData";
3559            }
3560            $outputString = PageBuilder::Build($template, $varHash, "Html");
3561        } else {
3562            # Here the user gave us a raw string.
3563            $outputString = $webData;
3564        }
3565        # Check for trace messages.
3566        if ($Destination ne "NONE" && $TraceLevel > 0) {
3567            # We have trace messages, so we want to put them at the end of the body. This
3568            # is either at the end of the whole string or at the beginning of the BODY
3569            # end-tag.
3570            my $pos = length $outputString;
3571            if ($outputString =~ m#</body>#gi) {
3572                $pos = (pos $outputString) - 7;
3573            }
3574            # If the trace messages were queued, we unroll them. Otherwise, we display the
3575            # destination.
3576            my $traceHtml;
3577            if ($Destination eq "QUEUE") {
3578                $traceHtml = QTrace('Html');
3579            } elsif ($Destination =~ /^>>(.+)$/) {
3580                # Here the tracing output it to a file. We code it as a hyperlink so the user
3581                # can copy the file name into the clipboard easily.
3582                my $actualDest = $1;
3583                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3584            } else {
3585                # Here we have one of the special destinations.
3586                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3587            }
3588            substr $outputString, $pos, 0, $traceHtml;
3589        }
3590        # Write the output string.
3591        print $outputString;
3592    }
3593    
3594    =head3 GenerateURL
3595    
3596        my $queryUrl = Tracer::GenerateURL($page, %parameters);
3597    
3598    Generate a GET-style URL for the specified page with the specified parameter
3599    names and values. The values will be URL-escaped automatically. So, for
3600    example
3601    
3602        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
3603    
3604    would return
3605    
3606        form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3607    
3608    =over 4
3609    
3610    =item page
3611    
3612    Page URL.
3613    
3614    =item parameters
3615    
3616    Hash mapping parameter names to parameter values.
3617    
3618    =item RETURN
3619    
3620    Returns a GET-style URL that goes to the specified page and passes in the
3621    specified parameters and values.
3622    
3623    =back
3624    
3625    =cut
3626    
3627    sub GenerateURL {
3628        # Get the parameters.
3629        my ($page, %parameters) = @_;
3630        # Prime the return variable with the page URL.
3631        my $retVal = $page;
3632        # Loop through the parameters, creating parameter elements in a list.
3633        my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
3634        # If the list is nonempty, tack it on.
3635        if (@parmList) {
3636            $retVal .= "?" . join(";", @parmList);
3637        }
3638        # Return the result.
3639        return $retVal;
3640  }  }
3641    
3642  =head3 ApplyURL  =head3 ApplyURL
# Line 3335  Line 3725 
3725      return $retVal;      return $retVal;
3726  }  }
3727    
 =head3 Cmp  
   
     my $cmp = Tracer::Cmp($a, $b);  
   
 This method performs a universal sort comparison. Each value coming in is  
 separated into a leading text part and a trailing number part. The text  
 part is string compared, and if both parts are equal, then the number  
 parts are compared numerically. A stream of just numbers or a stream of  
 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.  
   
 =over 4  
   
 =item a  
   
 First item to compare.  
   
 =item b  
   
 Second item to compare.  
   
 =item RETURN  
   
 Returns a negative number if the first item should sort first (is less), a positive  
 number if the first item should sort second (is greater), and a zero if the items are  
 equal.  
   
 =back  
   
 =cut  
   
 sub Cmp {  
     # Get the parameters.  
     my ($a, $b) = @_;  
     # Declare the return value.  
     my $retVal;  
     # Check for nulls.  
     if (! defined($a)) {  
         $retVal = (! defined($b) ? 0 : -1);  
     } elsif (! defined($b)) {  
         $retVal = 1;  
     } else {  
         # Here we have two real values. Parse the two strings.  
         $a =~ /^(\D*)(\d*)$/;  
         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];  
         }  
     }  
     # Return the result.  
     return $retVal;  
 }  
   
   
3728  =head3 TrackingCode  =head3 TrackingCode
3729    
3730      my $html = Tracer::TrackingCode();      my $html = Tracer::TrackingCode();
# Line 3424  Line 3755 
3755      return $retVal;      return $retVal;
3756  }  }
3757    
3758    =head3 Clean
3759    
3760        my $cleaned = Tracer::Clean($string);
3761    
3762    Clean up a string for HTML display. This not only converts special
3763    characters to HTML entity names, it also removes control characters.
3764    
3765    =over 4
3766    
3767    =item string
3768    
3769    String to convert.
3770    
3771    =item RETURN
3772    
3773    Returns the input string with anything that might disrupt an HTML literal removed. An
3774    undefined value will be converted to an empty string.
3775    
3776    =back
3777    
3778    =cut
3779    
3780    sub Clean {
3781        # Get the parameters.
3782        my ($string) = @_;
3783        # Declare the return variable.
3784        my $retVal = "";
3785        # Only proceed if the value exists.
3786        if (defined $string) {
3787            # Get the string.
3788            $retVal = $string;
3789            # Clean the control characters.
3790            $retVal =~ tr/\x00-\x1F/?/;
3791            # Escape the rest.
3792            $retVal = CGI::escapeHTML($retVal);
3793        }
3794        # Return the result.
3795        return $retVal;
3796    }
3797    
3798    
3799    
3800    
3801  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3