[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.131, Wed Nov 17 11:32:35 2010 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 Carp qw(longmess croak carp);      use base qw(Exporter);
23        use vars qw(@EXPORT @EXPORT_OK);
24        @EXPORT = qw(Trace T TSetup QTrace Confess MemTrace Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency Warn TraceDump IDHASH);
25        @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);
26        use Carp qw(longmess croak carp confess);
27      use CGI;      use CGI;
28      use Cwd;      use Cwd;
29      use FIG_Config;      use FIG_Config;
# Line 36  Line 36 
36      use Time::HiRes 'gettimeofday';      use Time::HiRes 'gettimeofday';
37      use URI::Escape;      use URI::Escape;
38      use Time::Local;      use Time::Local;
39        use POSIX qw(strftime);
40        use Time::Zone;
41        use Fcntl qw(:DEFAULT :flock);
42        use Data::Dumper;
43    
44    
45  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
46    
# Line 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    my $Confessions = 0;        # confession count
215    umask 2;                    # Fix the damn umask so everything is group-writable.
216    
217  =head2 Tracing Methods  =head2 Tracing Methods
218    
# Line 480  Line 489 
489          # Push the message into the queue.          # Push the message into the queue.
490          push @Queue, "$formatted";          push @Queue, "$formatted";
491      } elsif ($Destination eq "HTML") {      } elsif ($Destination eq "HTML") {
492          # Convert the message to HTML and write it to the standard output.          # Convert the message to HTML.
493          my $escapedMessage = CGI::escapeHTML($stripped);          my $escapedMessage = CGI::escapeHTML($stripped);
494          print "<p>$timeStamp $LastCategory $LastLevel: $escapedMessage</p>\n";          # The stuff after the first line feed should be pre-formatted.
495            my @lines = split /\s*\n/, $escapedMessage;
496            # Get the normal portion.
497            my $line1 = shift @lines;
498            print "<p>$timeStamp $LastCategory $LastLevel: $line1</p>\n";
499            if (@lines) {
500                print "<pre>" . join("\n", @lines, "</pre>");
501            }
502      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
503          # Write the trace message to an output file.          # Write the trace message to an output file.
504          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || confess("Tracing open for \"$Destination\" failed: $!");
505            # Lock the file.
506            flock TRACING, LOCK_EX;
507          print TRACING "$formatted\n";          print TRACING "$formatted\n";
508          close TRACING;          close TRACING;
509          # 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 513 
513      }      }
514  }  }
515    
516    =head3 MemTrace
517    
518        MemTrace($message);
519    
520    Output a trace message that includes memory size information.
521    
522    =over 4
523    
524    =item message
525    
526    Message to display. The message will be followed by a sentence about the memory size.
527    
528    =back
529    
530    =cut
531    
532    sub MemTrace {
533        # Get the parameters.
534        my ($message) = @_;
535        my $memory = GetMemorySize();
536        Trace("$message $memory in use.");
537    }
538    
539    
540    =head3 TraceDump
541    
542        TraceDump($title, $object);
543    
544    Dump an object to the trace log. This method simply calls the C<Dumper>
545    function, but routes the output to the trace log instead of returning it
546    as a string. The output is arranged so that it comes out monospaced when
547    it appears in an HTML trace dump.
548    
549    =over 4
550    
551    =item title
552    
553    Title to give to the object being dumped.
554    
555    =item object
556    
557    Reference to a list, hash, or object to dump.
558    
559    =back
560    
561    =cut
562    
563    sub TraceDump {
564        # Get the parameters.
565        my ($title, $object) = @_;
566        # Trace the object.
567        Trace("Object dump for $title:\n" . Dumper($object));
568    }
569    
570  =head3 T  =head3 T
571    
572      my $switch = T($category, $traceLevel);      my $switch = T($category, $traceLevel);
# Line 553  Line 625 
625          $LastLevel = $traceLevel;          $LastLevel = $traceLevel;
626          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
627          $category = lc $category;          $category = lc $category;
628          # Use the category and tracelevel to compute the result.          # Validate the trace level.
629          if (ref $traceLevel) {          if (ref $traceLevel) {
630              Confess("Bad trace level.");              Confess("Bad trace level.");
631          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
632              Confess("Bad trace config.");              Confess("Bad trace config.");
633          }          }
634          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
635            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
636      }      }
637      # Return the computed result.      # Return the computed result.
638      return $retVal;      return $retVal;
# Line 636  Line 709 
709      # Set up the category and level.      # Set up the category and level.
710      $LastCategory = "(confess)";      $LastCategory = "(confess)";
711      $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.");  
             }  
         }  
     }  
712      # Trace the call stack.      # Trace the call stack.
713      Cluck($message);      Cluck($message);
714        # Increment the confession count.
715        $Confessions++;
716      # Abort the program.      # Abort the program.
717      croak(">>> $message");      croak(">>> $message");
718  }  }
719    
720    =head3 Confessions
721    
722        my $count = Tracer::Confessions();
723    
724    Return the number of calls to L</Confess> by the current task.
725    
726    =cut
727    
728    sub Confessions {
729        return $Confessions;
730    }
731    
732    
733    =head3 SaveCGI
734    
735        Tracer::SaveCGI($cgi);
736    
737    This method saves the CGI object but does not activate emergency tracing.
738    It is used to allow L</Warn> to work in situations where emergency
739    tracing is contra-indicated (e.g. the wiki).
740    
741    =over 4
742    
743    =item cgi
744    
745    Active CGI query object.
746    
747    =back
748    
749    =cut
750    
751    sub SaveCGI {
752        $SavedCGI = $_[0];
753    }
754    
755    =head3 Warn
756    
757        Warn($message, @options);
758    
759    This method traces an important message. If an RSS feed is configured
760    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
761    then the message will be echoed to the feed. In general, a tracing
762    destination of C<WARN> indicates that the caller is running as a web
763    service in a production environment; however, this is not a requirement.
764    
765    To force warnings into the RSS feed even when the tracing destination
766    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
767    configured automatically when L</StandardSetup> is used.
768    
769    The L</Cluck> method calls this one for its final message. Since
770    L</Confess> calls L</Cluck>, this means that any error which is caught
771    and confessed will put something in the feed. This insures that someone
772    will be alerted relatively quickly when a failure occurs.
773    
774    =over 4
775    
776    =item message
777    
778    Message to be traced.
779    
780    =item options
781    
782    A list containing zero or more options.
783    
784    =back
785    
786    The permissible options are as follows.
787    
788    =over 4
789    
790    =item noStack
791    
792    If specified, then the stack trace is not included in the output.
793    
794    =back
795    
796    =cut
797    
798    sub Warn {
799        # Get the parameters.
800        my $message = shift @_;
801        my %options = map { $_ => 1 } @_;
802        # Save $@;
803        my $savedError = $@;
804        # Trace the message.
805        Trace($message);
806        # This will contain the lock handle. If it's defined, it means we need to unlock.
807        my $lock;
808        # Check for feed forcing.
809        my $forceFeed = exists $Categories{feed};
810        # An error here would be disastrous. Note that if debug mode is specified,
811        # we do this stuff even in a test environment.
812        eval {
813            # Do we need to put this in the RSS feed?
814            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
815                # Probably. We need to check first, however, to see if it's from an
816                # ignored IP. For non-CGI situations, we default the IP to the self-referent.
817                my $key = "127.0.0.1";
818                if (defined $SavedCGI) {
819                    # Get the IP address.
820                    $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
821                }
822                # Is the IP address in the ignore list?
823                my $found = scalar(grep { $_ eq $key } @FIG_Config::error_ignore_ips);
824                if (! $found) {
825                    # No. We're good. We now need to compute the date, the link, and the title.
826                    # First, the date, in a very specific format.
827                    my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
828                        (tz_local_offset() / 30);
829                    # Environment data goes in here. We start with the date.
830                    my $environment = "$date.  ";
831                    # If we need to recap the message (because it's too long to be a title), we'll
832                    # put it in here.
833                    my $recap;
834                    # Copy the message and remove excess space.
835                    my $title = $message;
836                    $title =~ s/\s+/ /gs;
837                    # If it's too long, we have to split it up.
838                    if (length $title > 60) {
839                        # Put the full message in the environment string.
840                        $recap = $title;
841                        # Excerpt it as the title.
842                        $title = substr($title, 0, 50) . "...";
843                    }
844                    # If we have a CGI object, then this is a web error. Otherwise, it's
845                    # command-line.
846                    if (defined $SavedCGI) {
847                        # We're in a web service. The environment is the user's IP, and the link
848                        # is the URL that got us here.
849                        $environment .= "Event Reported at IP address $key process $$.";
850                        my $url = $SavedCGI->self_url();
851                        # We need the user agent string and (if available) the referrer.
852                        # The referrer will be the link.
853                        $environment .= " User Agent $ENV{HTTP_USER_AGENT}";
854                        if ($ENV{HTTP_REFERER}) {
855                            my $link = $ENV{HTTP_REFERER};
856                            $environment .= " referred from <a href=\"$link\">$link</a>.";
857                        } else {
858                            $environment .= " referrer unknown.";
859                        }
860                        # Close off the sentence with the original link.
861                        $environment .= " URL of event is <a href=\"$url\">$url</a>.";
862                    } else {
863                        # No CGI object, so we're a command-line tool. Use the tracing
864                        # key and the PID as the user identifier, and add the command.
865                        my $key = EmergencyKey();
866                        $environment .= "Event Reported by $key process $$.";
867                        if ($CommandLine) {
868                            # We're in a StandardSetup script, so we have the real command line.
869                            $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
870                        } elsif ($ENV{_}) {
871                            # We're in a BASH script, so the command has been stored in the _ variable.
872                            $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
873                        }
874                    }
875                    # Build a GUID. We use the current time, the title, and the process ID,
876                    # then digest the result.
877                    my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
878                    # Finally, the description. This is a stack trace plus various environmental stuff.
879                    # The trace is optional.
880                    my $stackTrace;
881                    if ($options{noStack}) {
882                        $stackTrace = "";
883                    } else {
884                        my @trace = LongMess();
885                        # Only proceed if we got something back.
886                        if (scalar(@trace) > 0) {
887                            $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
888                            $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
889                        }
890                    }
891                    # We got the stack trace. Now it's time to put it all together.
892                    # We have a goofy thing here in that we need to HTML-escape some sections of the description
893                    # twice. They will be escaped once here, and then once when written by XML::Simple. They are
894                    # unescaped once when processed by the RSS reader, and stuff in the description is treated as
895                    # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
896                    # our <br>s and <pre>s are used to format the description.
897                    $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
898                    my $description = "$recap$environment  $stackTrace";
899                    # Okay, we have all the pieces. Create a hash of the new event.
900                    my $newItem = { title => $title,
901                                    description => $description,
902                                    category => $LastCategory,
903                                    pubDate => $date,
904                                    guid => $guid,
905                                  };
906                    # We need XML capability for this.
907                    require XML::Simple;
908                    # The RSS document goes in here.
909                    my $rss;
910                    # Get the name of the RSS file. It's in the FIG temporary directory.
911                    my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
912                    # Open the config file and lock it.
913                    $lock = Open(undef, "<$FIG_Config::fig_disk/config/FIG_Config.pm");
914                    flock $lock, LOCK_EX;
915                    # Does it exist?
916                    if (-s $fileName) {
917                        # Slurp it in.
918                        $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
919                    } else {
920                        my $size = -s $fileName;
921                        # Create an empty channel.
922                        $rss = {
923                            channel => {
924                                title => 'NMPDR Warning Feed',
925                                link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
926                                description => "Important messages regarding the status of the NMPDR.",
927                                generator => "NMPDR Trace Facility",
928                                docs => "http://blogs.law.harvard.edu/tech/rss",
929                                item => []
930                            },
931                        };
932                    }
933                    # Get the channel object.
934                    my $channel = $rss->{channel};
935                    # Update the last-build date.
936                    $channel->{lastBuildDate} = $date;
937                    # Get the item array.
938                    my $items = $channel->{item};
939                    # Insure it has only 100 entries.
940                    while (scalar @{$items} > 100) {
941                        pop @{$items};
942                    }
943                    # Add our new item at the front.
944                    unshift @{$items}, $newItem;
945                    # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
946                    # the requirements for those.
947                    my $xml = XML::Simple::XMLout($channel, NoAttr => 1, RootName => 'channel', XmlDecl => '');
948                    # Here we put in the root and declaration. The problem is that the root has to have the version attribute
949                    # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
950                    $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
951                    # We don't use Open here because we can't afford an error.
952                    if (open XMLOUT, ">$fileName") {
953                        print XMLOUT $xml;
954                        close XMLOUT;
955                    }
956                }
957            }
958        };
959        if ($@) {
960            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
961            # (which is a good thing).
962            my $error = $@;
963            Trace("Feed Error: $error") if T(Feed => 0);
964        }
965        # Be sure to unlock.
966        if ($lock) {
967            flock $lock, LOCK_UN;
968            undef $lock;
969        }
970        # Restore the error message.
971        $@ = $savedError;
972    }
973    
974    
975    
976    
977  =head3 Assert  =head3 Assert
978    
979      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 1024 
1024      my ($message) = @_;      my ($message) = @_;
1025      # Trace what's happening.      # Trace what's happening.
1026      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
1027      my $confession = longmess($message);      # Get the stack trace.
1028      # Convert the confession to a series of trace messages.      my @trace = LongMess();
1029      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
1030          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
1031          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
1032              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
1033              # Trace the line.              # Trace the line.
1034              Trace($line);              Trace($line);
1035          }          }
1036        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
1037        Warn($message);
1038      }      }
 }  
   
 =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.  
1039    
1040  =item RETURN  =head3 LongMess
1041    
1042  Returns a two-element list consisting of a CGI query object and a variable hash for      my @lines = Tracer::LongMess();
 the output page.  
1043    
1044  =back  Return a stack trace with all tracing methods removed. The return will be in the form of a list
1045    of message strings.
1046    
1047  =cut  =cut
1048    
1049  sub ScriptSetup {  sub LongMess {
1050      # Get the parameters.      # Declare the return variable.
1051      my ($noTrace) = @_;      my @retVal = ();
1052      # Get the CGI query object.      my $confession = longmess("");
1053      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
1054      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
1055      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
1056      # Create the variable hash.              push @retVal, $line;
1057      my $varHash = { results => '' };          }
1058      # Return the query object and variable hash.      }
1059      return ($cgi, $varHash);      # Return the result.
1060        return @retVal;
1061  }  }
1062    
1063  =head3 ETracing  =head3 ETracing
1064    
1065      ETracing($parameter);      ETracing($parameter, %options);
1066    
1067  Set up emergency tracing. Emergency tracing is tracing that is turned  Set up emergency tracing. Emergency tracing is tracing that is turned
1068  on automatically for any program that calls this method. The emergency  on automatically for any program that calls this method. The emergency
# Line 782  Line 1083 
1083  is a CGI object and emergency tracing is not on, the C<Trace> and  is a CGI object and emergency tracing is not on, the C<Trace> and
1084  C<TF> parameters will be used to determine the type of tracing.  C<TF> parameters will be used to determine the type of tracing.
1085    
1086    =item options
1087    
1088    Hash of options. The permissible options are given below.
1089    
1090    =over 8
1091    
1092    =item destType
1093    
1094    Emergency tracing destination type to use if no tracing file is found. The
1095    default is C<WARN>.
1096    
1097    =item noParms
1098    
1099    If TRUE, then display of the saved CGI parms is suppressed. The default is FALSE.
1100    
1101    =item level
1102    
1103    The trace level to use if no tracing file is found. The default is C<0>.
1104    
1105    =back
1106    
1107  =back  =back
1108    
1109  =cut  =cut
1110    
1111  sub ETracing {  sub ETracing {
1112      # Get the parameter.      # Get the parameter.
1113      my ($parameter) = @_;      my ($parameter, %options) = @_;
1114      # Check for CGI mode.      # Check for CGI mode.
1115      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
1116      # Default to no tracing except errors.          $SavedCGI = $parameter;
1117      my ($tracing, $dest) = ("0", "WARN");      } else {
1118            $SavedCGI = undef;
1119        }
1120        # Check for the noParms option.
1121        my $noParms = $options{noParms} || 0;
1122        # Get the default tracing information.
1123        my $tracing = $options{level} || 0;
1124        my $dest = $options{destType} || "WARN";
1125      # Check for emergency tracing.      # Check for emergency tracing.
1126      my $tkey = EmergencyKey($parameter);      my $tkey = EmergencyKey($parameter);
1127      my $emergencyFile = EmergencyFileName($tkey);      my $emergencyFile = EmergencyFileName($tkey);
1128      if (-e $emergencyFile) {      if (-e $emergencyFile && (my $stat = stat($emergencyFile))) {
1129          # We have the file. Read in the data.          # We have the file. Read in the data.
1130          my @tracing = GetFile($emergencyFile);          my @tracing = GetFile($emergencyFile);
1131          # Pull off the time limit.          # Pull off the time limit.
# Line 804  Line 1133 
1133          # Convert it to seconds.          # Convert it to seconds.
1134          $expire *= 3600;          $expire *= 3600;
1135          # Check the file data.          # Check the file data.
         my $stat = stat($emergencyFile);  
1136          my ($now) = gettimeofday;          my ($now) = gettimeofday;
1137          if ($now - $stat->mtime > $expire) {          if ($now - $stat->mtime <= $expire) {
             # Delete the expired file.  
             unlink $emergencyFile;  
         } else {  
1138              # Emergency tracing is on. Pull off the destination and              # Emergency tracing is on. Pull off the destination and
1139              # the trace level;              # the trace level;
1140              $dest = shift @tracing;              $dest = shift @tracing;
1141              my $level = shift @tracing;              my $level = shift @tracing;
             # Convert the destination to a real tracing destination.  
             # temp directory.  
             $dest = EmergencyTracingDest($tkey, $dest);  
1142              # Insure Tracer is specified.              # Insure Tracer is specified.
1143              my %moduleHash = map { $_ => 1 } @tracing;              my %moduleHash = map { $_ => 1 } @tracing;
1144              $moduleHash{Tracer} = 1;              $moduleHash{Tracer} = 1;
1145              # Set the trace parameter.              # Set the trace parameter.
1146              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1147          }          }
     } elsif (defined $cgi) {  
         # There's no emergency tracing, but we have a CGI object, so check  
         # for tracing from the form parameters.  
         if ($cgi->param('Trace')) {  
             # Here the user has requested tracing via a form.  
             $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");  
             $tracing = $cgi->param('Trace') . " Tracer";  
         }  
1148      }      }
1149        # Convert the destination to a real tracing destination.
1150        $dest = EmergencyTracingDest($tkey, $dest);
1151      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1152      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1153      # Check to see if we're a web script.      # Check to see if we're a web script.
1154      if (defined $cgi) {      if (defined $SavedCGI) {
1155          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data if it's not suppressed.
1156          TraceParms($cgi);          if (! $noParms) {
1157                TraceParms($SavedCGI);
1158            }
1159          # 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
1160          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1161          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1029  Line 1347 
1347      my $retVal;      my $retVal;
1348      # Determine the parameter type.      # Determine the parameter type.
1349      if (! defined $parameter) {      if (! defined $parameter) {
1350          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1351          $retVal = $ENV{TRACING};          # get the effective login ID.
1352            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1353      } else {      } else {
1354          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1355          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1071  Line 1390 
1390      # Get the parameters.      # Get the parameters.
1391      my ($cgi) = @_;      my ($cgi) = @_;
1392      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1393          # 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
1394          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));          # relatively small.
1395            my $url = $cgi->url(-relative => 1, -query => 1);
1396            my $len = length($url);
1397            if ($len < 500) {
1398                Trace("[URL] $url");
1399            } elsif ($len > 2048) {
1400                Trace("[URL] URL is too long to use with GET ($len characters).");
1401            } else {
1402                Trace("[URL] URL length is $len characters.");
1403            }
1404      }      }
1405      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1406          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1147  Line 1475 
1475      }      }
1476  }  }
1477    
1478    =head2 Command-Line Utility Methods
1479    
1480  =head3 ScriptFinish (deprecated)  =head3 SendSMS
   
     ScriptFinish($webData, $varHash);  
1481    
1482  Output a web page at the end of a script. Either the string to be output or the      my $msgID = Tracer::SendSMS($phoneNumber, $msg);
 name of a template file can be specified. If the second parameter is omitted,  
 it is assumed we have a string to be output; otherwise, it is assumed we have the  
 name of a template file. The template should have the variable C<DebugData>  
 specified in any form that invokes a standard script. If debugging mode is turned  
 on, a form field will be put in that allows the user to enter tracing data.  
 Trace messages will be placed immediately before the terminal C<BODY> tag in  
 the output, formatted as a list.  
1483    
1484  A typical standard script would loook like the following.  Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
1485    user name, password, and API ID for the relevant account in the hash reference variable
1486    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
1487    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
1488    is C<2561022>, then the FIG_Config file must contain
1489    
1490      BEGIN {      $phone =  { user => 'BruceTheHumanPet',
1491          # Print the HTML header.                  password => 'silly',
1492          print "CONTENT-TYPE: text/html\n\n";                  api_id => '2561022' };
     }  
     use Tracer;  
     use CGI;  
     use FIG;  
     # ... more uses ...  
1493    
1494      my ($cgi, $varHash) = ScriptSetup();  The original purpose of this method was to insure Bruce would be notified immediately when the
1495      eval {  Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
1496          # ... get data from $cgi, put it in $varHash ...  when you call this method.
     };  
     if ($@) {  
         Trace("Script Error: $@") if T(0);  
     }  
     ScriptFinish("Html/MyTemplate.html", $varHash);  
1497    
1498  The idea here is that even if the script fails, you'll see trace messages and  The message ID will be returned if successful, and C<undef> if an error occurs.
 useful output.  
1499    
1500  =over 4  =over 4
1501    
1502  =item webData  =item phoneNumber
1503    
1504  A string containing either the full web page to be written to the output or the  Phone number to receive the message, in international format. A United States phone number
1505  name of a template file from which the page is to be constructed. If the name  would be prefixed by "1". A British phone number would be prefixed by "44".
 of a template file is specified, then the second parameter must be present;  
 otherwise, it must be absent.  
1506    
1507  =item varHash (optional)  =item msg
1508    
1509  If specified, then a reference to a hash mapping variable names for a template  Message to send to the specified phone.
1510  to their values. The template file will be read into memory, and variable markers  
1511  will be replaced by data in this hash reference.  =item RETURN
1512    
1513    Returns the message ID if successful, and C<undef> if the message could not be sent.
1514    
1515  =back  =back
1516    
1517  =cut  =cut
1518    
1519  sub ScriptFinish {  sub SendSMS {
     # Get the parameters.  
     my ($webData, $varHash) = @_;  
     # Check for a template file situation.  
     my $outputString;  
     if (defined $varHash) {  
         # Here we have a template file. We need to determine the template type.  
         my $template;  
         if ($FIG_Config::template_url && $webData =~ /\.php$/) {  
             $template = "$FIG_Config::template_url/$webData";  
         } else {  
             $template = "<<$webData";  
         }  
         $outputString = PageBuilder::Build($template, $varHash, "Html");  
     } else {  
         # Here the user gave us a raw string.  
         $outputString = $webData;  
     }  
     # Check for trace messages.  
     if ($Destination ne "NONE" && $TraceLevel > 0) {  
         # We have trace messages, so we want to put them at the end of the body. This  
         # is either at the end of the whole string or at the beginning of the BODY  
         # end-tag.  
         my $pos = length $outputString;  
         if ($outputString =~ m#</body>#gi) {  
             $pos = (pos $outputString) - 7;  
         }  
         # If the trace messages were queued, we unroll them. Otherwise, we display the  
         # destination.  
         my $traceHtml;  
         if ($Destination eq "QUEUE") {  
             $traceHtml = QTrace('Html');  
         } elsif ($Destination =~ /^>>(.+)$/) {  
             # Here the tracing output it to a file. We code it as a hyperlink so the user  
             # can copy the file name into the clipboard easily.  
             my $actualDest = $1;  
             $traceHtml = "<p>Tracing output to $actualDest.</p>\n";  
         } else {  
             # Here we have one of the special destinations.  
             $traceHtml = "<P>Tracing output type is $Destination.</p>\n";  
         }  
         substr $outputString, $pos, 0, $traceHtml;  
     }  
     # Write the output string.  
     print $outputString;  
 }  
   
 =head2 Command-Line Utility Methods  
   
 =head3 SendSMS  
   
     my $msgID = Tracer::SendSMS($phoneNumber, $msg);  
   
 Send a text message to a phone number using Clickatell. The FIG_Config file must contain the  
 user name, password, and API ID for the relevant account in the hash reference variable  
 I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For  
 example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID  
 is C<2561022>, then the FIG_Config file must contain  
   
     $phone =  { user => 'BruceTheHumanPet',  
                 password => 'silly',  
                 api_id => '2561022' };  
   
 The original purpose of this method was to insure Bruce would be notified immediately when the  
 Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately  
 when you call this method.  
   
 The message ID will be returned if successful, and C<undef> if an error occurs.  
   
 =over 4  
   
 =item phoneNumber  
   
 Phone number to receive the message, in international format. A United States phone number  
 would be prefixed by "1". A British phone number would be prefixed by "44".  
   
 =item msg  
   
 Message to send to the specified phone.  
   
 =item RETURN  
   
 Returns the message ID if successful, and C<undef> if the message could not be sent.  
   
 =back  
   
 =cut  
   
 sub SendSMS {  
1520      # Get the parameters.      # Get the parameters.
1521      my ($phoneNumber, $msg) = @_;      my ($phoneNumber, $msg) = @_;
1522      # Declare the return variable. If we do not change it, C<undef> will be returned.      # Declare the return variable. If we do not change it, C<undef> will be returned.
# Line 1454  Line 1679 
1679  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
1680  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,
1681  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
1682  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
1683    login ID.
1684    
1685    Since the default situation in StandardSetup is to trace to the standard
1686    output, errors that occur in command-line scripts will not generate
1687    RSS events. To force the events, use the C<warn> option.
1688    
1689        TransactFeatures -background -warn register ../xacts IDs.tbl
1690    
1691  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1692  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 1703 
1703          -noAlias  do not expect aliases in CHANGE transactions          -noAlias  do not expect aliases in CHANGE transactions
1704          -start    start with this genome          -start    start with this genome
1705          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
1706            -forked   do not erase the trace file before tracing
1707    
1708  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
1709  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 1767 
1767      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1768      # Get the default tracing key.      # Get the default tracing key.
1769      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1770        # Save the command line.
1771        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1772      # Add the tracing options.      # Add the tracing options.
1773      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1774          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
1775      }      }
1776        if (! exists $options->{forked}) {
1777            $options->{forked} = [0, "keep old trace file"];
1778        }
1779      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
1780      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1781      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1782      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1783        $options->{warn} = [0, "send errors to RSS feed"];
1784        $options->{moreTracing} = ["", "comma-delimited list of additional trace modules for debugging"];
1785      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1786      # contains the default values rather than the default value      # contains the default values rather than the default value
1787      # 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 1798 
1798      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
1799      # Get the logfile suffix.      # Get the logfile suffix.
1800      my $suffix = $retOptions->{user};      my $suffix = $retOptions->{user};
1801      # Check for background mode.      # We'll put the trace file name in here. We need it later if background
1802      if ($retOptions->{background}) {      # mode is on.
1803          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};  
         }  
     }  
1804      # 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
1805      # wants emergency tracing.      # wants emergency tracing.
1806      if ($retOptions->{trace} eq 'E') {      if ($retOptions->{trace} eq 'E') {
# Line 1580  Line 1811 
1811          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1812              push @cats, "SQL";              push @cats, "SQL";
1813          }          }
1814            if ($retOptions->{warn}) {
1815                push @cats, "Feed";
1816            }
1817          # Add the default categories.          # Add the default categories.
1818          push @cats, "Tracer";          push @cats, "Tracer";
1819            # Check for more tracing groups.
1820            if ($retOptions->{moreTracing}) {
1821                push @cats, split /,/, $retOptions->{moreTracing};
1822            }
1823          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
1824          my $cats = join(" ", @cats);          my $cats = join(" ", @cats);
1825          # 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 1834 
1834          my $traceMode;          my $traceMode;
1835          # Verify that we can open a file in the FIG temporary directory.          # Verify that we can open a file in the FIG temporary directory.
1836          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
1837          if (open TESTTRACE, ">$traceFileName") {          my $traceFileSpec = ($retOptions->{forked} ? ">>$traceFileName" : ">$traceFileName");
1838            if (open TESTTRACE, "$traceFileSpec") {
1839              # Here we can trace to a file.              # Here we can trace to a file.
1840              $traceMode = ">$traceFileName";              $traceMode = ">>$traceFileName";
1841              if ($textOKFlag) {              if ($textOKFlag) {
1842                  # Echo to standard output if the text-OK flag is set.                  # Echo to standard output if the text-OK flag is set.
1843                  $traceMode = "+$traceMode";                  $traceMode = "+$traceMode";
# Line 1619  Line 1858 
1858          # Now set up the tracing.          # Now set up the tracing.
1859          TSetup("$traceLevel $cats", $traceMode);          TSetup("$traceLevel $cats", $traceMode);
1860      }      }
1861        # Check for background mode.
1862        if ($retOptions->{background}) {
1863            my $outFileName = "$FIG_Config::temp/out$suffix$$.log";
1864            my $errFileName = "$FIG_Config::temp/err$suffix$$.log";
1865            # Spool the output.
1866            open STDOUT, ">$outFileName";
1867            # If we have a trace file, trace the errors to the log. Otherwise,
1868            # spool the errors.
1869            if (defined $traceFileName) {
1870                open STDERR, "| Tracer $traceFileName";
1871            } else {
1872                open STDERR, ">$errFileName";
1873            }
1874            # Check for phone support. If we have phone support and a phone number,
1875            # we want to turn it on.
1876            if ($ENV{PHONE} && defined($FIG_Config::phone)) {
1877                $retOptions->{phone} = $ENV{PHONE};
1878            }
1879        }
1880      # Check for the "help" option. If it is specified, dump the command-line      # Check for the "help" option. If it is specified, dump the command-line
1881      # options and exit the program.      # options and exit the program.
1882      if ($retOptions->{help}) {      if ($retOptions->{help}) {
# Line 1799  Line 2057 
2057      }      }
2058  }  }
2059    
2060    =head3 UnparseOptions
2061    
2062        my $optionString = Tracer::UnparseOptions(\%options);
2063    
2064    Convert an option hash into a command-line string. This will not
2065    necessarily be the same text that came in, but it will nonetheless
2066    produce the same ultimate result when parsed by L</StandardSetup>.
2067    
2068    =over 4
2069    
2070    =item options
2071    
2072    Reference to a hash of options to convert into an option string.
2073    
2074    =item RETURN
2075    
2076    Returns a string that will parse to the same set of options when
2077    parsed by L</StandardSetup>.
2078    
2079    =back
2080    
2081    =cut
2082    
2083    sub UnparseOptions {
2084        # Get the parameters.
2085        my ($options) = @_;
2086        # The option segments will be put in here.
2087        my @retVal = ();
2088        # Loop through the options.
2089        for my $key (keys %$options) {
2090            # Get the option value.
2091            my $value = $options->{$key};
2092            # Only use it if it's nonempty.
2093            if (defined $value && $value ne "") {
2094                my $segment = "--$key=$value";
2095                # Quote it if necessary.
2096                if ($segment =~ /[ |<>*]/) {
2097                    $segment = '"' . $segment . '"';
2098                }
2099                # Add it to the return list.
2100                push @retVal, $segment;
2101            }
2102        }
2103        # Return the result.
2104        return join(" ", @retVal);
2105    }
2106    
2107  =head3 ParseCommand  =head3 ParseCommand
2108    
2109      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);
# Line 2271  Line 2576 
2576          } else {          } else {
2577              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
2578          }          }
2579            closedir $dirHandle;
2580      } elsif (! $flag) {      } elsif (! $flag) {
2581          # Here the directory would not open and it's considered an error.          # Here the directory would not open and it's considered an error.
2582          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
# Line 2377  Line 2683 
2683  Map of search patterns to permission masks. If a directory name matches  Map of search patterns to permission masks. If a directory name matches
2684  one of the patterns, that directory and all its members and subdirectories  one of the patterns, that directory and all its members and subdirectories
2685  will be assigned the new pattern. For example, the following would  will be assigned the new pattern. For example, the following would
2686  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>.
2687    
2688      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2689    
# Line 2430  Line 2736 
2736                      $match = 1;                      $match = 1;
2737                  }                  }
2738              }              }
2739              # 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
2740              # before terminating due to the match.              # before terminating due to the match.
2741              if ($match && $otherMasks[$i-1] != $mask) {              if ($match && $otherMasks[$i-1] != $mask) {
2742                  # 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 2904 
2904    
2905  =head2 Other Useful Methods  =head2 Other Useful Methods
2906    
2907    =head3 IDHASH
2908    
2909        my $hash = SHTargetSearch::IDHASH(@keys);
2910    
2911    This is a dinky little method that converts a list of values to a reference
2912    to hash of values to labels. The values and labels are the same.
2913    
2914    =cut
2915    
2916    sub IDHASH {
2917        my %retVal = map { $_ => $_ } @_;
2918        return \%retVal;
2919    }
2920    
2921    =head3 Pluralize
2922    
2923        my $plural = Tracer::Pluralize($word);
2924    
2925    This is a very simple pluralization utility. It adds an C<s> at the end
2926    of the input word unless it already ends in an C<s>, in which case it
2927    adds C<es>.
2928    
2929    =over 4
2930    
2931    =item word
2932    
2933    Singular word to pluralize.
2934    
2935    =item RETURN
2936    
2937    Returns the probable plural form of the word.
2938    
2939    =back
2940    
2941    =cut
2942    
2943    sub Pluralize {
2944        # Get the parameters.
2945        my ($word) = @_;
2946        # Declare the return variable.
2947        my $retVal;
2948        if ($word =~ /s$/) {
2949            $retVal = $word . 'es';
2950        } else {
2951            $retVal = $word . 's';
2952        }
2953        # Return the result.
2954        return $retVal;
2955    }
2956    
2957    =head3 Numeric
2958    
2959        my $okFlag = Tracer::Numeric($string);
2960    
2961    Return the value of the specified string if it is numeric, or an undefined value
2962    if it is not numeric.
2963    
2964    =over 4
2965    
2966    =item string
2967    
2968    String to check.
2969    
2970    =item RETURN
2971    
2972    Returns the numeric value of the string if successful, or C<undef> if the string
2973    is not numeric.
2974    
2975    =back
2976    
2977    =cut
2978    
2979    sub Numeric {
2980        # Get the parameters.
2981        my ($string) = @_;
2982        # We'll put the value in here if we succeed.
2983        my $retVal;
2984        # Get a working copy of the string.
2985        my $copy = $string;
2986        # Trim leading and trailing spaces.
2987        $copy =~ s/^\s+//;
2988        $copy =~ s/\s+$//;
2989        # Check the result.
2990        if ($copy =~ /^[+-]?\d+$/) {
2991            $retVal = $copy;
2992        } elsif ($copy =~ /^([+-]\d+|\d*)[eE][+-]?\d+$/) {
2993            $retVal = $copy;
2994        } elsif ($copy =~ /^([+-]\d+|\d*)\.\d*([eE][+-]?\d+)?$/) {
2995            $retVal = $copy;
2996        }
2997        # Return the result.
2998        return $retVal;
2999    }
3000    
3001    
3002  =head3 ParseParm  =head3 ParseParm
3003    
3004      my $listValue = Tracer::ParseParm($string);      my $listValue = Tracer::ParseParm($string);
# Line 2840  Line 3241 
3241      return $retVal;      return $retVal;
3242  }  }
3243    
3244    =head3 In
3245    
3246        my $flag = Tracer::In($value, $min, $max);
3247    
3248    Return TRUE if the value is between the minimum and the maximum, else FALSE.
3249    
3250    =cut
3251    
3252    sub In {
3253        return ($_[0] <= $_[2] && $_[0] >= $_[1]);
3254    }
3255    
3256    
3257  =head3 Constrain  =head3 Constrain
3258    
3259      my $constrained = Constrain($value, $min, $max);      my $constrained = Constrain($value, $min, $max);
# Line 2951  Line 3365 
3365      return $retVal;      return $retVal;
3366  }  }
3367    
   
3368  =head3 Strip  =head3 Strip
3369    
3370      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
# Line 2984  Line 3397 
3397      return $retVal;      return $retVal;
3398  }  }
3399    
3400    =head3 Trim
3401    
3402        my $string = Tracer::Trim($line);
3403    
3404    Trim all spaces from the beginning and ending of a string.
3405    
3406    =over 4
3407    
3408    =item line
3409    
3410    Line of text to be trimmed.
3411    
3412    =item RETURN
3413    
3414    The same line of text with all whitespace chopped off either end.
3415    
3416    =back
3417    
3418    =cut
3419    
3420    sub Trim {
3421        # Get a copy of the parameter string.
3422        my ($string) = @_;
3423        my $retVal = (defined $string ? $string : "");
3424        # Strip the front spaces.
3425        $retVal =~ s/^\s+//;
3426        # Strip the back spaces.
3427        $retVal =~ s/\s+$//;
3428        # Return the result.
3429        return $retVal;
3430    }
3431    
3432  =head3 Pad  =head3 Pad
3433    
3434      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);
# Line 3045  Line 3490 
3490      return $retVal;      return $retVal;
3491  }  }
3492    
3493    =head3 Quoted
3494    
3495        my $string = Tracer::Quoted($var);
3496    
3497    Convert the specified value to a string and enclose it in single quotes.
3498    If it's undefined, the string C<undef> in angle brackets will be used
3499    instead.
3500    
3501    =over 4
3502    
3503    =item var
3504    
3505    Value to quote.
3506    
3507    =item RETURN
3508    
3509    Returns a string enclosed in quotes, or an indication the value is undefined.
3510    
3511    =back
3512    
3513    =cut
3514    
3515    sub Quoted {
3516        # Get the parameters.
3517        my ($var) = @_;
3518        # Declare the return variable.
3519        my $retVal;
3520        # Are we undefined?
3521        if (! defined $var) {
3522            $retVal = "<undef>";
3523        } else {
3524            # No, so convert to a string and enclose in quotes.
3525            $retVal = $var;
3526            $retVal =~ s/'/\\'/;
3527            $retVal = "'$retVal'";
3528        }
3529        # Return the result.
3530        return $retVal;
3531    }
3532    
3533  =head3 EOF  =head3 EOF
3534    
3535  This is a constant that is lexically greater than any useful string.  This is a constant that is lexically greater than any useful string.
# Line 3134  Line 3619 
3619  }  }
3620    
3621    
3622    =head3 GetMemorySize
3623    
3624        my $string = Tracer::GetMemorySize();
3625    
3626    Return a memory size string for the current process. The string will be
3627    in comma format, with a size indicator (K, M, G) at the end.
3628    
3629    =cut
3630    
3631    sub GetMemorySize {
3632        # Get the memory size from Unix.
3633        my ($retVal) = `ps h -o vsz $$`;
3634        # Remove the ending new-line.
3635        chomp $retVal;
3636        # Format and return the result.
3637        return CommaFormat($retVal) . "K";
3638    }
3639    
3640  =head3 CompareLists  =head3 CompareLists
3641    
3642      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);
# Line 3201  Line 3704 
3704      return ($inserted, $deleted);      return ($inserted, $deleted);
3705  }  }
3706    
3707  =head3 GenerateURL  =head3 Cmp
3708    
3709      my $queryUrl = Tracer::GenerateURL($page, %parameters);      my $cmp = Tracer::Cmp($a, $b);
3710    
3711  Generate a GET-style URL for the specified page with the specified parameter  This method performs a universal sort comparison. Each value coming in is
3712  names and values. The values will be URL-escaped automatically. So, for  separated into a text parts and number parts. The text
3713  example  part is string compared, and if both parts are equal, then the number
3714    parts are compared numerically. A stream of just numbers or a stream of
3715    just strings will sort correctly, and a mixed stream will sort with the
3716    numbers first. Strings with a label and a number will sort in the
3717    expected manner instead of lexically. Undefined values sort last.
3718    
3719      Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")  =over 4
3720    
3721  would return  =item a
3722    
3723    First item to compare.
3724    
3725    =item b
3726    
3727    Second item to compare.
3728    
3729    =item RETURN
3730    
3731    Returns a negative number if the first item should sort first (is less), a positive
3732    number if the first item should sort second (is greater), and a zero if the items are
3733    equal.
3734    
3735    =back
3736    
3737    =cut
3738    
3739    sub Cmp {
3740        # Get the parameters.
3741        my ($a, $b) = @_;
3742        # Declare the return value.
3743        my $retVal;
3744        # Check for nulls.
3745        if (! defined($a)) {
3746            $retVal = (! defined($b) ? 0 : -1);
3747        } elsif (! defined($b)) {
3748            $retVal = 1;
3749        } else {
3750            # Here we have two real values. Parse the two strings.
3751            my @aParsed = _Parse($a);
3752            my @bParsed = _Parse($b);
3753            # Loop through the first string.
3754            while (! $retVal && @aParsed) {
3755                # Extract the string parts.
3756                my $aPiece = shift(@aParsed);
3757                my $bPiece = shift(@bParsed) || '';
3758                # Extract the number parts.
3759                my $aNum = shift(@aParsed);
3760                my $bNum = shift(@bParsed) || 0;
3761                # Compare the string parts insensitively.
3762                $retVal = (lc($aPiece) cmp lc($bPiece));
3763                # If they're equal, compare them sensitively.
3764                if (! $retVal) {
3765                    $retVal = ($aPiece cmp $bPiece);
3766                    # If they're STILL equal, compare the number parts.
3767                    if (! $retVal) {
3768                        $retVal = $aNum <=> $bNum;
3769                    }
3770                }
3771            }
3772        }
3773        # Return the result.
3774        return $retVal;
3775    }
3776    
3777    # This method parses an input string into a string parts alternating with
3778    # number parts.
3779    sub _Parse {
3780        # Get the incoming string.
3781        my ($string) = @_;
3782        # The pieces will be put in here.
3783        my @retVal;
3784        # Loop through as many alpha/num sets as we can.
3785        while ($string =~ /^(\D*)(\d+)(.*)/) {
3786            # Push the alpha and number parts into the return string.
3787            push @retVal, $1, $2;
3788            # Save the residual.
3789            $string = $3;
3790        }
3791        # If there's still stuff left, add it to the end with a trailing
3792        # zero.
3793        if ($string) {
3794            push @retVal, $string, 0;
3795        }
3796        # Return the list.
3797        return @retVal;
3798    }
3799    
3800    =head3 ListEQ
3801    
3802        my $flag = Tracer::ListEQ(\@a, \@b);
3803    
3804    Return TRUE if the specified lists contain the same strings in the same
3805    order, else FALSE.
3806    
3807    =over 4
3808    
3809    =item a
3810    
3811    Reference to the first list.
3812    
3813    =item b
3814    
3815    Reference to the second list.
3816    
3817    =item RETURN
3818    
3819    Returns TRUE if the two parameters are identical string lists, else FALSE.
3820    
3821    =back
3822    
3823    =cut
3824    
3825    sub ListEQ {
3826        # Get the parameters.
3827        my ($a, $b) = @_;
3828        # Declare the return variable. Start by checking the lengths.
3829        my $n = scalar(@$a);
3830        my $retVal = ($n == scalar(@$b));
3831        # Now compare the list elements.
3832        for (my $i = 0; $retVal && $i < $n; $i++) {
3833            $retVal = ($a->[$i] eq $b->[$i]);
3834        }
3835        # Return the result.
3836        return $retVal;
3837    }
3838    
3839    =head2 CGI Script Utilities
3840    
3841    =head3 ScriptSetup (deprecated)
3842    
3843        my ($cgi, $varHash) = ScriptSetup($noTrace);
3844    
3845    Perform standard tracing and debugging setup for scripts. The value returned is
3846    the CGI object followed by a pre-built variable hash. At the end of the script,
3847    the client should call L</ScriptFinish> to output the web page.
3848    
3849    This method calls L</ETracing> to configure tracing, which allows the tracing
3850    to be configured via the emergency tracing form on the debugging control panel.
3851    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3852    method, which includes every program that uses this method or L</StandardSetup>.
3853    
3854    =over 4
3855    
3856    =item noTrace (optional)
3857    
3858    If specified, tracing will be suppressed. This is useful if the script wants to set up
3859    tracing manually.
3860    
3861    =item RETURN
3862    
3863    Returns a two-element list consisting of a CGI query object and a variable hash for
3864    the output page.
3865    
3866    =back
3867    
3868    =cut
3869    
3870    sub ScriptSetup {
3871        # Get the parameters.
3872        my ($noTrace) = @_;
3873        # Get the CGI query object.
3874        my $cgi = CGI->new();
3875        # Set up tracing if it's not suppressed.
3876        ETracing($cgi) unless $noTrace;
3877        # Create the variable hash.
3878        my $varHash = { results => '' };
3879        # Return the query object and variable hash.
3880        return ($cgi, $varHash);
3881    }
3882    
3883    =head3 ScriptFinish (deprecated)
3884    
3885        ScriptFinish($webData, $varHash);
3886    
3887    Output a web page at the end of a script. Either the string to be output or the
3888    name of a template file can be specified. If the second parameter is omitted,
3889    it is assumed we have a string to be output; otherwise, it is assumed we have the
3890    name of a template file. The template should have the variable C<DebugData>
3891    specified in any form that invokes a standard script. If debugging mode is turned
3892    on, a form field will be put in that allows the user to enter tracing data.
3893    Trace messages will be placed immediately before the terminal C<BODY> tag in
3894    the output, formatted as a list.
3895    
3896    A typical standard script would loook like the following.
3897    
3898        BEGIN {
3899            # Print the HTML header.
3900            print "CONTENT-TYPE: text/html\n\n";
3901        }
3902        use Tracer;
3903        use CGI;
3904        use FIG;
3905        # ... more uses ...
3906    
3907        my ($cgi, $varHash) = ScriptSetup();
3908        eval {
3909            # ... get data from $cgi, put it in $varHash ...
3910        };
3911        if ($@) {
3912            Trace("Script Error: $@") if T(0);
3913        }
3914        ScriptFinish("Html/MyTemplate.html", $varHash);
3915    
3916    The idea here is that even if the script fails, you'll see trace messages and
3917    useful output.
3918    
3919    =over 4
3920    
3921    =item webData
3922    
3923    A string containing either the full web page to be written to the output or the
3924    name of a template file from which the page is to be constructed. If the name
3925    of a template file is specified, then the second parameter must be present;
3926    otherwise, it must be absent.
3927    
3928    =item varHash (optional)
3929    
3930    If specified, then a reference to a hash mapping variable names for a template
3931    to their values. The template file will be read into memory, and variable markers
3932    will be replaced by data in this hash reference.
3933    
3934    =back
3935    
3936    =cut
3937    
3938    sub ScriptFinish {
3939        # Get the parameters.
3940        my ($webData, $varHash) = @_;
3941        # Check for a template file situation.
3942        my $outputString;
3943        if (defined $varHash) {
3944            # Here we have a template file. We need to determine the template type.
3945            my $template;
3946            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3947                $template = "$FIG_Config::template_url/$webData";
3948            } else {
3949                $template = "<<$webData";
3950            }
3951            $outputString = PageBuilder::Build($template, $varHash, "Html");
3952        } else {
3953            # Here the user gave us a raw string.
3954            $outputString = $webData;
3955        }
3956        # Check for trace messages.
3957        if ($Destination ne "NONE" && $TraceLevel > 0) {
3958            # We have trace messages, so we want to put them at the end of the body. This
3959            # is either at the end of the whole string or at the beginning of the BODY
3960            # end-tag.
3961            my $pos = length $outputString;
3962            if ($outputString =~ m#</body>#gi) {
3963                $pos = (pos $outputString) - 7;
3964            }
3965            # If the trace messages were queued, we unroll them. Otherwise, we display the
3966            # destination.
3967            my $traceHtml;
3968            if ($Destination eq "QUEUE") {
3969                $traceHtml = QTrace('Html');
3970            } elsif ($Destination =~ /^>>(.+)$/) {
3971                # Here the tracing output it to a file. We code it as a hyperlink so the user
3972                # can copy the file name into the clipboard easily.
3973                my $actualDest = $1;
3974                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3975            } else {
3976                # Here we have one of the special destinations.
3977                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3978            }
3979            substr $outputString, $pos, 0, $traceHtml;
3980        }
3981        # Write the output string.
3982        print $outputString;
3983    }
3984    
3985    =head3 GenerateURL
3986    
3987        my $queryUrl = Tracer::GenerateURL($page, %parameters);
3988    
3989    Generate a GET-style URL for the specified page with the specified parameter
3990    names and values. The values will be URL-escaped automatically. So, for
3991    example
3992    
3993        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
3994    
3995    would return
3996    
3997      form.cgi?type=1;string=%22high%20pass%22%20or%20highway      form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3998    
# Line 3335  Line 4116 
4116      return $retVal;      return $retVal;
4117  }  }
4118    
 =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;  
 }  
   
   
4119  =head3 TrackingCode  =head3 TrackingCode
4120    
4121      my $html = Tracer::TrackingCode();      my $html = Tracer::TrackingCode();
# Line 3424  Line 4146 
4146      return $retVal;      return $retVal;
4147  }  }
4148    
4149    =head3 Clean
4150    
4151        my $cleaned = Tracer::Clean($string);
4152    
4153    Clean up a string for HTML display. This not only converts special
4154    characters to HTML entity names, it also removes control characters.
4155    
4156    =over 4
4157    
4158    =item string
4159    
4160    String to convert.
4161    
4162    =item RETURN
4163    
4164    Returns the input string with anything that might disrupt an HTML literal removed. An
4165    undefined value will be converted to an empty string.
4166    
4167    =back
4168    
4169    =cut
4170    
4171    sub Clean {
4172        # Get the parameters.
4173        my ($string) = @_;
4174        # Declare the return variable.
4175        my $retVal = "";
4176        # Only proceed if the value exists.
4177        if (defined $string) {
4178            # Get the string.
4179            $retVal = $string;
4180            # Clean the control characters.
4181            $retVal =~ tr/\x00-\x1F/?/;
4182            # Escape the rest.
4183            $retVal = CGI::escapeHTML($retVal);
4184        }
4185        # Return the result.
4186        return $retVal;
4187    }
4188    
4189    =head3 SortByValue
4190    
4191        my @keys = Tracer::SortByValue(\%hash);
4192    
4193    Get a list of hash table keys sorted by hash table values.
4194    
4195    =over 4
4196    
4197    =item hash
4198    
4199    Hash reference whose keys are to be extracted.
4200    
4201    =item RETURN
4202    
4203    Returns a list of the hash keys, ordered so that the corresponding hash values
4204    are in alphabetical sequence.
4205    
4206    =back
4207    
4208    =cut
4209    
4210    sub SortByValue {
4211        # Get the parameters.
4212        my ($hash) = @_;
4213        # Sort the hash's keys using the values.
4214        my @retVal = sort { Cmp($hash->{$a}, $hash->{$b}) } keys %$hash;
4215        # Return the result.
4216        return @retVal;
4217    }
4218    
4219    =head3 GetSet
4220    
4221        my $value = Tracer::GetSet($object, $name => $newValue);
4222    
4223    Get or set the value of an object field. The object is treated as an
4224    ordinary hash reference. If a new value is specified, it is stored in the
4225    hash under the specified name and then returned. If no new value is
4226    specified, the current value is returned.
4227    
4228    =over 4
4229    
4230    =item object
4231    
4232    Reference to the hash that is to be interrogated or updated.
4233    
4234    =item name
4235    
4236    Name of the field. This is the hash key.
4237    
4238    =item newValue (optional)
4239    
4240    New value to be stored in the field. If no new value is specified, the current
4241    value of the field is returned.
4242    
4243    =item RETURN
4244    
4245    Returns the value of the named field in the specified hash.
4246    
4247    =back
4248    
4249    =cut
4250    
4251    sub GetSet {
4252        # Get the parameters.
4253        my ($object, $name, $newValue) = @_;
4254        # Is a new value specified?
4255        if (defined $newValue) {
4256            # Yes, so store it.
4257            $object->{$name} = $newValue;
4258        }
4259        # Return the result.
4260        return $object->{$name};
4261    }
4262    
4263  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3