[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.115, Mon Jan 19 20:50:17 2009 UTC
# Line 18  Line 18 
18    
19  package Tracer;  package Tracer;
20    
     require Exporter;  
     @ISA = ('Exporter');  
     @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency);  
     @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);  
21      use strict;      use strict;
22        use base qw(Exporter);
23        use vars qw(@EXPORT @EXPORT_OK);
24        @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency Warn TraceDump IDHASH);
25        @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);
26      use Carp qw(longmess croak carp);      use Carp qw(longmess croak carp);
27      use CGI;      use CGI;
28      use Cwd;      use Cwd;
# Line 36  Line 36 
36      use Time::HiRes 'gettimeofday';      use Time::HiRes 'gettimeofday';
37      use URI::Escape;      use URI::Escape;
38      use Time::Local;      use Time::Local;
39        use POSIX qw(strftime);
40        use Time::Zone;
41        use Fcntl qw(:DEFAULT :flock);
42        use Data::Dumper;
43    
44    
45  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
46    
# Line 204  Line 209 
209  my $LastLevel = 0;          # level of the last test call  my $LastLevel = 0;          # level of the last test call
210  my $SetupCount = 0;         # number of times TSetup called  my $SetupCount = 0;         # number of times TSetup called
211  my $AllTrace = 0;           # TRUE if we are tracing all categories.  my $AllTrace = 0;           # TRUE if we are tracing all categories.
212    my $SavedCGI;               # CGI object passed to ETracing
213    my $CommandLine;            # Command line passed to StandardSetup
214    umask 2;                    # Fix the damn umask so everything is group-writable.
215    
216  =head2 Tracing Methods  =head2 Tracing Methods
217    
# Line 486  Line 494 
494      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
495          # Write the trace message to an output file.          # Write the trace message to an output file.
496          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
497            # Lock the file.
498            flock TRACING, LOCK_EX;
499          print TRACING "$formatted\n";          print TRACING "$formatted\n";
500          close TRACING;          close TRACING;
501          # 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 495  Line 505 
505      }      }
506  }  }
507    
508    =head3 TraceDump
509    
510        TraceDump($title, $object);
511    
512    Dump an object to the trace log. This method simply calls the C<Dumper>
513    function, but routes the output to the trace log instead of returning it
514    as a string. The output is arranged so that it comes out monospaced when
515    it appears in an HTML trace dump.
516    
517    =over 4
518    
519    =item title
520    
521    Title to give to the object being dumped.
522    
523    =item object
524    
525    Reference to a list, hash, or object to dump.
526    
527    =back
528    
529    =cut
530    
531    sub TraceDump {
532        # Get the parameters.
533        my ($title, $object) = @_;
534        # Trace the object.
535        Trace("Object dump for $title:\n" . Dumper($object));
536    }
537    
538  =head3 T  =head3 T
539    
540      my $switch = T($category, $traceLevel);      my $switch = T($category, $traceLevel);
# Line 553  Line 593 
593          $LastLevel = $traceLevel;          $LastLevel = $traceLevel;
594          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
595          $category = lc $category;          $category = lc $category;
596          # Use the category and tracelevel to compute the result.          # Validate the trace level.
597          if (ref $traceLevel) {          if (ref $traceLevel) {
598              Confess("Bad trace level.");              Confess("Bad trace level.");
599          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
600              Confess("Bad trace config.");              Confess("Bad trace config.");
601          }          }
602          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
603            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
604      }      }
605      # Return the computed result.      # Return the computed result.
606      return $retVal;      return $retVal;
# Line 636  Line 677 
677      # Set up the category and level.      # Set up the category and level.
678      $LastCategory = "(confess)";      $LastCategory = "(confess)";
679      $LastLevel = 0;      $LastLevel = 0;
     if (! defined($FIG_Config::no_tool_hdr)) {  
         # Here we have a tool header. Display its length so that the user can adjust the line numbers.  
         my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";  
         # Only proceed if the tool header file is actually present.  
         if (-f $toolHeaderFile) {  
             my $fh;  
             if (open $fh, "<$toolHeaderFile") {  
                 my @lines = <$fh>;  
                 Trace("Tool header has " . scalar(@lines) . " lines.");  
             }  
         }  
     }  
680      # Trace the call stack.      # Trace the call stack.
681      Cluck($message);      Cluck($message);
682      # Abort the program.      # Abort the program.
683      croak(">>> $message");      croak(">>> $message");
684  }  }
685    
686    =head3 SaveCGI
687    
688        Tracer::SaveCGI($cgi);
689    
690    This method saves the CGI object but does not activate emergency tracing.
691    It is used to allow L</Warn> to work in situations where emergency
692    tracing is contra-indicated (e.g. the wiki).
693    
694    =over 4
695    
696    =item cgi
697    
698    Active CGI query object.
699    
700    =back
701    
702    =cut
703    
704    sub SaveCGI {
705        $SavedCGI = $_[0];
706    }
707    
708    =head3 Warn
709    
710        Warn($message, @options);
711    
712    This method traces an important message. If an RSS feed is configured
713    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
714    then the message will be echoed to the feed. In general, a tracing
715    destination of C<WARN> indicates that the caller is running as a web
716    service in a production environment; however, this is not a requirement.
717    
718    To force warnings into the RSS feed even when the tracing destination
719    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
720    configured automatically when L</StandardSetup> is used.
721    
722    The L</Cluck> method calls this one for its final message. Since
723    L</Confess> calls L</Cluck>, this means that any error which is caught
724    and confessed will put something in the feed. This insures that someone
725    will be alerted relatively quickly when a failure occurs.
726    
727    =over 4
728    
729    =item message
730    
731    Message to be traced.
732    
733    =item options
734    
735    A list containing zero or more options.
736    
737    =back
738    
739    The permissible options are as follows.
740    
741    =over 4
742    
743    =item noStack
744    
745    If specified, then the stack trace is not included in the output.
746    
747    =back
748    
749    =cut
750    
751    sub Warn {
752        # Get the parameters.
753        my $message = shift @_;
754        my %options = map { $_ => 1 } @_;
755        # Save $@;
756        my $savedError = $@;
757        # Trace the message.
758        Trace($message);
759        # This will contain the lock handle. If it's defined, it means we need to unlock.
760        my $lock;
761        # Check for feed forcing.
762        my $forceFeed = exists $Categories{feed};
763        # An error here would be disastrous. Note that if debug mode is specified,
764        # we do this stuff even in a test environment.
765        eval {
766            # Do we need to put this in the RSS feed?
767            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
768                # Probably. We need to check first, however, to see if it's from an
769                # ignored IP. For non-CGI situations, we default the IP to the self-referent.
770                my $key = "127.0.0.1";
771                if (defined $SavedCGI) {
772                    # Get the IP address.
773                    $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
774                }
775                # Is the IP address in the ignore list?
776                my $found = scalar(grep { $_ eq $key } @FIG_Config::error_ignore_ips);
777                if (! $found) {
778                    # No. We're good. We now need to compute the date, the link, and the title.
779                    # First, the date, in a very specific format.
780                    my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
781                        (tz_local_offset() / 30);
782                    # Environment data goes in here. We start with the date.
783                    my $environment = "$date.  ";
784                    # If we need to recap the message (because it's too long to be a title), we'll
785                    # put it in here.
786                    my $recap;
787                    # Copy the message and remove excess space.
788                    my $title = $message;
789                    $title =~ s/\s+/ /gs;
790                    # If it's too long, we have to split it up.
791                    if (length $title > 60) {
792                        # Put the full message in the environment string.
793                        $recap = $title;
794                        # Excerpt it as the title.
795                        $title = substr($title, 0, 50) . "...";
796                    }
797                    # If we have a CGI object, then this is a web error. Otherwise, it's
798                    # command-line.
799                    if (defined $SavedCGI) {
800                        # We're in a web service. The environment is the user's IP, and the link
801                        # is the URL that got us here.
802                        $environment .= "Event Reported at IP address $key process $$.";
803                        my $url = $SavedCGI->self_url();
804                        # We need the user agent string and (if available) the referrer.
805                        # The referrer will be the link.
806                        $environment .= " User Agent $ENV{HTTP_USER_AGENT}";
807                        if ($ENV{HTTP_REFERER}) {
808                            my $link = $ENV{HTTP_REFERER};
809                            $environment .= " referred from <a href=\"$link\">$link</a>.";
810                        } else {
811                            $environment .= " referrer unknown.";
812                        }
813                        # Close off the sentence with the original link.
814                        $environment .= " URL of event is <a href=\"$url\">$url</a>.";
815                    } else {
816                        # No CGI object, so we're a command-line tool. Use the tracing
817                        # key and the PID as the user identifier, and add the command.
818                        my $key = EmergencyKey();
819                        $environment .= "Event Reported by $key process $$.";
820                        if ($CommandLine) {
821                            # We're in a StandardSetup script, so we have the real command line.
822                            $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
823                        } elsif ($ENV{_}) {
824                            # We're in a BASH script, so the command has been stored in the _ variable.
825                            $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
826                        }
827                    }
828                    # Build a GUID. We use the current time, the title, and the process ID,
829                    # then digest the result.
830                    my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
831                    # Finally, the description. This is a stack trace plus various environmental stuff.
832                    # The trace is optional.
833                    my $stackTrace;
834                    if ($options{noStack}) {
835                        $stackTrace = "";
836                    } else {
837                        my @trace = LongMess();
838                        # Only proceed if we got something back.
839                        if (scalar(@trace) > 0) {
840                            $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
841                            $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
842                        }
843                    }
844                    # We got the stack trace. Now it's time to put it all together.
845                    # We have a goofy thing here in that we need to HTML-escape some sections of the description
846                    # twice. They will be escaped once here, and then once when written by XML::Simple. They are
847                    # unescaped once when processed by the RSS reader, and stuff in the description is treated as
848                    # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
849                    # our <br>s and <pre>s are used to format the description.
850                    $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
851                    my $description = "$recap$environment  $stackTrace";
852                    # Okay, we have all the pieces. Create a hash of the new event.
853                    my $newItem = { title => $title,
854                                    description => $description,
855                                    category => $LastCategory,
856                                    pubDate => $date,
857                                    guid => $guid,
858                                  };
859                    # We need XML capability for this.
860                    require XML::Simple;
861                    # The RSS document goes in here.
862                    my $rss;
863                    # Get the name of the RSS file. It's in the FIG temporary directory.
864                    my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
865                    # Open the config file and lock it.
866                    $lock = Open(undef, "<$FIG_Config::fig_disk/config/FIG_Config.pm");
867                    flock $lock, LOCK_EX;
868                    # Does it exist?
869                    if (-s $fileName) {
870                        # Slurp it in.
871                        $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
872                    } else {
873                        my $size = -s $fileName;
874                        # Create an empty channel.
875                        $rss = {
876                            channel => {
877                                title => 'NMPDR Warning Feed',
878                                link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
879                                description => "Important messages regarding the status of the NMPDR.",
880                                generator => "NMPDR Trace Facility",
881                                docs => "http://blogs.law.harvard.edu/tech/rss",
882                                item => []
883                            },
884                        };
885                    }
886                    # Get the channel object.
887                    my $channel = $rss->{channel};
888                    # Update the last-build date.
889                    $channel->{lastBuildDate} = $date;
890                    # Get the item array.
891                    my $items = $channel->{item};
892                    # Insure it has only 100 entries.
893                    while (scalar @{$items} > 100) {
894                        pop @{$items};
895                    }
896                    # Add our new item at the front.
897                    unshift @{$items}, $newItem;
898                    # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
899                    # the requirements for those.
900                    my $xml = XML::Simple::XMLout($channel, NoAttr => 1, RootName => 'channel', XmlDecl => '');
901                    # Here we put in the root and declaration. The problem is that the root has to have the version attribute
902                    # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
903                    $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
904                    # We don't use Open here because we can't afford an error.
905                    if (open XMLOUT, ">$fileName") {
906                        print XMLOUT $xml;
907                        close XMLOUT;
908                    }
909                }
910            }
911        };
912        if ($@) {
913            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
914            # (which is a good thing).
915            my $error = $@;
916            Trace("Feed Error: $error") if T(Feed => 0);
917        }
918        # Be sure to unlock.
919        if ($lock) {
920            flock $lock, LOCK_UN;
921            undef $lock;
922        }
923        # Restore the error message.
924        $@ = $savedError;
925    }
926    
927    
928    
929    
930  =head3 Assert  =head3 Assert
931    
932      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 977 
977      my ($message) = @_;      my ($message) = @_;
978      # Trace what's happening.      # Trace what's happening.
979      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
980      my $confession = longmess($message);      # Get the stack trace.
981      # Convert the confession to a series of trace messages.      my @trace = LongMess();
982      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
983          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
984          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
985              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
986              # Trace the line.              # Trace the line.
987              Trace($line);              Trace($line);
988          }          }
989        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
990        Warn($message);
991      }      }
 }  
   
 =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.  
992    
993  =item RETURN  =head3 LongMess
994    
995  Returns a two-element list consisting of a CGI query object and a variable hash for      my @lines = Tracer::LongMess();
 the output page.  
996    
997  =back  Return a stack trace with all tracing methods removed. The return will be in the form of a list
998    of message strings.
999    
1000  =cut  =cut
1001    
1002  sub ScriptSetup {  sub LongMess {
1003      # Get the parameters.      # Declare the return variable.
1004      my ($noTrace) = @_;      my @retVal = ();
1005      # Get the CGI query object.      my $confession = longmess("");
1006      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
1007      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
1008      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
1009      # Create the variable hash.              push @retVal, $line;
1010      my $varHash = { results => '' };          }
1011      # Return the query object and variable hash.      }
1012      return ($cgi, $varHash);      # Return the result.
1013        return @retVal;
1014  }  }
1015    
1016  =head3 ETracing  =head3 ETracing
# Line 790  Line 1044 
1044      # Get the parameter.      # Get the parameter.
1045      my ($parameter) = @_;      my ($parameter) = @_;
1046      # Check for CGI mode.      # Check for CGI mode.
1047      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
1048            $SavedCGI = $parameter;
1049        } else {
1050            $SavedCGI = undef;
1051        }
1052      # Default to no tracing except errors.      # Default to no tracing except errors.
1053      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
1054      # Check for emergency tracing.      # Check for emergency tracing.
# Line 823  Line 1081 
1081              # Set the trace parameter.              # Set the trace parameter.
1082              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1083          }          }
1084      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1085          # 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
1086          # for tracing from the form parameters.          # for tracing from the form parameters.
1087          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1088              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1089              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1090              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1091          }          }
1092      }      }
1093      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1094      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1095      # Check to see if we're a web script.      # Check to see if we're a web script.
1096      if (defined $cgi) {      if (defined $SavedCGI) {
1097          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1098          TraceParms($cgi);          TraceParms($SavedCGI);
1099          # 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
1100          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1101          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1028  Line 1286 
1286      # Declare the return variable.      # Declare the return variable.
1287      my $retVal;      my $retVal;
1288      # Determine the parameter type.      # Determine the parameter type.
1289      if (! defined $parameter) {      if (! defined $parameter || defined($ENV{TRACING})) {
1290          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1291          $retVal = $ENV{TRACING};          # get the effective login ID.
1292            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1293      } else {      } else {
1294          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1295          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1071  Line 1330 
1330      # Get the parameters.      # Get the parameters.
1331      my ($cgi) = @_;      my ($cgi) = @_;
1332      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1333          # Here we trace the GET-style URL for the script.          # Here we trace the GET-style URL for the script, but only if it's
1334          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));          # relatively small.
1335            my $url = $cgi->url(-relative => 1, -query => 1);
1336            my $len = length($url);
1337            if ($len < 500) {
1338                Trace("[URL] $url");
1339            } elsif ($len > 2048) {
1340                Trace("[URL] URL is too long to use with GET ($len characters).");
1341            } else {
1342                Trace("[URL] URL length is $len characters.");
1343            }
1344      }      }
1345      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1346          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1147  Line 1415 
1415      }      }
1416  }  }
1417    
   
 =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;  
 }  
   
1418  =head2 Command-Line Utility Methods  =head2 Command-Line Utility Methods
1419    
1420  =head3 SendSMS  =head3 SendSMS
# Line 1454  Line 1619 
1619  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
1620  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,
1621  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
1622  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
1623    login ID.
1624    
1625    Since the default situation in StandardSetup is to trace to the standard
1626    output, errors that occur in command-line scripts will not generate
1627    RSS events. To force the events, use the C<warn> option.
1628    
1629        TransactFeatures -background -warn register ../xacts IDs.tbl
1630    
1631  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1632  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 1471  Line 1643 
1643          -noAlias  do not expect aliases in CHANGE transactions          -noAlias  do not expect aliases in CHANGE transactions
1644          -start    start with this genome          -start    start with this genome
1645          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
1646            -forked   do not erase the trace file before tracing
1647    
1648  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
1649  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 1534  Line 1707 
1707      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1708      # Get the default tracing key.      # Get the default tracing key.
1709      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1710        # Save the command line.
1711        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1712      # Add the tracing options.      # Add the tracing options.
1713      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1714          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
1715      }      }
1716        if (! exists $options->{forked}) {
1717            $options->{forked} = [0, "keep old trace file"];
1718        }
1719      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
1720      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1721      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1722      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1723        $options->{warn} = [0, "send errors to RSS feed"];
1724        $options->{moreTracing} = ["", "comma-delimited list of additional trace modules for debugging"];
1725      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1726      # contains the default values rather than the default value      # contains the default values rather than the default value
1727      # 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 1558  Line 1738 
1738      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
1739      # Get the logfile suffix.      # Get the logfile suffix.
1740      my $suffix = $retOptions->{user};      my $suffix = $retOptions->{user};
1741      # Check for background mode.      # We'll put the trace file name in here. We need it later if background
1742      if ($retOptions->{background}) {      # mode is on.
1743          my $outFileName = "$FIG_Config::temp/out$suffix.log";      my $traceFileName;
         my $errFileName = "$FIG_Config::temp/err$suffix.log";  
         open STDOUT, ">$outFileName";  
         open STDERR, ">$errFileName";  
         # Check for phone support. If we have phone support and a phone number,  
         # we want to turn it on.  
         if ($ENV{PHONE} && defined($FIG_Config::phone)) {  
             $retOptions->{phone} = $ENV{PHONE};  
         }  
     }  
1744      # Now we want to set up tracing. First, we need to know if the user      # Now we want to set up tracing. First, we need to know if the user
1745      # wants emergency tracing.      # wants emergency tracing.
1746      if ($retOptions->{trace} eq 'E') {      if ($retOptions->{trace} eq 'E') {
# Line 1580  Line 1751 
1751          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1752              push @cats, "SQL";              push @cats, "SQL";
1753          }          }
1754            if ($retOptions->{warn}) {
1755                push @cats, "Feed";
1756            }
1757          # Add the default categories.          # Add the default categories.
1758          push @cats, "Tracer";          push @cats, "Tracer";
1759            # Check for more tracing groups.
1760            if ($retOptions->{moreTracing}) {
1761                push @cats, split /,/, $retOptions->{moreTracing};
1762            }
1763          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
1764          my $cats = join(" ", @cats);          my $cats = join(" ", @cats);
1765          # Check to determine whether or not the caller wants to turn off tracing          # Check to determine whether or not the caller wants to turn off tracing
# Line 1596  Line 1774 
1774          my $traceMode;          my $traceMode;
1775          # Verify that we can open a file in the FIG temporary directory.          # Verify that we can open a file in the FIG temporary directory.
1776          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
1777          if (open TESTTRACE, ">$traceFileName") {          my $traceFileSpec = ($retOptions->{forked} ? ">>$traceFileName" : ">$traceFileName");
1778            if (open TESTTRACE, "$traceFileSpec") {
1779              # Here we can trace to a file.              # Here we can trace to a file.
1780              $traceMode = ">$traceFileName";              $traceMode = ">>$traceFileName";
1781              if ($textOKFlag) {              if ($textOKFlag) {
1782                  # Echo to standard output if the text-OK flag is set.                  # Echo to standard output if the text-OK flag is set.
1783                  $traceMode = "+$traceMode";                  $traceMode = "+$traceMode";
# Line 1619  Line 1798 
1798          # Now set up the tracing.          # Now set up the tracing.
1799          TSetup("$traceLevel $cats", $traceMode);          TSetup("$traceLevel $cats", $traceMode);
1800      }      }
1801      # Check for the "help" option. If it is specified, dump the command-line      # Check for background mode.
1802      # options and exit the program.      if ($retOptions->{background}) {
1803      if ($retOptions->{help}) {          my $outFileName = "$FIG_Config::temp/out$suffix$$.log";
1804          $0 =~ m#[/\\](\w+)(\.pl)?$#i;          my $errFileName = "$FIG_Config::temp/err$suffix$$.log";
1805          print "$1 [options] $parmHelp\n";          # Spool the output.
1806          for my $key (sort keys %{$options}) {          open STDOUT, ">$outFileName";
1807              my $name = Pad($key, $longestName, 0, ' ');          # If we have a trace file, trace the errors to the log. Otherwise,
1808            # spool the errors.
1809            if (defined $traceFileName) {
1810                open STDERR, "| Tracer $traceFileName";
1811            } else {
1812                open STDERR, ">$errFileName";
1813            }
1814            # Check for phone support. If we have phone support and a phone number,
1815            # we want to turn it on.
1816            if ($ENV{PHONE} && defined($FIG_Config::phone)) {
1817                $retOptions->{phone} = $ENV{PHONE};
1818            }
1819        }
1820        # Check for the "help" option. If it is specified, dump the command-line
1821        # options and exit the program.
1822        if ($retOptions->{help}) {
1823            $0 =~ m#[/\\](\w+)(\.pl)?$#i;
1824            print "$1 [options] $parmHelp\n";
1825            for my $key (sort keys %{$options}) {
1826                my $name = Pad($key, $longestName, 0, ' ');
1827              my $desc = $options->{$key}->[1];              my $desc = $options->{$key}->[1];
1828              if ($options->{$key}->[0]) {              if ($options->{$key}->[0]) {
1829                  $desc .= " (default " . $options->{$key}->[0] . ")";                  $desc .= " (default " . $options->{$key}->[0] . ")";
# Line 1799  Line 1997 
1997      }      }
1998  }  }
1999    
2000    =head3 UnparseOptions
2001    
2002        my $optionString = Tracer::UnparseOptions(\%options);
2003    
2004    Convert an option hash into a command-line string. This will not
2005    necessarily be the same text that came in, but it will nonetheless
2006    produce the same ultimate result when parsed by L</StandardSetup>.
2007    
2008    =over 4
2009    
2010    =item options
2011    
2012    Reference to a hash of options to convert into an option string.
2013    
2014    =item RETURN
2015    
2016    Returns a string that will parse to the same set of options when
2017    parsed by L</StandardSetup>.
2018    
2019    =back
2020    
2021    =cut
2022    
2023    sub UnparseOptions {
2024        # Get the parameters.
2025        my ($options) = @_;
2026        # The option segments will be put in here.
2027        my @retVal = ();
2028        # Loop through the options.
2029        for my $key (keys %$options) {
2030            # Get the option value.
2031            my $value = $options->{$key};
2032            # Only use it if it's nonempty.
2033            if (defined $value && $value ne "") {
2034                my $segment = "--$key=$value";
2035                # Quote it if necessary.
2036                if ($segment =~ /[ |<>*]/) {
2037                    $segment = '"' . $segment . '"';
2038                }
2039                # Add it to the return list.
2040                push @retVal, $segment;
2041            }
2042        }
2043        # Return the result.
2044        return join(" ", @retVal);
2045    }
2046    
2047  =head3 ParseCommand  =head3 ParseCommand
2048    
2049      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);
# Line 2377  Line 2622 
2622  Map of search patterns to permission masks. If a directory name matches  Map of search patterns to permission masks. If a directory name matches
2623  one of the patterns, that directory and all its members and subdirectories  one of the patterns, that directory and all its members and subdirectories
2624  will be assigned the new pattern. For example, the following would  will be assigned the new pattern. For example, the following would
2625  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>.
2626    
2627      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2628    
# Line 2430  Line 2675 
2675                      $match = 1;                      $match = 1;
2676                  }                  }
2677              }              }
2678              # 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
2679              # before terminating due to the match.              # before terminating due to the match.
2680              if ($match && $otherMasks[$i-1] != $mask) {              if ($match && $otherMasks[$i-1] != $mask) {
2681                  # This directory matches one of the incoming patterns, and it's                  # This directory matches one of the incoming patterns, and it's
# Line 2598  Line 2843 
2843    
2844  =head2 Other Useful Methods  =head2 Other Useful Methods
2845    
2846    =head3 IDHASH
2847    
2848        my $hash = SHTargetSearch::IDHASH(@keys);
2849    
2850    This is a dinky little method that converts a list of values to a reference
2851    to hash of values to labels. The values and labels are the same.
2852    
2853    =cut
2854    
2855    sub IDHASH {
2856        my %retVal = map { $_ => $_ } @_;
2857        return \%retVal;
2858    }
2859    
2860    =head3 Pluralize
2861    
2862        my $plural = Tracer::Pluralize($word);
2863    
2864    This is a very simple pluralization utility. It adds an C<s> at the end
2865    of the input word unless it already ends in an C<s>, in which case it
2866    adds C<es>.
2867    
2868    =over 4
2869    
2870    =item word
2871    
2872    Singular word to pluralize.
2873    
2874    =item RETURN
2875    
2876    Returns the probable plural form of the word.
2877    
2878    =back
2879    
2880    =cut
2881    
2882    sub Pluralize {
2883        # Get the parameters.
2884        my ($word) = @_;
2885        # Declare the return variable.
2886        my $retVal;
2887        if ($word =~ /s$/) {
2888            $retVal = $word . 'es';
2889        } else {
2890            $retVal = $word . 's';
2891        }
2892        # Return the result.
2893        return $retVal;
2894    }
2895    
2896    =head3 Numeric
2897    
2898        my $okFlag = Tracer::Numeric($string);
2899    
2900    Return the value of the specified string if it is numeric, or an undefined value
2901    if it is not numeric.
2902    
2903    =over 4
2904    
2905    =item string
2906    
2907    String to check.
2908    
2909    =item RETURN
2910    
2911    Returns the numeric value of the string if successful, or C<undef> if the string
2912    is not numeric.
2913    
2914    =back
2915    
2916    =cut
2917    
2918    sub Numeric {
2919        # Get the parameters.
2920        my ($string) = @_;
2921        # We'll put the value in here if we succeed.
2922        my $retVal;
2923        # Get a working copy of the string.
2924        my $copy = $string;
2925        # Trim leading and trailing spaces.
2926        $copy =~ s/^\s+//;
2927        $copy =~ s/\s+$//;
2928        # Check the result.
2929        if ($copy =~ /^[+-]?\d+$/) {
2930            $retVal = $copy;
2931        } elsif ($copy =~ /^([+-]\d+|\d*)[eE][+-]?\d+$/) {
2932            $retVal = $copy;
2933        } elsif ($copy =~ /^([+-]\d+|\d*)\.\d*([eE][+-]?\d+)?$/) {
2934            $retVal = $copy;
2935        }
2936        # Return the result.
2937        return $retVal;
2938    }
2939    
2940    
2941  =head3 ParseParm  =head3 ParseParm
2942    
2943      my $listValue = Tracer::ParseParm($string);      my $listValue = Tracer::ParseParm($string);
# Line 2840  Line 3180 
3180      return $retVal;      return $retVal;
3181  }  }
3182    
3183    =head3 In
3184    
3185        my $flag = Tracer::In($value, $min, $max);
3186    
3187    Return TRUE if the value is between the minimum and the maximum, else FALSE.
3188    
3189    =cut
3190    
3191    sub In {
3192        return ($_[0] <= $_[2] && $_[0] >= $_[1]);
3193    }
3194    
3195    
3196  =head3 Constrain  =head3 Constrain
3197    
3198      my $constrained = Constrain($value, $min, $max);      my $constrained = Constrain($value, $min, $max);
# Line 2951  Line 3304 
3304      return $retVal;      return $retVal;
3305  }  }
3306    
   
3307  =head3 Strip  =head3 Strip
3308    
3309      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
# Line 2984  Line 3336 
3336      return $retVal;      return $retVal;
3337  }  }
3338    
3339    =head3 Trim
3340    
3341        my $string = Tracer::Trim($line);
3342    
3343    Trim all spaces from the beginning and ending of a string.
3344    
3345    =over 4
3346    
3347    =item line
3348    
3349    Line of text to be trimmed.
3350    
3351    =item RETURN
3352    
3353    The same line of text with all whitespace chopped off either end.
3354    
3355    =back
3356    
3357    =cut
3358    
3359    sub Trim {
3360        # Get a copy of the parameter string.
3361        my ($string) = @_;
3362        my $retVal = (defined $string ? $string : "");
3363        # Strip the front spaces.
3364        $retVal =~ s/^\s+//;
3365        # Strip the back spaces.
3366        $retVal =~ s/\s+$//;
3367        # Return the result.
3368        return $retVal;
3369    }
3370    
3371  =head3 Pad  =head3 Pad
3372    
3373      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);
# Line 3201  Line 3585 
3585      return ($inserted, $deleted);      return ($inserted, $deleted);
3586  }  }
3587    
3588    =head3 Cmp
3589    
3590        my $cmp = Tracer::Cmp($a, $b);
3591    
3592    This method performs a universal sort comparison. Each value coming in is
3593    separated into a leading text part and a trailing number part. The text
3594    part is string compared, and if both parts are equal, then the number
3595    parts are compared numerically. A stream of just numbers or a stream of
3596    just strings will sort correctly, and a mixed stream will sort with the
3597    numbers first. Strings with a label and a number will sort in the
3598    expected manner instead of lexically.
3599    
3600    =over 4
3601    
3602    =item a
3603    
3604    First item to compare.
3605    
3606    =item b
3607    
3608    Second item to compare.
3609    
3610    =item RETURN
3611    
3612    Returns a negative number if the first item should sort first (is less), a positive
3613    number if the first item should sort second (is greater), and a zero if the items are
3614    equal.
3615    
3616    =back
3617    
3618    =cut
3619    
3620    sub Cmp {
3621        # Get the parameters.
3622        my ($a, $b) = @_;
3623        # Declare the return value.
3624        my $retVal;
3625        # Check for nulls.
3626        if (! defined($a)) {
3627            $retVal = (! defined($b) ? 0 : -1);
3628        } elsif (! defined($b)) {
3629            $retVal = 1;
3630        } else {
3631            # Here we have two real values. Parse the two strings.
3632            my $aParsed = _Parse($a);
3633            my $bParsed = _Parse($b);
3634            # Compare the string parts insensitively.
3635            $retVal = (lc $aParsed->[0] cmp lc $bParsed->[0]);
3636            # If they're equal, compare them sensitively.
3637            if (! $retVal) {
3638                $retVal = ($aParsed->[0] cmp $bParsed->[0]);
3639            }
3640            # If they're STILL equal, compare the number parts.
3641            if (! $retVal) {
3642                $retVal = $aParsed->[1] <=> $bParsed->[1];
3643            }
3644        }
3645        # Return the result.
3646        return $retVal;
3647    }
3648    
3649    # This method parses an input string into a string part and a number part.
3650    sub _Parse {
3651        my ($string) = @_;
3652        my ($alpha, $num);
3653        if ($string =~ /^(.*?)(\d+(?:\.\d+)?)$/) {
3654            $alpha = $1;
3655            $num = $2;
3656        } else {
3657            $alpha = $string;
3658            $num = 0;
3659        }
3660        return [$alpha, $num];
3661    }
3662    
3663    =head3 ListEQ
3664    
3665        my $flag = Tracer::ListEQ(\@a, \@b);
3666    
3667    Return TRUE if the specified lists contain the same strings in the same
3668    order, else FALSE.
3669    
3670    =over 4
3671    
3672    =item a
3673    
3674    Reference to the first list.
3675    
3676    =item b
3677    
3678    Reference to the second list.
3679    
3680    =item RETURN
3681    
3682    Returns TRUE if the two parameters are identical string lists, else FALSE.
3683    
3684    =back
3685    
3686    =cut
3687    
3688    sub ListEQ {
3689        # Get the parameters.
3690        my ($a, $b) = @_;
3691        # Declare the return variable. Start by checking the lengths.
3692        my $n = scalar(@$a);
3693        my $retVal = ($n == scalar(@$b));
3694        # Now compare the list elements.
3695        for (my $i = 0; $retVal && $i < $n; $i++) {
3696            $retVal = ($a->[$i] eq $b->[$i]);
3697        }
3698        # Return the result.
3699        return $retVal;
3700    }
3701    
3702    =head2 CGI Script Utilities
3703    
3704    =head3 ScriptSetup (deprecated)
3705    
3706        my ($cgi, $varHash) = ScriptSetup($noTrace);
3707    
3708    Perform standard tracing and debugging setup for scripts. The value returned is
3709    the CGI object followed by a pre-built variable hash. At the end of the script,
3710    the client should call L</ScriptFinish> to output the web page.
3711    
3712    This method calls L</ETracing> to configure tracing, which allows the tracing
3713    to be configured via the emergency tracing form on the debugging control panel.
3714    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3715    method, which includes every program that uses this method or L</StandardSetup>.
3716    
3717    =over 4
3718    
3719    =item noTrace (optional)
3720    
3721    If specified, tracing will be suppressed. This is useful if the script wants to set up
3722    tracing manually.
3723    
3724    =item RETURN
3725    
3726    Returns a two-element list consisting of a CGI query object and a variable hash for
3727    the output page.
3728    
3729    =back
3730    
3731    =cut
3732    
3733    sub ScriptSetup {
3734        # Get the parameters.
3735        my ($noTrace) = @_;
3736        # Get the CGI query object.
3737        my $cgi = CGI->new();
3738        # Set up tracing if it's not suppressed.
3739        ETracing($cgi) unless $noTrace;
3740        # Create the variable hash.
3741        my $varHash = { results => '' };
3742        # Return the query object and variable hash.
3743        return ($cgi, $varHash);
3744    }
3745    
3746    =head3 ScriptFinish (deprecated)
3747    
3748        ScriptFinish($webData, $varHash);
3749    
3750    Output a web page at the end of a script. Either the string to be output or the
3751    name of a template file can be specified. If the second parameter is omitted,
3752    it is assumed we have a string to be output; otherwise, it is assumed we have the
3753    name of a template file. The template should have the variable C<DebugData>
3754    specified in any form that invokes a standard script. If debugging mode is turned
3755    on, a form field will be put in that allows the user to enter tracing data.
3756    Trace messages will be placed immediately before the terminal C<BODY> tag in
3757    the output, formatted as a list.
3758    
3759    A typical standard script would loook like the following.
3760    
3761        BEGIN {
3762            # Print the HTML header.
3763            print "CONTENT-TYPE: text/html\n\n";
3764        }
3765        use Tracer;
3766        use CGI;
3767        use FIG;
3768        # ... more uses ...
3769    
3770        my ($cgi, $varHash) = ScriptSetup();
3771        eval {
3772            # ... get data from $cgi, put it in $varHash ...
3773        };
3774        if ($@) {
3775            Trace("Script Error: $@") if T(0);
3776        }
3777        ScriptFinish("Html/MyTemplate.html", $varHash);
3778    
3779    The idea here is that even if the script fails, you'll see trace messages and
3780    useful output.
3781    
3782    =over 4
3783    
3784    =item webData
3785    
3786    A string containing either the full web page to be written to the output or the
3787    name of a template file from which the page is to be constructed. If the name
3788    of a template file is specified, then the second parameter must be present;
3789    otherwise, it must be absent.
3790    
3791    =item varHash (optional)
3792    
3793    If specified, then a reference to a hash mapping variable names for a template
3794    to their values. The template file will be read into memory, and variable markers
3795    will be replaced by data in this hash reference.
3796    
3797    =back
3798    
3799    =cut
3800    
3801    sub ScriptFinish {
3802        # Get the parameters.
3803        my ($webData, $varHash) = @_;
3804        # Check for a template file situation.
3805        my $outputString;
3806        if (defined $varHash) {
3807            # Here we have a template file. We need to determine the template type.
3808            my $template;
3809            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3810                $template = "$FIG_Config::template_url/$webData";
3811            } else {
3812                $template = "<<$webData";
3813            }
3814            $outputString = PageBuilder::Build($template, $varHash, "Html");
3815        } else {
3816            # Here the user gave us a raw string.
3817            $outputString = $webData;
3818        }
3819        # Check for trace messages.
3820        if ($Destination ne "NONE" && $TraceLevel > 0) {
3821            # We have trace messages, so we want to put them at the end of the body. This
3822            # is either at the end of the whole string or at the beginning of the BODY
3823            # end-tag.
3824            my $pos = length $outputString;
3825            if ($outputString =~ m#</body>#gi) {
3826                $pos = (pos $outputString) - 7;
3827            }
3828            # If the trace messages were queued, we unroll them. Otherwise, we display the
3829            # destination.
3830            my $traceHtml;
3831            if ($Destination eq "QUEUE") {
3832                $traceHtml = QTrace('Html');
3833            } elsif ($Destination =~ /^>>(.+)$/) {
3834                # Here the tracing output it to a file. We code it as a hyperlink so the user
3835                # can copy the file name into the clipboard easily.
3836                my $actualDest = $1;
3837                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3838            } else {
3839                # Here we have one of the special destinations.
3840                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3841            }
3842            substr $outputString, $pos, 0, $traceHtml;
3843        }
3844        # Write the output string.
3845        print $outputString;
3846    }
3847    
3848  =head3 GenerateURL  =head3 GenerateURL
3849    
3850      my $queryUrl = Tracer::GenerateURL($page, %parameters);      my $queryUrl = Tracer::GenerateURL($page, %parameters);
# Line 3335  Line 3979 
3979      return $retVal;      return $retVal;
3980  }  }
3981    
 =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;  
 }  
   
   
3982  =head3 TrackingCode  =head3 TrackingCode
3983    
3984      my $html = Tracer::TrackingCode();      my $html = Tracer::TrackingCode();
# Line 3424  Line 4009 
4009      return $retVal;      return $retVal;
4010  }  }
4011    
4012    =head3 Clean
4013    
4014        my $cleaned = Tracer::Clean($string);
4015    
4016    Clean up a string for HTML display. This not only converts special
4017    characters to HTML entity names, it also removes control characters.
4018    
4019    =over 4
4020    
4021    =item string
4022    
4023    String to convert.
4024    
4025    =item RETURN
4026    
4027    Returns the input string with anything that might disrupt an HTML literal removed. An
4028    undefined value will be converted to an empty string.
4029    
4030    =back
4031    
4032    =cut
4033    
4034    sub Clean {
4035        # Get the parameters.
4036        my ($string) = @_;
4037        # Declare the return variable.
4038        my $retVal = "";
4039        # Only proceed if the value exists.
4040        if (defined $string) {
4041            # Get the string.
4042            $retVal = $string;
4043            # Clean the control characters.
4044            $retVal =~ tr/\x00-\x1F/?/;
4045            # Escape the rest.
4046            $retVal = CGI::escapeHTML($retVal);
4047        }
4048        # Return the result.
4049        return $retVal;
4050    }
4051    
4052    =head3 SortByValue
4053    
4054        my @keys = Tracer::SortByValue(\%hash);
4055    
4056    Get a list of hash table keys sorted by hash table values.
4057    
4058    =over 4
4059    
4060    =item hash
4061    
4062    Hash reference whose keys are to be extracted.
4063    
4064    =item RETURN
4065    
4066    Returns a list of the hash keys, ordered so that the corresponding hash values
4067    are in alphabetical sequence.
4068    
4069    =back
4070    
4071    =cut
4072    
4073    sub SortByValue {
4074        # Get the parameters.
4075        my ($hash) = @_;
4076        # Sort the hash's keys using the values.
4077        my @retVal = sort { Cmp($hash->{$a}, $hash->{$b}) } keys %$hash;
4078        # Return the result.
4079        return @retVal;
4080    }
4081    
4082    =head3 GetSet
4083    
4084        my $value = Tracer::GetSet($object, $name => $newValue);
4085    
4086    Get or set the value of an object field. The object is treated as an
4087    ordinary hash reference. If a new value is specified, it is stored in the
4088    hash under the specified name and then returned. If no new value is
4089    specified, the current value is returned.
4090    
4091    =over 4
4092    
4093    =item object
4094    
4095    Reference to the hash that is to be interrogated or updated.
4096    
4097    =item name
4098    
4099    Name of the field. This is the hash key.
4100    
4101    =item newValue (optional)
4102    
4103    New value to be stored in the field. If no new value is specified, the current
4104    value of the field is returned.
4105    
4106    =item RETURN
4107    
4108    Returns the value of the named field in the specified hash.
4109    
4110    =back
4111    
4112    =cut
4113    
4114    sub GetSet {
4115        # Get the parameters.
4116        my ($object, $name, $newValue) = @_;
4117        # Is a new value specified?
4118        if (defined $newValue) {
4119            # Yes, so store it.
4120            $object->{$name} = $newValue;
4121        }
4122        # Return the result.
4123        return $object->{$name};
4124    }
4125    
4126  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3