[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.112, Wed Oct 1 03:23:40 2008 UTC
# Line 20  Line 20 
20    
21      require Exporter;      require Exporter;
22      @ISA = ('Exporter');      @ISA = ('Exporter');
23      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency Warn);
24      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);
25      use strict;      use strict;
26      use Carp qw(longmess croak carp);      use Carp qw(longmess croak carp);
# Line 36  Line 36 
36      use Time::HiRes 'gettimeofday';      use Time::HiRes 'gettimeofday';
37      use URI::Escape;      use URI::Escape;
38      use Time::Local;      use Time::Local;
39        use POSIX qw(strftime);
40        use Time::Zone;
41        use Fcntl qw(:DEFAULT :flock);
42    
43    
44  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
45    
# Line 204  Line 208 
208  my $LastLevel = 0;          # level of the last test call  my $LastLevel = 0;          # level of the last test call
209  my $SetupCount = 0;         # number of times TSetup called  my $SetupCount = 0;         # number of times TSetup called
210  my $AllTrace = 0;           # TRUE if we are tracing all categories.  my $AllTrace = 0;           # TRUE if we are tracing all categories.
211    my $SavedCGI;               # CGI object passed to ETracing
212    my $CommandLine;            # Command line passed to StandardSetup
213    umask 2;                    # Fix the damn umask so everything is group-writable.
214    
215  =head2 Tracing Methods  =head2 Tracing Methods
216    
# Line 486  Line 493 
493      } elsif ($Destination =~ m/^>>/) {      } elsif ($Destination =~ m/^>>/) {
494          # Write the trace message to an output file.          # Write the trace message to an output file.
495          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";          open(TRACING, $Destination) || die "Tracing open for \"$Destination\" failed: $!";
496            # Lock the file.
497            flock TRACING, LOCK_EX;
498          print TRACING "$formatted\n";          print TRACING "$formatted\n";
499          close TRACING;          close TRACING;
500          # If the Tee flag is on, echo it to the standard output.          # If the Tee flag is on, echo it to the standard output.
# Line 553  Line 562 
562          $LastLevel = $traceLevel;          $LastLevel = $traceLevel;
563          # Convert it to lower case before we hash it.          # Convert it to lower case before we hash it.
564          $category = lc $category;          $category = lc $category;
565          # Use the category and tracelevel to compute the result.          # Validate the trace level.
566          if (ref $traceLevel) {          if (ref $traceLevel) {
567              Confess("Bad trace level.");              Confess("Bad trace level.");
568          } elsif (ref $TraceLevel) {          } elsif (ref $TraceLevel) {
569              Confess("Bad trace config.");              Confess("Bad trace config.");
570          }          }
571          $retVal = ($traceLevel <= $TraceLevel && ($AllTrace || exists $Categories{$category}));          # Make the check. Note that level 0 shows even if the category is turned off.
572            $retVal = ($traceLevel <= $TraceLevel && ($traceLevel == 0 || $AllTrace || exists $Categories{$category}));
573      }      }
574      # Return the computed result.      # Return the computed result.
575      return $retVal;      return $retVal;
# Line 654  Line 664 
664      croak(">>> $message");      croak(">>> $message");
665  }  }
666    
667    =head3 SaveCGI
668    
669        Tracer::SaveCGI($cgi);
670    
671    This method saves the CGI object but does not activate emergency tracing.
672    It is used to allow L</Warn> to work in situations where emergency
673    tracing is contra-indicated (e.g. the wiki).
674    
675    =over 4
676    
677    =item cgi
678    
679    Active CGI query object.
680    
681    =back
682    
683    =cut
684    
685    sub SaveCGI {
686        $SavedCGI = $_[0];
687    }
688    
689    =head3 Warn
690    
691        Warn($message, @options);
692    
693    This method traces an important message. If an RSS feed is configured
694    (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
695    then the message will be echoed to the feed. In general, a tracing
696    destination of C<WARN> indicates that the caller is running as a web
697    service in a production environment; however, this is not a requirement.
698    
699    To force warnings into the RSS feed even when the tracing destination
700    is not C<WARN>, simply specify the C<Feed> tracing module. This can be
701    configured automatically when L</StandardSetup> is used.
702    
703    The L</Cluck> method calls this one for its final message. Since
704    L</Confess> calls L</Cluck>, this means that any error which is caught
705    and confessed will put something in the feed. This insures that someone
706    will be alerted relatively quickly when a failure occurs.
707    
708    =over 4
709    
710    =item message
711    
712    Message to be traced.
713    
714    =item options
715    
716    A list containing zero or more options.
717    
718    =back
719    
720    The permissible options are as follows.
721    
722    =over 4
723    
724    =item noStack
725    
726    If specified, then the stack trace is not included in the output.
727    
728    =back
729    
730    =cut
731    
732    sub Warn {
733        # Get the parameters.
734        my $message = shift @_;
735        my %options = map { $_ => 1 } @_;
736        # Save $@;
737        my $savedError = $@;
738        # Trace the message.
739        Trace($message);
740        # This will contain the lock handle. If it's defined, it means we need to unlock.
741        my $lock;
742        # Check for feed forcing.
743        my $forceFeed = exists $Categories{feed};
744        # An error here would be disastrous. Note that if debug mode is specified,
745        # we do this stuff even in a test environment.
746        eval {
747            # Do we need to put this in the RSS feed?
748            if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
749                # Probably. We need to check first, however, to see if it's from an
750                # ignored IP. For non-CGI situations, we default the IP to the self-referent.
751                my $key = "127.0.0.1";
752                if (defined $SavedCGI) {
753                    # Get the IP address.
754                    $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};
755                }
756                # Is the IP address in the ignore list?
757                my $found = scalar(grep { $_ eq $key } @FIG_Config::error_ignore_ips);
758                if (! $found) {
759                    # No. We're good. We now need to compute the date, the link, and the title.
760                    # First, the date, in a very specific format.
761                    my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
762                        (tz_local_offset() / 30);
763                    # Environment data goes in here. We start with the date.
764                    my $environment = "$date.  ";
765                    # If we need to recap the message (because it's too long to be a title), we'll
766                    # put it in here.
767                    my $recap;
768                    # Copy the message and remove excess space.
769                    my $title = $message;
770                    $title =~ s/\s+/ /gs;
771                    # If it's too long, we have to split it up.
772                    if (length $title > 60) {
773                        # Put the full message in the environment string.
774                        $recap = $title;
775                        # Excerpt it as the title.
776                        $title = substr($title, 0, 50) . "...";
777                    }
778                    # If we have a CGI object, then this is a web error. Otherwise, it's
779                    # command-line.
780                    if (defined $SavedCGI) {
781                        # We're in a web service. The environment is the user's IP, and the link
782                        # is the URL that got us here.
783                        $environment .= "Event Reported at IP address $key process $$.";
784                        my $url = $SavedCGI->self_url();
785                        # We need the user agent string and (if available) the referrer.
786                        # The referrer will be the link.
787                        $environment .= " User Agent $ENV{HTTP_USER_AGENT}";
788                        if ($ENV{HTTP_REFERER}) {
789                            my $link = $ENV{HTTP_REFERER};
790                            $environment .= " referred from <a href=\"$link\">$link</a>.";
791                        } else {
792                            $environment .= " referrer unknown.";
793                        }
794                        # Close off the sentence with the original link.
795                        $environment .= " URL of event is <a href=\"$url\">$url</a>.";
796                    } else {
797                        # No CGI object, so we're a command-line tool. Use the tracing
798                        # key and the PID as the user identifier, and add the command.
799                        my $key = EmergencyKey();
800                        $environment .= "Event Reported by $key process $$.";
801                        if ($CommandLine) {
802                            # We're in a StandardSetup script, so we have the real command line.
803                            $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
804                        } elsif ($ENV{_}) {
805                            # We're in a BASH script, so the command has been stored in the _ variable.
806                            $environment .= "  Command = " . CGI::escapeHTML($ENV{_}) . "\n";
807                        }
808                    }
809                    # Build a GUID. We use the current time, the title, and the process ID,
810                    # then digest the result.
811                    my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
812                    # Finally, the description. This is a stack trace plus various environmental stuff.
813                    # The trace is optional.
814                    my $stackTrace;
815                    if ($options{noStack}) {
816                        $stackTrace = "";
817                    } else {
818                        my @trace = LongMess();
819                        # Only proceed if we got something back.
820                        if (scalar(@trace) > 0) {
821                            $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
822                            $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");
823                        }
824                    }
825                    # We got the stack trace. Now it's time to put it all together.
826                    # We have a goofy thing here in that we need to HTML-escape some sections of the description
827                    # twice. They will be escaped once here, and then once when written by XML::Simple. They are
828                    # unescaped once when processed by the RSS reader, and stuff in the description is treated as
829                    # HTML. So, anything escaped here is treated as a literal when viewed in the RSS reader, but
830                    # our <br>s and <pre>s are used to format the description.
831                    $recap = (defined $recap ? "<em>" . CGI::escapeHTML($recap) . "</em><br /><br />" : "");
832                    my $description = "$recap$environment  $stackTrace";
833                    # Okay, we have all the pieces. Create a hash of the new event.
834                    my $newItem = { title => $title,
835                                    description => $description,
836                                    category => $LastCategory,
837                                    pubDate => $date,
838                                    guid => $guid,
839                                  };
840                    # We need XML capability for this.
841                    require XML::Simple;
842                    # The RSS document goes in here.
843                    my $rss;
844                    # Get the name of the RSS file. It's in the FIG temporary directory.
845                    my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";
846                    # Open the config file and lock it.
847                    $lock = Open(undef, "<$FIG_Config::fig_disk/config/FIG_Config.pm");
848                    flock $lock, LOCK_EX;
849                    # Does it exist?
850                    if (-s $fileName) {
851                        # Slurp it in.
852                        $rss = XML::Simple::XMLin($fileName, ForceArray => ['item']);
853                    } else {
854                        my $size = -s $fileName;
855                        # Create an empty channel.
856                        $rss = {
857                            channel => {
858                                title => 'NMPDR Warning Feed',
859                                link => "$FIG_Config::temp_url/$FIG_Config::error_feed",
860                                description => "Important messages regarding the status of the NMPDR.",
861                                generator => "NMPDR Trace Facility",
862                                docs => "http://blogs.law.harvard.edu/tech/rss",
863                                item => []
864                            },
865                        };
866                    }
867                    # Get the channel object.
868                    my $channel = $rss->{channel};
869                    # Update the last-build date.
870                    $channel->{lastBuildDate} = $date;
871                    # Get the item array.
872                    my $items = $channel->{item};
873                    # Insure it has only 100 entries.
874                    while (scalar @{$items} > 100) {
875                        pop @{$items};
876                    }
877                    # Add our new item at the front.
878                    unshift @{$items}, $newItem;
879                    # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
880                    # the requirements for those.
881                    my $xml = XML::Simple::XMLout($channel, NoAttr => 1, RootName => 'channel', XmlDecl => '');
882                    # Here we put in the root and declaration. The problem is that the root has to have the version attribute
883                    # in it. So, we suppress the root and do it by hand, and that requires suppressing the declaration, too.
884                    $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
885                    # We don't use Open here because we can't afford an error.
886                    if (open XMLOUT, ">$fileName") {
887                        print XMLOUT $xml;
888                        close XMLOUT;
889                    }
890                }
891            }
892        };
893        if ($@) {
894            # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
895            # (which is a good thing).
896            my $error = $@;
897            Trace("Feed Error: $error") if T(Feed => 0);
898        }
899        # Be sure to unlock.
900        if ($lock) {
901            flock $lock, LOCK_UN;
902            undef $lock;
903        }
904        # Restore the error message.
905        $@ = $savedError;
906    }
907    
908    
909    
910    
911  =head3 Assert  =head3 Assert
912    
913      Assert($condition1, $condition2, ... $conditionN);      Assert($condition1, $condition2, ... $conditionN);
# Line 704  Line 958 
958      my ($message) = @_;      my ($message) = @_;
959      # Trace what's happening.      # Trace what's happening.
960      Trace("Stack trace for event: $message");      Trace("Stack trace for event: $message");
961      my $confession = longmess($message);      # Get the stack trace.
962      # Convert the confession to a series of trace messages.      my @trace = LongMess();
963      for my $line (split /\s*\n/, $confession) {      # Convert the trace to a series of messages.
964          # Only proceed if this call trace is for a method outside Tracer itself.      for my $line (@trace) {
965          if ($line !~ /Tracer\.pm/) {          # Replace the tab at the beginning with spaces.
966              # Replace the leading tab with a series of spaces.          $line =~ s/^\t/    /;
             $line =~ s/\t/    /;  
967              # Trace the line.              # Trace the line.
968              Trace($line);              Trace($line);
969          }          }
970        # Issue a warning. This displays the event message and inserts it into the RSS error feed.
971        Warn($message);
972      }      }
 }  
   
 =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.  
973    
974  =item RETURN  =head3 LongMess
975    
976  Returns a two-element list consisting of a CGI query object and a variable hash for      my @lines = Tracer::LongMess();
 the output page.  
977    
978  =back  Return a stack trace with all tracing methods removed. The return will be in the form of a list
979    of message strings.
980    
981  =cut  =cut
982    
983  sub ScriptSetup {  sub LongMess {
984      # Get the parameters.      # Declare the return variable.
985      my ($noTrace) = @_;      my @retVal = ();
986      # Get the CGI query object.      my $confession = longmess("");
987      my $cgi = CGI->new();      for my $line (split /\s*\n/, $confession) {
988      # Set up tracing if it's not suppressed.          unless ($line =~ /Tracer\.pm/) {
989      ETracing($cgi) unless $noTrace;              # Here we have a line worth keeping. Push it onto the result list.
990      # Create the variable hash.              push @retVal, $line;
991      my $varHash = { results => '' };          }
992      # Return the query object and variable hash.      }
993      return ($cgi, $varHash);      # Return the result.
994        return @retVal;
995  }  }
996    
997  =head3 ETracing  =head3 ETracing
# Line 790  Line 1025 
1025      # Get the parameter.      # Get the parameter.
1026      my ($parameter) = @_;      my ($parameter) = @_;
1027      # Check for CGI mode.      # Check for CGI mode.
1028      my $cgi = (ref $parameter eq 'CGI' ? $parameter : undef);      if (defined $parameter && ref $parameter eq 'CGI') {
1029            $SavedCGI = $parameter;
1030        } else {
1031            $SavedCGI = undef;
1032        }
1033      # Default to no tracing except errors.      # Default to no tracing except errors.
1034      my ($tracing, $dest) = ("0", "WARN");      my ($tracing, $dest) = ("0", "WARN");
1035      # Check for emergency tracing.      # Check for emergency tracing.
# Line 823  Line 1062 
1062              # Set the trace parameter.              # Set the trace parameter.
1063              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1064          }          }
1065      } elsif (defined $cgi) {      } elsif (defined $SavedCGI) {
1066          # There's no emergency tracing, but we have a CGI object, so check          # There's no emergency tracing, but we have a CGI object, so check
1067          # for tracing from the form parameters.          # for tracing from the form parameters.
1068          if ($cgi->param('Trace')) {          if ($SavedCGI->param('Trace')) {
1069              # Here the user has requested tracing via a form.              # Here the user has requested tracing via a form.
1070              $dest = ($cgi->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");              $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1071              $tracing = $cgi->param('Trace') . " Tracer";              $tracing = $SavedCGI->param('Trace') . " Tracer";
1072          }          }
1073      }      }
1074      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1075      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1076      # Check to see if we're a web script.      # Check to see if we're a web script.
1077      if (defined $cgi) {      if (defined $SavedCGI) {
1078          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data.
1079          TraceParms($cgi);          TraceParms($SavedCGI);
1080          # Check for RAW mode. In raw mode, we print a fake header so that we see everything          # Check for RAW mode. In raw mode, we print a fake header so that we see everything
1081          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1082          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1029  Line 1268 
1268      my $retVal;      my $retVal;
1269      # Determine the parameter type.      # Determine the parameter type.
1270      if (! defined $parameter) {      if (! defined $parameter) {
1271          # Here we're supposed to check the environment.          # Here we're supposed to check the environment. If that fails, we
1272          $retVal = $ENV{TRACING};          # get the effective login ID.
1273            $retVal = $ENV{TRACING} || scalar getpwuid($<);
1274      } else {      } else {
1275          my $ptype = ref $parameter;          my $ptype = ref $parameter;
1276          if ($ptype eq 'CGI') {          if ($ptype eq 'CGI') {
# Line 1147  Line 1387 
1387      }      }
1388  }  }
1389    
   
 =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;  
 }  
   
1390  =head2 Command-Line Utility Methods  =head2 Command-Line Utility Methods
1391    
1392  =head3 SendSMS  =head3 SendSMS
# Line 1454  Line 1591 
1591  Specifying a value of C<E> for the trace level causes emergency tracing to  Specifying a value of C<E> for the trace level causes emergency tracing to
1592  be used instead of custom tracing. If the user name is not specified,  be used instead of custom tracing. If the user name is not specified,
1593  the tracing key is taken from the C<Tracing> environment variable. If there  the tracing key is taken from the C<Tracing> environment variable. If there
1594  is no value for that variable, the tracing key will be computed from the PID.  is no value for that variable, the tracing key will be computed from the active
1595    login ID.
1596    
1597    Since the default situation in StandardSetup is to trace to the standard
1598    output, errors that occur in command-line scripts will not generate
1599    RSS events. To force the events, use the C<warn> option.
1600    
1601        TransactFeatures -background -warn register ../xacts IDs.tbl
1602    
1603  Finally, if the special option C<-help> is specified, the option  Finally, if the special option C<-help> is specified, the option
1604  names will be traced at level 0 and the program will exit without processing.  names will be traced at level 0 and the program will exit without processing.
# Line 1471  Line 1615 
1615          -noAlias  do not expect aliases in CHANGE transactions          -noAlias  do not expect aliases in CHANGE transactions
1616          -start    start with this genome          -start    start with this genome
1617          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
1618            -forked   do not erase the trace file before tracing
1619    
1620  The caller has the option of modifying the tracing scheme by placing a value  The caller has the option of modifying the tracing scheme by placing a value
1621  for C<trace> in the incoming options hash. The default value can be overridden,  for C<trace> in the incoming options hash. The default value can be overridden,
# Line 1534  Line 1679 
1679      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
1680      # Get the default tracing key.      # Get the default tracing key.
1681      my $tkey = EmergencyKey();      my $tkey = EmergencyKey();
1682        # Save the command line.
1683        $CommandLine = join(" ", $0, map { $_ =~ /\s/ ? "\"$_\"" : $_ } @argv);
1684      # Add the tracing options.      # Add the tracing options.
1685      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1686          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
1687      }      }
1688        if (! exists $options->{forked}) {
1689            $options->{forked} = [0, "keep old trace file"];
1690        }
1691      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
1692      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1693      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1694      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1695        $options->{warn} = [0, "send errors to RSS feed"];
1696      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1697      # contains the default values rather than the default value      # contains the default values rather than the default value
1698      # 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 1560  Line 1711 
1711      my $suffix = $retOptions->{user};      my $suffix = $retOptions->{user};
1712      # Check for background mode.      # Check for background mode.
1713      if ($retOptions->{background}) {      if ($retOptions->{background}) {
1714          my $outFileName = "$FIG_Config::temp/out$suffix.log";          my $outFileName = "$FIG_Config::temp/out$suffix$$.log";
1715          my $errFileName = "$FIG_Config::temp/err$suffix.log";          my $errFileName = "$FIG_Config::temp/err$suffix$$.log";
1716          open STDOUT, ">$outFileName";          open STDOUT, ">$outFileName";
1717          open STDERR, ">$errFileName";          open STDERR, ">$errFileName";
1718          # Check for phone support. If we have phone support and a phone number,          # Check for phone support. If we have phone support and a phone number,
# Line 1580  Line 1731 
1731          if ($retOptions->{sql}) {          if ($retOptions->{sql}) {
1732              push @cats, "SQL";              push @cats, "SQL";
1733          }          }
1734            if ($retOptions->{warn}) {
1735                push @cats, "Feed";
1736            }
1737          # Add the default categories.          # Add the default categories.
1738          push @cats, "Tracer";          push @cats, "Tracer";
1739          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
# Line 1596  Line 1750 
1750          my $traceMode;          my $traceMode;
1751          # Verify that we can open a file in the FIG temporary directory.          # Verify that we can open a file in the FIG temporary directory.
1752          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
1753          if (open TESTTRACE, ">$traceFileName") {          my $traceFileSpec = ($retOptions->{forked} ? ">>$traceFileName" : ">$traceFileName");
1754            if (open TESTTRACE, "$traceFileSpec") {
1755              # Here we can trace to a file.              # Here we can trace to a file.
1756              $traceMode = ">$traceFileName";              $traceMode = ">>$traceFileName";
1757              if ($textOKFlag) {              if ($textOKFlag) {
1758                  # Echo to standard output if the text-OK flag is set.                  # Echo to standard output if the text-OK flag is set.
1759                  $traceMode = "+$traceMode";                  $traceMode = "+$traceMode";
# Line 1799  Line 1954 
1954      }      }
1955  }  }
1956    
1957    =head3 UnparseOptions
1958    
1959        my $optionString = Tracer::UnparseOptions(\%options);
1960    
1961    Convert an option hash into a command-line string. This will not
1962    necessarily be the same text that came in, but it will nonetheless
1963    produce the same ultimate result when parsed by L</StandardSetup>.
1964    
1965    =over 4
1966    
1967    =item options
1968    
1969    Reference to a hash of options to convert into an option string.
1970    
1971    =item RETURN
1972    
1973    Returns a string that will parse to the same set of options when
1974    parsed by L</StandardSetup>.
1975    
1976    =back
1977    
1978    =cut
1979    
1980    sub UnparseOptions {
1981        # Get the parameters.
1982        my ($options) = @_;
1983        # The option segments will be put in here.
1984        my @retVal = ();
1985        # Loop through the options.
1986        for my $key (keys %$options) {
1987            # Get the option value.
1988            my $value = $options->{$key};
1989            # Only use it if it's nonempty.
1990            if (defined $value && $value ne "") {
1991                my $segment = "--$key=$value";
1992                # Quote it if necessary.
1993                if ($segment =~ /[ |<>*]/) {
1994                    $segment = '"' . $segment . '"';
1995                }
1996                # Add it to the return list.
1997                push @retVal, $segment;
1998            }
1999        }
2000        # Return the result.
2001        return join(" ", @retVal);
2002    }
2003    
2004  =head3 ParseCommand  =head3 ParseCommand
2005    
2006      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);
# Line 2377  Line 2579 
2579  Map of search patterns to permission masks. If a directory name matches  Map of search patterns to permission masks. If a directory name matches
2580  one of the patterns, that directory and all its members and subdirectories  one of the patterns, that directory and all its members and subdirectories
2581  will be assigned the new pattern. For example, the following would  will be assigned the new pattern. For example, the following would
2582  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>.
2583    
2584      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2585    
# Line 2430  Line 2632 
2632                      $match = 1;                      $match = 1;
2633                  }                  }
2634              }              }
2635              # 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
2636              # before terminating due to the match.              # before terminating due to the match.
2637              if ($match && $otherMasks[$i-1] != $mask) {              if ($match && $otherMasks[$i-1] != $mask) {
2638                  # This directory matches one of the incoming patterns, and it's                  # This directory matches one of the incoming patterns, and it's
# Line 2951  Line 3153 
3153      return $retVal;      return $retVal;
3154  }  }
3155    
   
3156  =head3 Strip  =head3 Strip
3157    
3158      my $string = Tracer::Strip($line);      my $string = Tracer::Strip($line);
# Line 3201  Line 3402 
3402      return ($inserted, $deleted);      return ($inserted, $deleted);
3403  }  }
3404    
3405  =head3 GenerateURL  =head3 Cmp
3406    
3407      my $queryUrl = Tracer::GenerateURL($page, %parameters);      my $cmp = Tracer::Cmp($a, $b);
3408    
3409  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
3410  names and values. The values will be URL-escaped automatically. So, for  separated into a leading text part and a trailing number part. The text
3411  example  part is string compared, and if both parts are equal, then the number
3412    parts are compared numerically. A stream of just numbers or a stream of
3413    just strings will sort correctly, and a mixed stream will sort with the
3414    numbers first. Strings with a label and a number will sort in the
3415    expected manner instead of lexically.
3416    
3417      Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")  =over 4
3418    
3419  would return  =item a
3420    
3421      form.cgi?type=1;string=%22high%20pass%22%20or%20highway  First item to compare.
3422    
3423  =over 4  =item b
3424    
3425    Second item to compare.
3426    
3427    =item RETURN
3428    
3429    Returns a negative number if the first item should sort first (is less), a positive
3430    number if the first item should sort second (is greater), and a zero if the items are
3431    equal.
3432    
3433    =back
3434    
3435    =cut
3436    
3437    sub Cmp {
3438        # Get the parameters.
3439        my ($a, $b) = @_;
3440        # Declare the return value.
3441        my $retVal;
3442        # Check for nulls.
3443        if (! defined($a)) {
3444            $retVal = (! defined($b) ? 0 : -1);
3445        } elsif (! defined($b)) {
3446            $retVal = 1;
3447        } else {
3448            # Here we have two real values. Parse the two strings.
3449            $a =~ /^(\D*)(\d*)$/;
3450            my $aParsed = [$1, $2];
3451            $b =~ /^(\D*)(\d*)$/;
3452            my $bParsed = [$1, $2];
3453            # Compare the string parts.
3454            $retVal = $aParsed->[0] cmp $bParsed->[0];
3455            if (! $retVal) {
3456                $retVal = $aParsed->[1] <=> $bParsed->[1];
3457            }
3458        }
3459        # Return the result.
3460        return $retVal;
3461    }
3462    
3463    =head3 ListEQ
3464    
3465        my $flag = Tracer::ListEQ(\@a, \@b);
3466    
3467    Return TRUE if the specified lists contain the same strings in the same
3468    order, else FALSE.
3469    
3470    =over 4
3471    
3472    =item a
3473    
3474    Reference to the first list.
3475    
3476    =item b
3477    
3478    Reference to the second list.
3479    
3480    =item RETURN
3481    
3482    Returns TRUE if the two parameters are identical string lists, else FALSE.
3483    
3484    =back
3485    
3486    =cut
3487    
3488    sub ListEQ {
3489        # Get the parameters.
3490        my ($a, $b) = @_;
3491        # Declare the return variable. Start by checking the lengths.
3492        my $n = scalar(@$a);
3493        my $retVal = ($n == scalar(@$b));
3494        # Now compare the list elements.
3495        for (my $i = 0; $retVal && $i < $n; $i++) {
3496            $retVal = ($a->[$i] eq $b->[$i]);
3497        }
3498        # Return the result.
3499        return $retVal;
3500    }
3501    
3502    =head2 CGI Script Utilities
3503    
3504    =head3 ScriptSetup (deprecated)
3505    
3506        my ($cgi, $varHash) = ScriptSetup($noTrace);
3507    
3508    Perform standard tracing and debugging setup for scripts. The value returned is
3509    the CGI object followed by a pre-built variable hash. At the end of the script,
3510    the client should call L</ScriptFinish> to output the web page.
3511    
3512    This method calls L</ETracing> to configure tracing, which allows the tracing
3513    to be configured via the emergency tracing form on the debugging control panel.
3514    Tracing will then be turned on automatically for all programs that use the L</ETracing>
3515    method, which includes every program that uses this method or L</StandardSetup>.
3516    
3517    =over 4
3518    
3519    =item noTrace (optional)
3520    
3521    If specified, tracing will be suppressed. This is useful if the script wants to set up
3522    tracing manually.
3523    
3524    =item RETURN
3525    
3526    Returns a two-element list consisting of a CGI query object and a variable hash for
3527    the output page.
3528    
3529    =back
3530    
3531    =cut
3532    
3533    sub ScriptSetup {
3534        # Get the parameters.
3535        my ($noTrace) = @_;
3536        # Get the CGI query object.
3537        my $cgi = CGI->new();
3538        # Set up tracing if it's not suppressed.
3539        ETracing($cgi) unless $noTrace;
3540        # Create the variable hash.
3541        my $varHash = { results => '' };
3542        # Return the query object and variable hash.
3543        return ($cgi, $varHash);
3544    }
3545    
3546    =head3 ScriptFinish (deprecated)
3547    
3548        ScriptFinish($webData, $varHash);
3549    
3550    Output a web page at the end of a script. Either the string to be output or the
3551    name of a template file can be specified. If the second parameter is omitted,
3552    it is assumed we have a string to be output; otherwise, it is assumed we have the
3553    name of a template file. The template should have the variable C<DebugData>
3554    specified in any form that invokes a standard script. If debugging mode is turned
3555    on, a form field will be put in that allows the user to enter tracing data.
3556    Trace messages will be placed immediately before the terminal C<BODY> tag in
3557    the output, formatted as a list.
3558    
3559    A typical standard script would loook like the following.
3560    
3561        BEGIN {
3562            # Print the HTML header.
3563            print "CONTENT-TYPE: text/html\n\n";
3564        }
3565        use Tracer;
3566        use CGI;
3567        use FIG;
3568        # ... more uses ...
3569    
3570        my ($cgi, $varHash) = ScriptSetup();
3571        eval {
3572            # ... get data from $cgi, put it in $varHash ...
3573        };
3574        if ($@) {
3575            Trace("Script Error: $@") if T(0);
3576        }
3577        ScriptFinish("Html/MyTemplate.html", $varHash);
3578    
3579    The idea here is that even if the script fails, you'll see trace messages and
3580    useful output.
3581    
3582    =over 4
3583    
3584    =item webData
3585    
3586    A string containing either the full web page to be written to the output or the
3587    name of a template file from which the page is to be constructed. If the name
3588    of a template file is specified, then the second parameter must be present;
3589    otherwise, it must be absent.
3590    
3591    =item varHash (optional)
3592    
3593    If specified, then a reference to a hash mapping variable names for a template
3594    to their values. The template file will be read into memory, and variable markers
3595    will be replaced by data in this hash reference.
3596    
3597    =back
3598    
3599    =cut
3600    
3601    sub ScriptFinish {
3602        # Get the parameters.
3603        my ($webData, $varHash) = @_;
3604        # Check for a template file situation.
3605        my $outputString;
3606        if (defined $varHash) {
3607            # Here we have a template file. We need to determine the template type.
3608            my $template;
3609            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
3610                $template = "$FIG_Config::template_url/$webData";
3611            } else {
3612                $template = "<<$webData";
3613            }
3614            $outputString = PageBuilder::Build($template, $varHash, "Html");
3615        } else {
3616            # Here the user gave us a raw string.
3617            $outputString = $webData;
3618        }
3619        # Check for trace messages.
3620        if ($Destination ne "NONE" && $TraceLevel > 0) {
3621            # We have trace messages, so we want to put them at the end of the body. This
3622            # is either at the end of the whole string or at the beginning of the BODY
3623            # end-tag.
3624            my $pos = length $outputString;
3625            if ($outputString =~ m#</body>#gi) {
3626                $pos = (pos $outputString) - 7;
3627            }
3628            # If the trace messages were queued, we unroll them. Otherwise, we display the
3629            # destination.
3630            my $traceHtml;
3631            if ($Destination eq "QUEUE") {
3632                $traceHtml = QTrace('Html');
3633            } elsif ($Destination =~ /^>>(.+)$/) {
3634                # Here the tracing output it to a file. We code it as a hyperlink so the user
3635                # can copy the file name into the clipboard easily.
3636                my $actualDest = $1;
3637                $traceHtml = "<p>Tracing output to $actualDest.</p>\n";
3638            } else {
3639                # Here we have one of the special destinations.
3640                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
3641            }
3642            substr $outputString, $pos, 0, $traceHtml;
3643        }
3644        # Write the output string.
3645        print $outputString;
3646    }
3647    
3648    =head3 GenerateURL
3649    
3650        my $queryUrl = Tracer::GenerateURL($page, %parameters);
3651    
3652    Generate a GET-style URL for the specified page with the specified parameter
3653    names and values. The values will be URL-escaped automatically. So, for
3654    example
3655    
3656        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
3657    
3658    would return
3659    
3660        form.cgi?type=1;string=%22high%20pass%22%20or%20highway
3661    
3662    =over 4
3663    
3664  =item page  =item page
3665    
# Line 3335  Line 3779 
3779      return $retVal;      return $retVal;
3780  }  }
3781    
 =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;  
 }  
   
   
3782  =head3 TrackingCode  =head3 TrackingCode
3783    
3784      my $html = Tracer::TrackingCode();      my $html = Tracer::TrackingCode();
# Line 3424  Line 3809 
3809      return $retVal;      return $retVal;
3810  }  }
3811    
3812    =head3 Clean
3813    
3814        my $cleaned = Tracer::Clean($string);
3815    
3816    Clean up a string for HTML display. This not only converts special
3817    characters to HTML entity names, it also removes control characters.
3818    
3819    =over 4
3820    
3821    =item string
3822    
3823    String to convert.
3824    
3825    =item RETURN
3826    
3827    Returns the input string with anything that might disrupt an HTML literal removed. An
3828    undefined value will be converted to an empty string.
3829    
3830    =back
3831    
3832    =cut
3833    
3834    sub Clean {
3835        # Get the parameters.
3836        my ($string) = @_;
3837        # Declare the return variable.
3838        my $retVal = "";
3839        # Only proceed if the value exists.
3840        if (defined $string) {
3841            # Get the string.
3842            $retVal = $string;
3843            # Clean the control characters.
3844            $retVal =~ tr/\x00-\x1F/?/;
3845            # Escape the rest.
3846            $retVal = CGI::escapeHTML($retVal);
3847        }
3848        # Return the result.
3849        return $retVal;
3850    }
3851    
3852    
3853    
3854    
3855  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3