[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.105, Wed May 14 09:09:25 2008 UTC revision 1.128, Wed Dec 16 20:57:35 2009 UTC
# Line 18  Line 18 
18    
19  package Tracer;  package Tracer;
20    
     require Exporter;  
     @ISA = ('Exporter');  
     @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency Warn);  
     @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape PrintLine PutLine);  
21      use strict;      use strict;
22        use base qw(Exporter);
23        use vars qw(@EXPORT @EXPORT_OK);
24        @EXPORT = qw(Trace T TSetup QTrace Confess 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);      use Carp qw(longmess croak carp);
27      use CGI;      use CGI;
28      use Cwd;      use Cwd;
# Line 38  Line 38 
38      use Time::Local;      use Time::Local;
39      use POSIX qw(strftime);      use POSIX qw(strftime);
40      use Time::Zone;      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
# Line 209  Line 211 
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  my $SavedCGI;               # CGI object passed to ETracing
213  my $CommandLine;            # Command line passed to StandardSetup  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.  umask 2;                    # Fix the damn umask so everything is group-writable.
216    
217  =head2 Tracing Methods  =head2 Tracing Methods
# Line 486  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) || die "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 501  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 643  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  =head3 Warn
756    
757      Warn($message);      Warn($message, @options);
758    
759  This method traces an important message. If an RSS feed is configured  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>,  (via I<FIG_Config::error_feed>) and the tracing destination is C<WARN>,
# Line 686  Line 777 
777    
778  Message to be traced.  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  =back
795    
796  =cut  =cut
797    
798  sub Warn {  sub Warn {
799      # Get the parameters.      # Get the parameters.
800      my ($message) = @_;      my $message = shift @_;
801        my %options = map { $_ => 1 } @_;
802        # Save $@;
803        my $savedError = $@;
804      # Trace the message.      # Trace the message.
805      Trace($message);      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.      # Check for feed forcing.
809      my $forceFeed = exists $Categories{feed};      my $forceFeed = exists $Categories{feed};
810      # An error here would be disastrous. Note, however, that we aren't too worried      # An error here would be disastrous. Note that if debug mode is specified,
811      # about losing events. The error log is always available for the occasions where      # we do this stuff even in a test environment.
     # we mess up. Note that if debug mode is specified, we do this stuff even in a  
     # test environment.  
812      eval {      eval {
813          # Do we need to put this in the RSS feed?          # Do we need to put this in the RSS feed?
814          if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {          if ($FIG_Config::error_feed && ($Destination eq 'WARN' || $forceFeed)) {
815              # Yes. We now need to compute the date, the link, and the title.              # 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.              # First, the date, in a very specific format.
827              my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .              my $date = strftime("%a, %02e %b %H:%M:%S %Y ", localtime) .
828                  (tz_local_offset() / 30);                  (tz_local_offset() / 30);
# Line 728  Line 846 
846              if (defined $SavedCGI) {              if (defined $SavedCGI) {
847                  # We're in a web service. The environment is the user's IP, and the link                  # We're in a web service. The environment is the user's IP, and the link
848                  # is the URL that got us here.                  # is the URL that got us here.
849                  my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};                      $environment .= "Event Reported at IP address $key process $$.";
850                  $environment .= "Event Reported at IP address $key.";                      my $url = $SavedCGI->self_url();
                 my $url = $SavedCGI->url(-full => 1, -query => 1);  
851                  # We need the user agent string and (if available) the referrer.                  # We need the user agent string and (if available) the referrer.
852                  # The referrer will be the link.                  # The referrer will be the link.
853                  $environment .= "User Agent $ENV{HTTP_USER_AGENT}";                  $environment .= "User Agent $ENV{HTTP_USER_AGENT}";
# Line 741  Line 858 
858                      $environment .= " referrer unknown.";                      $environment .= " referrer unknown.";
859                  }                  }
860                  # Close off the sentence with the original link.                  # Close off the sentence with the original link.
861                  $environment .= " URL of error is <a href=\"$url\">$url</a>.";                      $environment .= " URL of event is <a href=\"$url\">$url</a>.";
862              } else {              } else {
863                  # No CGI object, so we're a command-line tool. Use the tracing                  # 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.                  # key and the PID as the user identifier, and add the command.
865                  my $key = EmergencyKey();                  my $key = EmergencyKey();
866                  $environment .= "Event Reported by $key Process $$.";                      $environment .= "Event Reported by $key process $$.";
867                  if ($CommandLine) {                  if ($CommandLine) {
868                      # We're in a StandardSetup script, so we have the real command line.                      # We're in a StandardSetup script, so we have the real command line.
869                      $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";                      $environment .= "\n<pre>" . CGI::escapeHTML($CommandLine) . "</pre>\n";
# Line 759  Line 876 
876              # then digest the result.              # then digest the result.
877              my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);              my $guid = Digest::MD5::md5_base64(gettimeofday(), $title, $$);
878              # Finally, the description. This is a stack trace plus various environmental stuff.              # Finally, the description. This is a stack trace plus various environmental stuff.
879              my $stackTrace = "";                  # The trace is optional.
880                    my $stackTrace;
881                    if ($options{noStack}) {
882                        $stackTrace = "";
883                    } else {
884              my @trace = LongMess();              my @trace = LongMess();
885              # Only proceed if we got something back.              # Only proceed if we got something back.
886              if (scalar(@trace) > 0) {              if (scalar(@trace) > 0) {
887                  $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;                  $trace[0] =~ s/Tracer::Warn.+?called/Event occurred/;
888                  $stackTrace = "Stack trace:<pre>" . join("\n", @trace, "</pre>");                  $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.              # 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              # 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              # twice. They will be escaped once here, and then once when written by XML::Simple. They are
# Line 787  Line 909 
909              my $rss;              my $rss;
910              # Get the name of the RSS file. It's in the FIG temporary directory.              # Get the name of the RSS file. It's in the FIG temporary directory.
911              my $fileName = "$FIG_Config::temp/$FIG_Config::error_feed";              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?              # Does it exist?
916              if (-s $fileName) {              if (-s $fileName) {
917                  # Slurp it in.                  # Slurp it in.
# Line 819  Line 944 
944              unshift @{$items}, $newItem;              unshift @{$items}, $newItem;
945              # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle              # Create the XML. Note we do not include the root or the declaration. XML Simple can't handle
946              # the requirements for those.              # the requirements for those.
947              my $xml = XML::Simple::XMLout($rss, NoAttr => 1, RootName => undef, XmlDecl => '');                  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              # 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.              # 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>";              $xml = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<rss version=\"2.0\">$xml\n</rss>";
# Line 829  Line 954 
954                  close XMLOUT;                  close XMLOUT;
955              }              }
956          }          }
957            }
958      };      };
959      if ($@) {      if ($@) {
960          # If the feed failed, we need to know why. The error will be traced, but this method will not be involved          # If the feed failed, we need to know why. The error will be traced, but this method will not be involved
# Line 836  Line 962 
962          my $error = $@;          my $error = $@;
963          Trace("Feed Error: $error") if T(Feed => 0);          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 926  Line 1062 
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 947  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  =back
1106    
1107  =cut  =cut
1108    
1109  sub ETracing {  sub ETracing {
1110      # Get the parameter.      # Get the parameter.
1111      my ($parameter) = @_;      my ($parameter, %options) = @_;
1112      # Check for CGI mode.      # Check for CGI mode.
1113      if (defined $parameter && ref $parameter eq 'CGI') {      if (defined $parameter && ref $parameter eq 'CGI') {
1114          $SavedCGI = $parameter;          $SavedCGI = $parameter;
1115      } else {      } else {
1116          $SavedCGI = undef;          $SavedCGI = undef;
1117      }      }
1118      # Default to no tracing except errors.      # Check for the noParms option.
1119      my ($tracing, $dest) = ("0", "WARN");      my $noParms = $options{noParms} || 0;
1120        # Get the default tracing information.
1121        my $tracing = $options{level} || 0;
1122        my $dest = $options{destType} || "WARN";
1123      # Check for emergency tracing.      # Check for emergency tracing.
1124      my $tkey = EmergencyKey($parameter);      my $tkey = EmergencyKey($parameter);
1125      my $emergencyFile = EmergencyFileName($tkey);      my $emergencyFile = EmergencyFileName($tkey);
# Line 983  Line 1141 
1141              # the trace level;              # the trace level;
1142              $dest = shift @tracing;              $dest = shift @tracing;
1143              my $level = shift @tracing;              my $level = shift @tracing;
             # Convert the destination to a real tracing destination.  
             # temp directory.  
             $dest = EmergencyTracingDest($tkey, $dest);  
1144              # Insure Tracer is specified.              # Insure Tracer is specified.
1145              my %moduleHash = map { $_ => 1 } @tracing;              my %moduleHash = map { $_ => 1 } @tracing;
1146              $moduleHash{Tracer} = 1;              $moduleHash{Tracer} = 1;
1147              # Set the trace parameter.              # Set the trace parameter.
1148              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1149          }          }
     } elsif (defined $SavedCGI) {  
         # There's no emergency tracing, but we have a CGI object, so check  
         # for tracing from the form parameters.  
         if ($SavedCGI->param('Trace')) {  
             # Here the user has requested tracing via a form.  
             $dest = ($SavedCGI->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");  
             $tracing = $SavedCGI->param('Trace') . " Tracer";  
         }  
1150      }      }
1151        # Convert the destination to a real tracing destination.
1152        $dest = EmergencyTracingDest($tkey, $dest);
1153      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1154      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1155      # Check to see if we're a web script.      # Check to see if we're a web script.
1156      if (defined $SavedCGI) {      if (defined $SavedCGI) {
1157          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data if it's not suppressed.
1158            if (! $noParms) {
1159          TraceParms($SavedCGI);          TraceParms($SavedCGI);
1160            }
1161          # 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
1162          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1163          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1241  Line 1392 
1392      # Get the parameters.      # Get the parameters.
1393      my ($cgi) = @_;      my ($cgi) = @_;
1394      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1395          # 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
1396          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));          # relatively small.
1397            my $url = $cgi->url(-relative => 1, -query => 1);
1398            my $len = length($url);
1399            if ($len < 500) {
1400                Trace("[URL] $url");
1401            } elsif ($len > 2048) {
1402                Trace("[URL] URL is too long to use with GET ($len characters).");
1403            } else {
1404                Trace("[URL] URL length is $len characters.");
1405            }
1406      }      }
1407      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1408          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1545  Line 1705 
1705          -noAlias  do not expect aliases in CHANGE transactions          -noAlias  do not expect aliases in CHANGE transactions
1706          -start    start with this genome          -start    start with this genome
1707          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
1708            -forked   do not erase the trace file before tracing
1709    
1710  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
1711  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 1614  Line 1775 
1775      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1776          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
1777      }      }
1778        if (! exists $options->{forked}) {
1779            $options->{forked} = [0, "keep old trace file"];
1780        }
1781      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
1782      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1783      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1784      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1785      $options->{warn} = [0, "send errors to RSS feed"];      $options->{warn} = [0, "send errors to RSS feed"];
1786        $options->{moreTracing} = ["", "comma-delimited list of additional trace modules for debugging"];
1787      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1788      # contains the default values rather than the default value      # contains the default values rather than the default value
1789      # 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 1635  Line 1800 
1800      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
1801      # Get the logfile suffix.      # Get the logfile suffix.
1802      my $suffix = $retOptions->{user};      my $suffix = $retOptions->{user};
1803      # Check for background mode.      # We'll put the trace file name in here. We need it later if background
1804      if ($retOptions->{background}) {      # mode is on.
1805          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};  
         }  
     }  
1806      # 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
1807      # wants emergency tracing.      # wants emergency tracing.
1808      if ($retOptions->{trace} eq 'E') {      if ($retOptions->{trace} eq 'E') {
# Line 1662  Line 1818 
1818          }          }
1819          # Add the default categories.          # Add the default categories.
1820          push @cats, "Tracer";          push @cats, "Tracer";
1821            # Check for more tracing groups.
1822            if ($retOptions->{moreTracing}) {
1823                push @cats, split /,/, $retOptions->{moreTracing};
1824            }
1825          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
1826          my $cats = join(" ", @cats);          my $cats = join(" ", @cats);
1827          # 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 1676  Line 1836 
1836          my $traceMode;          my $traceMode;
1837          # Verify that we can open a file in the FIG temporary directory.          # Verify that we can open a file in the FIG temporary directory.
1838          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
1839          if (open TESTTRACE, ">$traceFileName") {          my $traceFileSpec = ($retOptions->{forked} ? ">>$traceFileName" : ">$traceFileName");
1840            if (open TESTTRACE, "$traceFileSpec") {
1841              # Here we can trace to a file.              # Here we can trace to a file.
1842              $traceMode = ">$traceFileName";              $traceMode = ">>$traceFileName";
1843              if ($textOKFlag) {              if ($textOKFlag) {
1844                  # Echo to standard output if the text-OK flag is set.                  # Echo to standard output if the text-OK flag is set.
1845                  $traceMode = "+$traceMode";                  $traceMode = "+$traceMode";
# Line 1699  Line 1860 
1860          # Now set up the tracing.          # Now set up the tracing.
1861          TSetup("$traceLevel $cats", $traceMode);          TSetup("$traceLevel $cats", $traceMode);
1862      }      }
1863        # Check for background mode.
1864        if ($retOptions->{background}) {
1865            my $outFileName = "$FIG_Config::temp/out$suffix$$.log";
1866            my $errFileName = "$FIG_Config::temp/err$suffix$$.log";
1867            # Spool the output.
1868            open STDOUT, ">$outFileName";
1869            # If we have a trace file, trace the errors to the log. Otherwise,
1870            # spool the errors.
1871            if (defined $traceFileName) {
1872                open STDERR, "| Tracer $traceFileName";
1873            } else {
1874                open STDERR, ">$errFileName";
1875            }
1876            # Check for phone support. If we have phone support and a phone number,
1877            # we want to turn it on.
1878            if ($ENV{PHONE} && defined($FIG_Config::phone)) {
1879                $retOptions->{phone} = $ENV{PHONE};
1880            }
1881        }
1882      # 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
1883      # options and exit the program.      # options and exit the program.
1884      if ($retOptions->{help}) {      if ($retOptions->{help}) {
# Line 1879  Line 2059 
2059      }      }
2060  }  }
2061    
2062    =head3 UnparseOptions
2063    
2064        my $optionString = Tracer::UnparseOptions(\%options);
2065    
2066    Convert an option hash into a command-line string. This will not
2067    necessarily be the same text that came in, but it will nonetheless
2068    produce the same ultimate result when parsed by L</StandardSetup>.
2069    
2070    =over 4
2071    
2072    =item options
2073    
2074    Reference to a hash of options to convert into an option string.
2075    
2076    =item RETURN
2077    
2078    Returns a string that will parse to the same set of options when
2079    parsed by L</StandardSetup>.
2080    
2081    =back
2082    
2083    =cut
2084    
2085    sub UnparseOptions {
2086        # Get the parameters.
2087        my ($options) = @_;
2088        # The option segments will be put in here.
2089        my @retVal = ();
2090        # Loop through the options.
2091        for my $key (keys %$options) {
2092            # Get the option value.
2093            my $value = $options->{$key};
2094            # Only use it if it's nonempty.
2095            if (defined $value && $value ne "") {
2096                my $segment = "--$key=$value";
2097                # Quote it if necessary.
2098                if ($segment =~ /[ |<>*]/) {
2099                    $segment = '"' . $segment . '"';
2100                }
2101                # Add it to the return list.
2102                push @retVal, $segment;
2103            }
2104        }
2105        # Return the result.
2106        return join(" ", @retVal);
2107    }
2108    
2109  =head3 ParseCommand  =head3 ParseCommand
2110    
2111      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);
# Line 2351  Line 2578 
2578          } else {          } else {
2579              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
2580          }          }
2581            closedir $dirHandle;
2582      } elsif (! $flag) {      } elsif (! $flag) {
2583          # Here the directory would not open and it's considered an error.          # Here the directory would not open and it's considered an error.
2584          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
# Line 2457  Line 2685 
2685  Map of search patterns to permission masks. If a directory name matches  Map of search patterns to permission masks. If a directory name matches
2686  one of the patterns, that directory and all its members and subdirectories  one of the patterns, that directory and all its members and subdirectories
2687  will be assigned the new pattern. For example, the following would  will be assigned the new pattern. For example, the following would
2688  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>.
2689    
2690      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2691    
# Line 2510  Line 2738 
2738                      $match = 1;                      $match = 1;
2739                  }                  }
2740              }              }
2741              # 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
2742              # before terminating due to the match.              # before terminating due to the match.
2743              if ($match && $otherMasks[$i-1] != $mask) {              if ($match && $otherMasks[$i-1] != $mask) {
2744                  # This directory matches one of the incoming patterns, and it's                  # This directory matches one of the incoming patterns, and it's
# Line 2678  Line 2906 
2906    
2907  =head2 Other Useful Methods  =head2 Other Useful Methods
2908    
2909    =head3 IDHASH
2910    
2911        my $hash = SHTargetSearch::IDHASH(@keys);
2912    
2913    This is a dinky little method that converts a list of values to a reference
2914    to hash of values to labels. The values and labels are the same.
2915    
2916    =cut
2917    
2918    sub IDHASH {
2919        my %retVal = map { $_ => $_ } @_;
2920        return \%retVal;
2921    }
2922    
2923    =head3 Pluralize
2924    
2925        my $plural = Tracer::Pluralize($word);
2926    
2927    This is a very simple pluralization utility. It adds an C<s> at the end
2928    of the input word unless it already ends in an C<s>, in which case it
2929    adds C<es>.
2930    
2931    =over 4
2932    
2933    =item word
2934    
2935    Singular word to pluralize.
2936    
2937    =item RETURN
2938    
2939    Returns the probable plural form of the word.
2940    
2941    =back
2942    
2943    =cut
2944    
2945    sub Pluralize {
2946        # Get the parameters.
2947        my ($word) = @_;
2948        # Declare the return variable.
2949        my $retVal;
2950        if ($word =~ /s$/) {
2951            $retVal = $word . 'es';
2952        } else {
2953            $retVal = $word . 's';
2954        }
2955        # Return the result.
2956        return $retVal;
2957    }
2958    
2959    =head3 Numeric
2960    
2961        my $okFlag = Tracer::Numeric($string);
2962    
2963    Return the value of the specified string if it is numeric, or an undefined value
2964    if it is not numeric.
2965    
2966    =over 4
2967    
2968    =item string
2969    
2970    String to check.
2971    
2972    =item RETURN
2973    
2974    Returns the numeric value of the string if successful, or C<undef> if the string
2975    is not numeric.
2976    
2977    =back
2978    
2979    =cut
2980    
2981    sub Numeric {
2982        # Get the parameters.
2983        my ($string) = @_;
2984        # We'll put the value in here if we succeed.
2985        my $retVal;
2986        # Get a working copy of the string.
2987        my $copy = $string;
2988        # Trim leading and trailing spaces.
2989        $copy =~ s/^\s+//;
2990        $copy =~ s/\s+$//;
2991        # Check the result.
2992        if ($copy =~ /^[+-]?\d+$/) {
2993            $retVal = $copy;
2994        } elsif ($copy =~ /^([+-]\d+|\d*)[eE][+-]?\d+$/) {
2995            $retVal = $copy;
2996        } elsif ($copy =~ /^([+-]\d+|\d*)\.\d*([eE][+-]?\d+)?$/) {
2997            $retVal = $copy;
2998        }
2999        # Return the result.
3000        return $retVal;
3001    }
3002    
3003    
3004  =head3 ParseParm  =head3 ParseParm
3005    
3006      my $listValue = Tracer::ParseParm($string);      my $listValue = Tracer::ParseParm($string);
# Line 2920  Line 3243 
3243      return $retVal;      return $retVal;
3244  }  }
3245    
3246    =head3 In
3247    
3248        my $flag = Tracer::In($value, $min, $max);
3249    
3250    Return TRUE if the value is between the minimum and the maximum, else FALSE.
3251    
3252    =cut
3253    
3254    sub In {
3255        return ($_[0] <= $_[2] && $_[0] >= $_[1]);
3256    }
3257    
3258    
3259  =head3 Constrain  =head3 Constrain
3260    
3261      my $constrained = Constrain($value, $min, $max);      my $constrained = Constrain($value, $min, $max);
# Line 3063  Line 3399 
3399      return $retVal;      return $retVal;
3400  }  }
3401    
3402    =head3 Trim
3403    
3404        my $string = Tracer::Trim($line);
3405    
3406    Trim all spaces from the beginning and ending of a string.
3407    
3408    =over 4
3409    
3410    =item line
3411    
3412    Line of text to be trimmed.
3413    
3414    =item RETURN
3415    
3416    The same line of text with all whitespace chopped off either end.
3417    
3418    =back
3419    
3420    =cut
3421    
3422    sub Trim {
3423        # Get a copy of the parameter string.
3424        my ($string) = @_;
3425        my $retVal = (defined $string ? $string : "");
3426        # Strip the front spaces.
3427        $retVal =~ s/^\s+//;
3428        # Strip the back spaces.
3429        $retVal =~ s/\s+$//;
3430        # Return the result.
3431        return $retVal;
3432    }
3433    
3434  =head3 Pad  =head3 Pad
3435    
3436      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);
# Line 3124  Line 3492 
3492      return $retVal;      return $retVal;
3493  }  }
3494    
3495    =head3 Quoted
3496    
3497        my $string = Tracer::Quoted($var);
3498    
3499    Convert the specified value to a string and enclose it in single quotes.
3500    If it's undefined, the string C<undef> in angle brackets will be used
3501    instead.
3502    
3503    =over 4
3504    
3505    =item var
3506    
3507    Value to quote.
3508    
3509    =item RETURN
3510    
3511    Returns a string enclosed in quotes, or an indication the value is undefined.
3512    
3513    =back
3514    
3515    =cut
3516    
3517    sub Quoted {
3518        # Get the parameters.
3519        my ($var) = @_;
3520        # Declare the return variable.
3521        my $retVal;
3522        # Are we undefined?
3523        if (! defined $var) {
3524            $retVal = "<undef>";
3525        } else {
3526            # No, so convert to a string and enclose in quotes.
3527            $retVal = $var;
3528            $retVal =~ s/'/\\'/;
3529            $retVal = "'$retVal'";
3530        }
3531        # Return the result.
3532        return $retVal;
3533    }
3534    
3535  =head3 EOF  =head3 EOF
3536    
3537  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 3213  Line 3621 
3621  }  }
3622    
3623    
3624    =head3 GetMemorySize
3625    
3626        my $string = Tracer::GetMemorySize();
3627    
3628    Return a memory size string for the current process. The string will be
3629    in comma format, with a size indicator (K, M, G) at the end.
3630    
3631    =cut
3632    
3633    sub GetMemorySize {
3634        # Get the memory size from Unix.
3635        my ($retVal) = `ps h -o vsz $$`;
3636        # Remove the ending new-line.
3637        chomp $retVal;
3638        # Format and return the result.
3639        return CommaFormat($retVal) . "K";
3640    }
3641    
3642  =head3 CompareLists  =head3 CompareLists
3643    
3644      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);
# Line 3285  Line 3711 
3711      my $cmp = Tracer::Cmp($a, $b);      my $cmp = Tracer::Cmp($a, $b);
3712    
3713  This method performs a universal sort comparison. Each value coming in is  This method performs a universal sort comparison. Each value coming in is
3714  separated into a leading text part and a trailing number part. The text  separated into a text parts and number parts. The text
3715  part is string compared, and if both parts are equal, then the number  part is string compared, and if both parts are equal, then the number
3716  parts are compared numerically. A stream of just numbers or a stream of  parts are compared numerically. A stream of just numbers or a stream of
3717  just strings will sort correctly, and a mixed stream will sort with the  just strings will sort correctly, and a mixed stream will sort with the
3718  numbers first. Strings with a label and a number will sort in the  numbers first. Strings with a label and a number will sort in the
3719  expected manner instead of lexically.  expected manner instead of lexically. Undefined values sort last.
3720    
3721  =over 4  =over 4
3722    
# Line 3324  Line 3750 
3750          $retVal = 1;          $retVal = 1;
3751      } else {      } else {
3752          # Here we have two real values. Parse the two strings.          # Here we have two real values. Parse the two strings.
3753          $a =~ /^(\D*)(\d*)$/;          my @aParsed = _Parse($a);
3754          my $aParsed = [$1, $2];          my @bParsed = _Parse($b);
3755          $b =~ /^(\D*)(\d*)$/;          # Loop through the first string.
3756          my $bParsed = [$1, $2];          while (! $retVal && @aParsed) {
3757          # Compare the string parts.              # Extract the string parts.
3758          $retVal = $aParsed->[0] cmp $bParsed->[0];              my $aPiece = shift(@aParsed);
3759                my $bPiece = shift(@bParsed) || '';
3760                # Extract the number parts.
3761                my $aNum = shift(@aParsed);
3762                my $bNum = shift(@bParsed) || 0;
3763                # Compare the string parts insensitively.
3764                $retVal = (lc($aPiece) cmp lc($bPiece));
3765                # If they're equal, compare them sensitively.
3766          if (! $retVal) {          if (! $retVal) {
3767              $retVal = $aParsed->[1] <=> $bParsed->[1];                  $retVal = ($aPiece cmp $bPiece);
3768                    # If they're STILL equal, compare the number parts.
3769                    if (! $retVal) {
3770                        $retVal = $aNum <=> $bNum;
3771                    }
3772                }
3773          }          }
3774      }      }
3775      # Return the result.      # Return the result.
3776      return $retVal;      return $retVal;
3777  }  }
3778    
3779    # This method parses an input string into a string parts alternating with
3780    # number parts.
3781    sub _Parse {
3782        # Get the incoming string.
3783        my ($string) = @_;
3784        # The pieces will be put in here.
3785        my @retVal;
3786        # Loop through as many alpha/num sets as we can.
3787        while ($string =~ /^(\D*)(\d+)(.*)/) {
3788            # Push the alpha and number parts into the return string.
3789            push @retVal, $1, $2;
3790            # Save the residual.
3791            $string = $3;
3792        }
3793        # If there's still stuff left, add it to the end with a trailing
3794        # zero.
3795        if ($string) {
3796            push @retVal, $string, 0;
3797        }
3798        # Return the list.
3799        return @retVal;
3800    }
3801    
3802    =head3 ListEQ
3803    
3804        my $flag = Tracer::ListEQ(\@a, \@b);
3805    
3806    Return TRUE if the specified lists contain the same strings in the same
3807    order, else FALSE.
3808    
3809    =over 4
3810    
3811    =item a
3812    
3813    Reference to the first list.
3814    
3815    =item b
3816    
3817    Reference to the second list.
3818    
3819    =item RETURN
3820    
3821    Returns TRUE if the two parameters are identical string lists, else FALSE.
3822    
3823    =back
3824    
3825    =cut
3826    
3827    sub ListEQ {
3828        # Get the parameters.
3829        my ($a, $b) = @_;
3830        # Declare the return variable. Start by checking the lengths.
3831        my $n = scalar(@$a);
3832        my $retVal = ($n == scalar(@$b));
3833        # Now compare the list elements.
3834        for (my $i = 0; $retVal && $i < $n; $i++) {
3835            $retVal = ($a->[$i] eq $b->[$i]);
3836        }
3837        # Return the result.
3838        return $retVal;
3839    }
3840    
3841  =head2 CGI Script Utilities  =head2 CGI Script Utilities
3842    
3843  =head3 ScriptSetup (deprecated)  =head3 ScriptSetup (deprecated)
# Line 3688  Line 4188 
4188      return $retVal;      return $retVal;
4189  }  }
4190    
4191    =head3 SortByValue
4192    
4193        my @keys = Tracer::SortByValue(\%hash);
4194    
4195    Get a list of hash table keys sorted by hash table values.
4196    
4197    =over 4
4198    
4199    =item hash
4200    
4201    Hash reference whose keys are to be extracted.
4202    
4203    =item RETURN
4204    
4205    Returns a list of the hash keys, ordered so that the corresponding hash values
4206    are in alphabetical sequence.
4207    
4208    =back
4209    
4210    =cut
4211    
4212    sub SortByValue {
4213        # Get the parameters.
4214        my ($hash) = @_;
4215        # Sort the hash's keys using the values.
4216        my @retVal = sort { Cmp($hash->{$a}, $hash->{$b}) } keys %$hash;
4217        # Return the result.
4218        return @retVal;
4219    }
4220    
4221    =head3 GetSet
4222    
4223        my $value = Tracer::GetSet($object, $name => $newValue);
4224    
4225    Get or set the value of an object field. The object is treated as an
4226    ordinary hash reference. If a new value is specified, it is stored in the
4227    hash under the specified name and then returned. If no new value is
4228    specified, the current value is returned.
4229    
4230    =over 4
4231    
4232    =item object
4233    
4234    Reference to the hash that is to be interrogated or updated.
4235    
4236    =item name
4237    
4238    Name of the field. This is the hash key.
4239    
4240    =item newValue (optional)
4241    
4242    New value to be stored in the field. If no new value is specified, the current
4243    value of the field is returned.
4244    
4245    =item RETURN
4246    
4247    Returns the value of the named field in the specified hash.
4248    
4249    =back
4250    
4251    =cut
4252    
4253    sub GetSet {
4254        # Get the parameters.
4255        my ($object, $name, $newValue) = @_;
4256        # Is a new value specified?
4257        if (defined $newValue) {
4258            # Yes, so store it.
4259            $object->{$name} = $newValue;
4260        }
4261        # Return the result.
4262        return $object->{$name};
4263    }
4264    
4265  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3