[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.105, Wed May 14 09:09:25 2008 UTC
# Line 20  Line 20 
20    
21      require Exporter;      require Exporter;
22      @ISA = ('Exporter');      @ISA = ('Exporter');
23      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing 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    
42    
43  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
44    
# Line 204  Line 207 
207  my $LastLevel = 0;          # level of the last test call  my $LastLevel = 0;          # level of the last test call
208  my $SetupCount = 0;         # number of times TSetup called  my $SetupCount = 0;         # number of times TSetup called
209  my $AllTrace = 0;           # TRUE if we are tracing all categories.  my $AllTrace = 0;           # TRUE if we are tracing all categories.
210    my $SavedCGI;               # CGI object passed to ETracing
211    my $CommandLine;            # Command line passed to StandardSetup
212    umask 2;                    # Fix the damn umask so everything is group-writable.
213    
214  =head2 Tracing Methods  =head2 Tracing Methods
215    
# Line 553  Line 559 
559          $LastLevel = $traceLevel;          $LastLevel = $traceLevel;
560          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
561          $category = lc $category;          $category = lc $category;
562          # Use the category and tracelevel to compute the result.          # Validate the trace level.
563          if (ref $traceLevel) {          if (ref $traceLevel) {
564              Confess("Bad trace level.");              Confess("Bad trace level.");
565          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
566              Confess("Bad trace config.");              Confess("Bad trace config.");
567          }          }
568          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
569            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
570      }      }
571      # Return the computed result.      # Return the computed result.
572      return $retVal;      return $retVal;
# Line 654  Line 661 
661      croak(">>> $message");      croak(">>> $message");
662  }  }
663    
664    =head3 Warn
665    
666        Warn($message);
667    
668    This method traces an important message. If an RSS feed is configured
669    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
670    then the message will be echoed to the feed. In general, a tracing
671    destination of C<WARN> indicates that the caller is running as a web
672    service in a production environment; however, this is not a requirement.
673    
674    To force warnings into the RSS feed even when the tracing destination
675    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
676    configured automatically when L</StandardSetup> is used.
677    
678    The L</Cluck> method calls this one for its final message. Since
679    L</Confess> calls L</Cluck>, this means that any error which is caught
680    and confessed will put something in the feed. This insures that someone
681    will be alerted relatively quickly when a failure occurs.
682    
683    =over 4
684    
685    =item message
686    
687    Message to be traced.
688    
689    =back
690    
691    =cut
692    
693    sub Warn {
694        # Get the parameters.
695        my ($message) = @_;
696        # Trace the message.
697        Trace($message);
698        # Check for feed forcing.
699        my $forceFeed = exists $Categories{feed};
700        # An error here would be disastrous. Note, however, that we aren't too worried
701        # about losing events. The error log is always available for the occasions where
702        # we mess up. Note that if debug mode is specified, we do this stuff even in a
703        # test environment.
704        eval {
705            # Do we need to put this in the RSS feed?
706            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
707                # Yes. We now need to compute the date, the link, and the title.
708                # First, the date, in a very specific format.
709                my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
710                    (tz_local_offset() / 30);
711                # Environment data goes in here. We start with the date.
712                my $environment = "$date.  ";
713                # If we need to recap the message (because it's too long to be a title), we'll
714                # put it in here.
715                my $recap;
716                # Copy the message and remove excess space.
717                my $title = $message;
718                $title =~ s/\s+/ /gs;
719                # If it's too long, we have to split it up.
720                if (length $title > 60) {
721                    # Put the full message in the environment string.
722                    $recap = $title;
723                    # Excerpt it as the title.
724                    $title = substr($title, 0, 50) . "...";
725                }
726                # If we have a CGI object, then this is a web error. Otherwise, it's
727                # command-line.
728                if (defined $SavedCGI) {
729                    # We're in a web service. The environment is the user's IP, and the link
730                    # is the URL that got us here.
731                    my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
732                    $environment .= "Event Reported at IP address $key.";
733                    my $url = $SavedCGI->url(-full => 1, -query => 1);
734                    # We need the user agent string and (if available) the referrer.
735                    # The referrer will be the link.
736                    $environment .= "User Agent $ENV{HTTP_USER_AGENT}";
737                    if ($ENV{HTTP_REFERER}) {
738                        my $link = $ENV{HTTP_REFERER};
739                        $environment .= " referred from <a href=\"$link\">$link</a>.";
740                    } else {
741                        $environment .= " referrer unknown.";
742                    }
743                    # Close off the sentence with the original link.
744                    $environment .= " URL of error is <a href=\"$url\">$url</a>.";
745                } else {
746                    # No CGI object, so we're a command-line tool. Use the tracing
747                    # key and the PID as the user identifier, and add the command.
748                    my $key = EmergencyKey();
749                    $environment .= "Event Reported by $key Process $$.";
750                    if ($CommandLine) {
751                        # We're in a StandardSetup script, so we have the real command line.
752                        $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
753                    } elsif ($ENV{_}) {
754                        # We're in a BASH script, so the command has been stored in the _ variable.
755                        $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
756                    }
757                }
758                # Build a GUID. We use the current time, the title, and the process ID,
759                # then digest the result.
760                my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
761                # Finally, the description. This is a stack trace plus various environmental stuff.
762                my $stackTrace = "";
763                my @trace = LongMess();
764                # Only proceed if we got something back.
765                if (scalar(@trace) > 0) {
766                    $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
767                    $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
768                }
769                # We got the stack trace. Now it's time to put it all together.
770                # We have a goofy thing here in that we need to HTML-escape some sections of the description
771                # twice. They will be escaped once here, and then once when written by XML::Simple. They are
772                # unescaped once when processed by the RSS reader, and stuff in the description is treated as
773                # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
774                # our <br>s and <pre>s are used to format the description.
775                $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
776                my $description = "$recap$environment  $stackTrace";
777                # Okay, we have all the pieces. Create a hash of the new event.
778                my $newItem = { title => $title,
779                                description => $description,
780                                category => $LastCategory,
781                                pubDate => $date,
782                                guid => $guid,
783                               };
784                # We need XML capability for this.
785                require XML::Simple;
786                # The RSS document goes in here.
787                my $rss;
788                # Get the name of the RSS file. It's in the FIG temporary directory.
789                my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
790                # Does it exist?
791                if (-s $fileName) {
792                    # Slurp it in.
793                    $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
794                } else {
795                    my $size = -s $fileName;
796                    # Create an empty channel.
797                    $rss = {
798                        channel => {
799                            title => 'NMPDR Warning Feed',
800                            link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
801                            description => "Important messages regarding the status of the NMPDR.",
802                            generator => "NMPDR Trace Facility",
803                            docs => "http://blogs.law.harvard.edu/tech/rss",
804                            item => []
805                        },
806                    };
807                }
808                # Get the channel object.
809                my $channel = $rss->{channel};
810                # Update the last-build date.
811                $channel->{lastBuildDate} = $date;
812                # Get the item array.
813                my $items = $channel->{item};
814                # Insure it has only 100 entries.
815                while (scalar @{$items} > 100) {
816                    pop @{$items};
817                }
818                # Add our new item at the front.
819                unshift @{$items}, $newItem;
820                # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
821                # the requirements for those.
822                my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => undef, XmlDecl => '');
823                # Here we put in the root and declaration. The problem is that the root has to have the version attribute
824                # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
825                $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
826                # We don't use Open here because we can't afford an error.
827                if (open XMLOUT, ">$fileName") {
828                    print XMLOUT $xml;
829                    close XMLOUT;
830                }
831            }
832        };
833        if ($@) {
834            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
835            # (which is a good thing).
836            my $error = $@;
837            Trace("Feed Error: $error") if T(Feed => 0);
838        }
839    }
840    
841  =head3 Assert  =head3 Assert
842    
843      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 888 
888      my ($message) = @_;      my ($message) = @_;
889      # Trace what's happening.      # Trace what's happening.
890      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
891      my $confession = longmess($message);      # Get the stack trace.
892      # Convert the confession to a series of trace messages.      my @trace = LongMess();
893      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
894          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
895          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
896              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
897              # Trace the line.              # Trace the line.
898              Trace($line);              Trace($line);
899          }          }
900      }      # Issue a warning. This displays the event message and inserts it into the RSS error feed.
901        Warn($message);
902  }  }
903    
904  =head3 ScriptSetup (deprecated)  =head3 LongMess
905    
906      my ($cgi, $varHash) = ScriptSetup($noTrace);      my @lines = Tracer::LongMess();
907    
908  Perform standard tracing and debugging setup for scripts. The value returned is  Return a stack trace with all tracing methods removed. The return will be in the form of a list
909  the CGI object followed by a pre-built variable hash. At the end of the script,  of message strings.
 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  
   
 Returns a two-element list consisting of a CGI query object and a variable hash for  
 the output page.  
   
 =back  
910    
911  =cut  =cut
912    
913  sub ScriptSetup {  sub LongMess {
914      # Get the parameters.      # Declare the return variable.
915      my ($noTrace) = @_;      my @retVal = ();
916      # Get the CGI query object.      my $confession = longmess("");
917      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
918      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
919      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
920      # Create the variable hash.              push @retVal, $line;
921      my $varHash = { results => '' };          }
922      # Return the query object and variable hash.      }
923      return ($cgi, $varHash);      # Return the result.
924        return @retVal;
925  }  }
926    
927  =head3 ETracing  =head3 ETracing
# Line 790  Line 955 
955      # Get the parameter.      # Get the parameter.
956      my ($parameter) = @_;      my ($parameter) = @_;
957      # Check for CGI mode.      # Check for CGI mode.
958      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
959            $SavedCGI = $parameter;
960        } else {
961            $SavedCGI = undef;
962        }
963      # Default to no tracing except errors.      # Default to no tracing except errors.
964      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
965      # Check for emergency tracing.      # Check for emergency tracing.
# Line 823  Line 992 
992              # Set the trace parameter.              # Set the trace parameter.
993              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
994          }          }
995      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
996          # There's no emergency tracing, but we have a CGI object, so check          # There's no emergency tracing, but we have a CGI object, so check
997          # for tracing from the form parameters.          # for tracing from the form parameters.
998          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
999              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1000              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1001              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1002          }          }
1003      }      }
1004      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1005      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1006      # Check to see if we're a web script.      # Check to see if we're a web script.
1007      if (defined $cgi) {      if (defined $SavedCGI) {
1008          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1009          TraceParms($cgi);          TraceParms($SavedCGI);
1010          # Check for RAW mode. In raw mode, we print a fake header so that we see everything          # Check for RAW mode. In raw mode, we print a fake header so that we see everything
1011          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1012          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1029  Line 1198 
1198      my $retVal;      my $retVal;
1199      # Determine the parameter type.      # Determine the parameter type.
1200      if (! defined $parameter) {      if (! defined $parameter) {
1201          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1202          $retVal = $ENV{TRACING};          # get the effective login ID.
1203            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1204      } else {      } else {
1205          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1206          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1147  Line 1317 
1317      }      }
1318  }  }
1319    
   
 =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;  
 }  
   
1320  =head2 Command-Line Utility Methods  =head2 Command-Line Utility Methods
1321    
1322  =head3 SendSMS  =head3 SendSMS
# Line 1454  Line 1521 
1521  Specifying a value of C<E> for the trace level causes emergency tracing to  Specifying a value of C<E> for the trace level causes emergency tracing to
1522  be used instead of custom tracing. If the user name is not specified,  be used instead of custom tracing. If the user name is not specified,
1523  the tracing key is taken from the C<Tracing> environment variable. If there  the tracing key is taken from the C<Tracing> environment variable. If there
1524  is no value for that variable, the tracing key will be computed from the PID.  is no value for that variable, the tracing key will be computed from the active
1525    login ID.
1526    
1527    Since the default situation in StandardSetup is to trace to the standard
1528    output, errors that occur in command-line scripts will not generate
1529    RSS events. To force the events, use the C<warn> option.
1530    
1531        TransactFeatures -background -warn register ../xacts IDs.tbl
1532    
1533  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1534  names will be traced at level 0 and the program will exit without processing.  names will be traced at level 0 and the program will exit without processing.
# Line 1534  Line 1608 
1608      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1609      # Get the default tracing key.      # Get the default tracing key.
1610      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1611        # Save the command line.
1612        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1613      # Add the tracing options.      # Add the tracing options.
1614      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1615          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
# Line 1542  Line 1618 
1618      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1619      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1620      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1621        $options->{warn} = [0, "send errors to RSS feed"];
1622      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1623      # contains the default values rather than the default value      # contains the default values rather than the default value
1624      # and the description. While we're at it, we'll memorize the      # and the description. While we're at it, we'll memorize the
# Line 1580  Line 1657 
1657          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1658              push @cats, "SQL";              push @cats, "SQL";
1659          }          }
1660            if ($retOptions->{warn}) {
1661                push @cats, "Feed";
1662            }
1663          # Add the default categories.          # Add the default categories.
1664          push @cats, "Tracer";          push @cats, "Tracer";
1665          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
# Line 2951  Line 3031 
3031      return $retVal;      return $retVal;
3032  }  }
3033    
   
3034  =head3 Strip  =head3 Strip
3035    
3036      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
# Line 3201  Line 3280 
3280      return ($inserted, $deleted);      return ($inserted, $deleted);
3281  }  }
3282    
3283    =head3 Cmp
3284    
3285        my $cmp = Tracer::Cmp($a, $b);
3286    
3287    This method performs a universal sort comparison. Each value coming in is
3288    separated into a leading text part and a trailing number part. The text
3289    part is string compared, and if both parts are equal, then the number
3290    parts are compared numerically. A stream of just numbers or a stream of
3291    just strings will sort correctly, and a mixed stream will sort with the
3292    numbers first. Strings with a label and a number will sort in the
3293    expected manner instead of lexically.
3294    
3295    =over 4
3296    
3297    =item a
3298    
3299    First item to compare.
3300    
3301    =item b
3302    
3303    Second item to compare.
3304    
3305    =item RETURN
3306    
3307    Returns a negative number if the first item should sort first (is less), a positive
3308    number if the first item should sort second (is greater), and a zero if the items are
3309    equal.
3310    
3311    =back
3312    
3313    =cut
3314    
3315    sub Cmp {
3316        # Get the parameters.
3317        my ($a, $b) = @_;
3318        # Declare the return value.
3319        my $retVal;
3320        # Check for nulls.
3321        if (! defined($a)) {
3322            $retVal = (! defined($b) ? 0 : -1);
3323        } elsif (! defined($b)) {
3324            $retVal = 1;
3325        } else {
3326            # Here we have two real values. Parse the two strings.
3327            $a =~ /^(\D*)(\d*)$/;
3328            my $aParsed = [$1, $2];
3329            $b =~ /^(\D*)(\d*)$/;
3330            my $bParsed = [$1, $2];
3331            # Compare the string parts.
3332            $retVal = $aParsed->[0] cmp $bParsed->[0];
3333            if (! $retVal) {
3334                $retVal = $aParsed->[1] <=> $bParsed->[1];
3335            }
3336        }
3337        # Return the result.
3338        return $retVal;
3339    }
3340    
3341    =head2 CGI Script Utilities
3342    
3343    =head3 ScriptSetup (deprecated)
3344    
3345        my ($cgi, $varHash) = ScriptSetup($noTrace);
3346    
3347    Perform standard tracing and debugging setup for scripts. The value returned is
3348    the CGI object followed by a pre-built variable hash. At the end of the script,
3349    the client should call L</ScriptFinish> to output the web page.
3350    
3351    This method calls L</ETracing> to configure tracing, which allows the tracing
3352    to be configured via the emergency tracing form on the debugging control panel.
3353    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3354    method, which includes every program that uses this method or L</StandardSetup>.
3355    
3356    =over 4
3357    
3358    =item noTrace (optional)
3359    
3360    If specified, tracing will be suppressed. This is useful if the script wants to set up
3361    tracing manually.
3362    
3363    =item RETURN
3364    
3365    Returns a two-element list consisting of a CGI query object and a variable hash for
3366    the output page.
3367    
3368    =back
3369    
3370    =cut
3371    
3372    sub ScriptSetup {
3373        # Get the parameters.
3374        my ($noTrace) = @_;
3375        # Get the CGI query object.
3376        my $cgi = CGI->new();
3377        # Set up tracing if it's not suppressed.
3378        ETracing($cgi) unless $noTrace;
3379        # Create the variable hash.
3380        my $varHash = { results => '' };
3381        # Return the query object and variable hash.
3382        return ($cgi, $varHash);
3383    }
3384    
3385    =head3 ScriptFinish (deprecated)
3386    
3387        ScriptFinish($webData, $varHash);
3388    
3389    Output a web page at the end of a script. Either the string to be output or the
3390    name of a template file can be specified. If the second parameter is omitted,
3391    it is assumed we have a string to be output; otherwise, it is assumed we have the
3392    name of a template file. The template should have the variable C<DebugData>
3393    specified in any form that invokes a standard script. If debugging mode is turned
3394    on, a form field will be put in that allows the user to enter tracing data.
3395    Trace messages will be placed immediately before the terminal C<BODY> tag in
3396    the output, formatted as a list.
3397    
3398    A typical standard script would loook like the following.
3399    
3400        BEGIN {
3401            # Print the HTML header.
3402            print "CONTENT-TYPE: text/html\n\n";
3403        }
3404        use Tracer;
3405        use CGI;
3406        use FIG;
3407        # ... more uses ...
3408    
3409        my ($cgi, $varHash) = ScriptSetup();
3410        eval {
3411            # ... get data from $cgi, put it in $varHash ...
3412        };
3413        if ($@) {
3414            Trace("Script Error: $@") if T(0);
3415        }
3416        ScriptFinish("Html/MyTemplate.html", $varHash);
3417    
3418    The idea here is that even if the script fails, you'll see trace messages and
3419    useful output.
3420    
3421    =over 4
3422    
3423    =item webData
3424    
3425    A string containing either the full web page to be written to the output or the
3426    name of a template file from which the page is to be constructed. If the name
3427    of a template file is specified, then the second parameter must be present;
3428    otherwise, it must be absent.
3429    
3430    =item varHash (optional)
3431    
3432    If specified, then a reference to a hash mapping variable names for a template
3433    to their values. The template file will be read into memory, and variable markers
3434    will be replaced by data in this hash reference.
3435    
3436    =back
3437    
3438    =cut
3439    
3440    sub ScriptFinish {
3441        # Get the parameters.
3442        my ($webData, $varHash) = @_;
3443        # Check for a template file situation.
3444        my $outputString;
3445        if (defined $varHash) {
3446            # Here we have a template file. We need to determine the template type.
3447            my $template;
3448            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3449                $template = "$FIG_Config::template_url/$webData";
3450            } else {
3451                $template = "<<$webData";
3452            }
3453            $outputString = PageBuilder::Build($template, $varHash, "Html");
3454        } else {
3455            # Here the user gave us a raw string.
3456            $outputString = $webData;
3457        }
3458        # Check for trace messages.
3459        if ($Destination ne "NONE" && $TraceLevel > 0) {
3460            # We have trace messages, so we want to put them at the end of the body. This
3461            # is either at the end of the whole string or at the beginning of the BODY
3462            # end-tag.
3463            my $pos = length $outputString;
3464            if ($outputString =~ m#</body>#gi) {
3465                $pos = (pos $outputString) - 7;
3466            }
3467            # If the trace messages were queued, we unroll them. Otherwise, we display the
3468            # destination.
3469            my $traceHtml;
3470            if ($Destination eq "QUEUE") {
3471                $traceHtml = QTrace('Html');
3472            } elsif ($Destination =~ /^>>(.+)$/) {
3473                # Here the tracing output it to a file. We code it as a hyperlink so the user
3474                # can copy the file name into the clipboard easily.
3475                my $actualDest = $1;
3476                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3477            } else {
3478                # Here we have one of the special destinations.
3479                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3480            }
3481            substr $outputString, $pos, 0, $traceHtml;
3482        }
3483        # Write the output string.
3484        print $outputString;
3485    }
3486    
3487  =head3 GenerateURL  =head3 GenerateURL
3488    
3489      my $queryUrl = Tracer::GenerateURL($page, %parameters);      my $queryUrl = Tracer::GenerateURL($page, %parameters);
# Line 3335  Line 3618 
3618      return $retVal;      return $retVal;
3619  }  }
3620    
 =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;  
 }  
   
   
3621  =head3 TrackingCode  =head3 TrackingCode
3622    
3623      my $html = Tracer::TrackingCode();      my $html = Tracer::TrackingCode();
# Line 3424  Line 3648 
3648      return $retVal;      return $retVal;
3649  }  }
3650    
3651    =head3 Clean
3652    
3653        my $cleaned = Tracer::Clean($string);
3654    
3655    Clean up a string for HTML display. This not only converts special
3656    characters to HTML entity names, it also removes control characters.
3657    
3658    =over 4
3659    
3660    =item string
3661    
3662    String to convert.
3663    
3664    =item RETURN
3665    
3666    Returns the input string with anything that might disrupt an HTML literal removed. An
3667    undefined value will be converted to an empty string.
3668    
3669    =back
3670    
3671    =cut
3672    
3673    sub Clean {
3674        # Get the parameters.
3675        my ($string) = @_;
3676        # Declare the return variable.
3677        my $retVal = "";
3678        # Only proceed if the value exists.
3679        if (defined $string) {
3680            # Get the string.
3681            $retVal = $string;
3682            # Clean the control characters.
3683            $retVal =~ tr/\x00-\x1F/?/;
3684            # Escape the rest.
3685            $retVal = CGI::escapeHTML($retVal);
3686        }
3687        # Return the result.
3688        return $retVal;
3689    }
3690    
3691    
3692    
3693    
3694  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3