[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.108, Wed Sep 3 20:33:22 2008 UTC revision 1.129, Tue Jan 5 17:25:48 2010 UTC
# Line 18  Line 18 
18    
19  package Tracer;  package Tracer;
20    
     require Exporter;  
     @ISA = ('Exporter');  
     @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency 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 ':flock';      use Fcntl qw(:DEFAULT :flock);
42        use Data::Dumper;
43    
44    
45  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
# Line 210  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 487  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 502  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 644  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  =head3 SaveCGI
734    
735      Tracer::SaveCGI($cgi);      Tracer::SaveCGI($cgi);
# Line 744  Line 812 
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 768  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.
                 my $key = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR};  
849                  $environment .= "Event Reported at IP address $key process $$.";                  $environment .= "Event Reported at IP address $key process $$.";
850                  my $url = $SavedCGI->self_url();                  my $url = $SavedCGI->self_url();
851                  # We need the user agent string and (if available) the referrer.                  # We need the user agent string and (if available) the referrer.
# Line 877  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 984  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 1005  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);
1126      if (-e $emergencyFile) {      if (-e $emergencyFile && (my $stat = stat($emergencyFile))) {
1127          # We have the file. Read in the data.          # We have the file. Read in the data.
1128          my @tracing = GetFile($emergencyFile);          my @tracing = GetFile($emergencyFile);
1129          # Pull off the time limit.          # Pull off the time limit.
# Line 1031  Line 1131 
1131          # Convert it to seconds.          # Convert it to seconds.
1132          $expire *= 3600;          $expire *= 3600;
1133          # Check the file data.          # Check the file data.
         my $stat = stat($emergencyFile);  
1134          my ($now) = gettimeofday;          my ($now) = gettimeofday;
1135          if ($now - $stat->mtime > $expire) {          if ($now - $stat->mtime <= $expire) {
             # Delete the expired file.  
             unlink $emergencyFile;  
         } else {  
1136              # Emergency tracing is on. Pull off the destination and              # Emergency tracing is on. Pull off the destination and
1137              # the trace level;              # the trace level;
1138              $dest = shift @tracing;              $dest = shift @tracing;
1139              my $level = shift @tracing;              my $level = shift @tracing;
             # Convert the destination to a real tracing destination.  
             # temp directory.  
             $dest = EmergencyTracingDest($tkey, $dest);  
1140              # Insure Tracer is specified.              # Insure Tracer is specified.
1141              my %moduleHash = map { $_ => 1 } @tracing;              my %moduleHash = map { $_ => 1 } @tracing;
1142              $moduleHash{Tracer} = 1;              $moduleHash{Tracer} = 1;
1143              # Set the trace parameter.              # Set the trace parameter.
1144              $tracing = join(" ", $level, sort keys %moduleHash);              $tracing = join(" ", $level, sort keys %moduleHash);
1145          }          }
     } 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";  
         }  
1146      }      }
1147        # Convert the destination to a real tracing destination.
1148        $dest = EmergencyTracingDest($tkey, $dest);
1149      # Setup the tracing we've determined from all the stuff above.      # Setup the tracing we've determined from all the stuff above.
1150      TSetup($tracing, $dest);      TSetup($tracing, $dest);
1151      # Check to see if we're a web script.      # Check to see if we're a web script.
1152      if (defined $SavedCGI) {      if (defined $SavedCGI) {
1153          # Yes we are. Trace the form and environment data.          # Yes we are. Trace the form and environment data if it's not suppressed.
1154            if (! $noParms) {
1155          TraceParms($SavedCGI);          TraceParms($SavedCGI);
1156            }
1157          # 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
1158          # emitted by the script in its raw form.          # emitted by the script in its raw form.
1159          if (T(Raw => 3)) {          if (T(Raw => 3)) {
# Line 1299  Line 1388 
1388      # Get the parameters.      # Get the parameters.
1389      my ($cgi) = @_;      my ($cgi) = @_;
1390      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1391          # 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
1392          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));          # relatively small.
1393            my $url = $cgi->url(-relative => 1, -query => 1);
1394            my $len = length($url);
1395            if ($len < 500) {
1396                Trace("[URL] $url");
1397            } elsif ($len > 2048) {
1398                Trace("[URL] URL is too long to use with GET ($len characters).");
1399            } else {
1400                Trace("[URL] URL length is $len characters.");
1401            }
1402      }      }
1403      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1404          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 1603  Line 1701 
1701          -noAlias  do not expect aliases in CHANGE transactions          -noAlias  do not expect aliases in CHANGE transactions
1702          -start    start with this genome          -start    start with this genome
1703          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
1704            -forked   do not erase the trace file before tracing
1705    
1706  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
1707  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 1672  Line 1771 
1771      if (! exists $options->{trace}) {      if (! exists $options->{trace}) {
1772          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];          $options->{trace} = ['2', "tracing level (E for emergency tracing)"];
1773      }      }
1774        if (! exists $options->{forked}) {
1775            $options->{forked} = [0, "keep old trace file"];
1776        }
1777      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
1778      $options->{help} = [0, "display command-line options"];      $options->{help} = [0, "display command-line options"];
1779      $options->{user} = [$tkey, "tracing key"];      $options->{user} = [$tkey, "tracing key"];
1780      $options->{background} = [0, "spool standard and error output"];      $options->{background} = [0, "spool standard and error output"];
1781      $options->{warn} = [0, "send errors to RSS feed"];      $options->{warn} = [0, "send errors to RSS feed"];
1782        $options->{moreTracing} = ["", "comma-delimited list of additional trace modules for debugging"];
1783      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
1784      # contains the default values rather than the default value      # contains the default values rather than the default value
1785      # 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 1693  Line 1796 
1796      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
1797      # Get the logfile suffix.      # Get the logfile suffix.
1798      my $suffix = $retOptions->{user};      my $suffix = $retOptions->{user};
1799      # Check for background mode.      # We'll put the trace file name in here. We need it later if background
1800      if ($retOptions->{background}) {      # mode is on.
1801          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};  
         }  
     }  
1802      # 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
1803      # wants emergency tracing.      # wants emergency tracing.
1804      if ($retOptions->{trace} eq 'E') {      if ($retOptions->{trace} eq 'E') {
# Line 1720  Line 1814 
1814          }          }
1815          # Add the default categories.          # Add the default categories.
1816          push @cats, "Tracer";          push @cats, "Tracer";
1817            # Check for more tracing groups.
1818            if ($retOptions->{moreTracing}) {
1819                push @cats, split /,/, $retOptions->{moreTracing};
1820            }
1821          # Next, we create the category string by joining the categories.          # Next, we create the category string by joining the categories.
1822          my $cats = join(" ", @cats);          my $cats = join(" ", @cats);
1823          # 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 1734  Line 1832 
1832          my $traceMode;          my $traceMode;
1833          # Verify that we can open a file in the FIG temporary directory.          # Verify that we can open a file in the FIG temporary directory.
1834          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";          my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
1835          if (open TESTTRACE, ">$traceFileName") {          my $traceFileSpec = ($retOptions->{forked} ? ">>$traceFileName" : ">$traceFileName");
1836            if (open TESTTRACE, "$traceFileSpec") {
1837              # Here we can trace to a file.              # Here we can trace to a file.
1838              $traceMode = ">$traceFileName";              $traceMode = ">>$traceFileName";
1839              if ($textOKFlag) {              if ($textOKFlag) {
1840                  # Echo to standard output if the text-OK flag is set.                  # Echo to standard output if the text-OK flag is set.
1841                  $traceMode = "+$traceMode";                  $traceMode = "+$traceMode";
# Line 1757  Line 1856 
1856          # Now set up the tracing.          # Now set up the tracing.
1857          TSetup("$traceLevel $cats", $traceMode);          TSetup("$traceLevel $cats", $traceMode);
1858      }      }
1859        # Check for background mode.
1860        if ($retOptions->{background}) {
1861            my $outFileName = "$FIG_Config::temp/out$suffix$$.log";
1862            my $errFileName = "$FIG_Config::temp/err$suffix$$.log";
1863            # Spool the output.
1864            open STDOUT, ">$outFileName";
1865            # If we have a trace file, trace the errors to the log. Otherwise,
1866            # spool the errors.
1867            if (defined $traceFileName) {
1868                open STDERR, "| Tracer $traceFileName";
1869            } else {
1870                open STDERR, ">$errFileName";
1871            }
1872            # Check for phone support. If we have phone support and a phone number,
1873            # we want to turn it on.
1874            if ($ENV{PHONE} && defined($FIG_Config::phone)) {
1875                $retOptions->{phone} = $ENV{PHONE};
1876            }
1877        }
1878      # 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
1879      # options and exit the program.      # options and exit the program.
1880      if ($retOptions->{help}) {      if ($retOptions->{help}) {
# Line 1937  Line 2055 
2055      }      }
2056  }  }
2057    
2058    =head3 UnparseOptions
2059    
2060        my $optionString = Tracer::UnparseOptions(\%options);
2061    
2062    Convert an option hash into a command-line string. This will not
2063    necessarily be the same text that came in, but it will nonetheless
2064    produce the same ultimate result when parsed by L</StandardSetup>.
2065    
2066    =over 4
2067    
2068    =item options
2069    
2070    Reference to a hash of options to convert into an option string.
2071    
2072    =item RETURN
2073    
2074    Returns a string that will parse to the same set of options when
2075    parsed by L</StandardSetup>.
2076    
2077    =back
2078    
2079    =cut
2080    
2081    sub UnparseOptions {
2082        # Get the parameters.
2083        my ($options) = @_;
2084        # The option segments will be put in here.
2085        my @retVal = ();
2086        # Loop through the options.
2087        for my $key (keys %$options) {
2088            # Get the option value.
2089            my $value = $options->{$key};
2090            # Only use it if it's nonempty.
2091            if (defined $value && $value ne "") {
2092                my $segment = "--$key=$value";
2093                # Quote it if necessary.
2094                if ($segment =~ /[ |<>*]/) {
2095                    $segment = '"' . $segment . '"';
2096                }
2097                # Add it to the return list.
2098                push @retVal, $segment;
2099            }
2100        }
2101        # Return the result.
2102        return join(" ", @retVal);
2103    }
2104    
2105  =head3 ParseCommand  =head3 ParseCommand
2106    
2107      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);      my ($options, @arguments) = Tracer::ParseCommand(\%optionTable, @inputList);
# Line 2409  Line 2574 
2574          } else {          } else {
2575              @retVal = readdir $dirHandle;              @retVal = readdir $dirHandle;
2576          }          }
2577            closedir $dirHandle;
2578      } elsif (! $flag) {      } elsif (! $flag) {
2579          # Here the directory would not open and it's considered an error.          # Here the directory would not open and it's considered an error.
2580          Confess("Could not open directory $dirName.");          Confess("Could not open directory $dirName.");
# Line 2515  Line 2681 
2681  Map of search patterns to permission masks. If a directory name matches  Map of search patterns to permission masks. If a directory name matches
2682  one of the patterns, that directory and all its members and subdirectories  one of the patterns, that directory and all its members and subdirectories
2683  will be assigned the new pattern. For example, the following would  will be assigned the new pattern. For example, the following would
2684  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>.
2685    
2686      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);      Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2687    
# Line 2568  Line 2734 
2734                      $match = 1;                      $match = 1;
2735                  }                  }
2736              }              }
2737              # 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
2738              # before terminating due to the match.              # before terminating due to the match.
2739              if ($match && $otherMasks[$i-1] != $mask) {              if ($match && $otherMasks[$i-1] != $mask) {
2740                  # This directory matches one of the incoming patterns, and it's                  # This directory matches one of the incoming patterns, and it's
# Line 2736  Line 2902 
2902    
2903  =head2 Other Useful Methods  =head2 Other Useful Methods
2904    
2905    =head3 IDHASH
2906    
2907        my $hash = SHTargetSearch::IDHASH(@keys);
2908    
2909    This is a dinky little method that converts a list of values to a reference
2910    to hash of values to labels. The values and labels are the same.
2911    
2912    =cut
2913    
2914    sub IDHASH {
2915        my %retVal = map { $_ => $_ } @_;
2916        return \%retVal;
2917    }
2918    
2919    =head3 Pluralize
2920    
2921        my $plural = Tracer::Pluralize($word);
2922    
2923    This is a very simple pluralization utility. It adds an C<s> at the end
2924    of the input word unless it already ends in an C<s>, in which case it
2925    adds C<es>.
2926    
2927    =over 4
2928    
2929    =item word
2930    
2931    Singular word to pluralize.
2932    
2933    =item RETURN
2934    
2935    Returns the probable plural form of the word.
2936    
2937    =back
2938    
2939    =cut
2940    
2941    sub Pluralize {
2942        # Get the parameters.
2943        my ($word) = @_;
2944        # Declare the return variable.
2945        my $retVal;
2946        if ($word =~ /s$/) {
2947            $retVal = $word . 'es';
2948        } else {
2949            $retVal = $word . 's';
2950        }
2951        # Return the result.
2952        return $retVal;
2953    }
2954    
2955    =head3 Numeric
2956    
2957        my $okFlag = Tracer::Numeric($string);
2958    
2959    Return the value of the specified string if it is numeric, or an undefined value
2960    if it is not numeric.
2961    
2962    =over 4
2963    
2964    =item string
2965    
2966    String to check.
2967    
2968    =item RETURN
2969    
2970    Returns the numeric value of the string if successful, or C<undef> if the string
2971    is not numeric.
2972    
2973    =back
2974    
2975    =cut
2976    
2977    sub Numeric {
2978        # Get the parameters.
2979        my ($string) = @_;
2980        # We'll put the value in here if we succeed.
2981        my $retVal;
2982        # Get a working copy of the string.
2983        my $copy = $string;
2984        # Trim leading and trailing spaces.
2985        $copy =~ s/^\s+//;
2986        $copy =~ s/\s+$//;
2987        # Check the result.
2988        if ($copy =~ /^[+-]?\d+$/) {
2989            $retVal = $copy;
2990        } elsif ($copy =~ /^([+-]\d+|\d*)[eE][+-]?\d+$/) {
2991            $retVal = $copy;
2992        } elsif ($copy =~ /^([+-]\d+|\d*)\.\d*([eE][+-]?\d+)?$/) {
2993            $retVal = $copy;
2994        }
2995        # Return the result.
2996        return $retVal;
2997    }
2998    
2999    
3000  =head3 ParseParm  =head3 ParseParm
3001    
3002      my $listValue = Tracer::ParseParm($string);      my $listValue = Tracer::ParseParm($string);
# Line 2978  Line 3239 
3239      return $retVal;      return $retVal;
3240  }  }
3241    
3242    =head3 In
3243    
3244        my $flag = Tracer::In($value, $min, $max);
3245    
3246    Return TRUE if the value is between the minimum and the maximum, else FALSE.
3247    
3248    =cut
3249    
3250    sub In {
3251        return ($_[0] <= $_[2] && $_[0] >= $_[1]);
3252    }
3253    
3254    
3255  =head3 Constrain  =head3 Constrain
3256    
3257      my $constrained = Constrain($value, $min, $max);      my $constrained = Constrain($value, $min, $max);
# Line 3121  Line 3395 
3395      return $retVal;      return $retVal;
3396  }  }
3397    
3398    =head3 Trim
3399    
3400        my $string = Tracer::Trim($line);
3401    
3402    Trim all spaces from the beginning and ending of a string.
3403    
3404    =over 4
3405    
3406    =item line
3407    
3408    Line of text to be trimmed.
3409    
3410    =item RETURN
3411    
3412    The same line of text with all whitespace chopped off either end.
3413    
3414    =back
3415    
3416    =cut
3417    
3418    sub Trim {
3419        # Get a copy of the parameter string.
3420        my ($string) = @_;
3421        my $retVal = (defined $string ? $string : "");
3422        # Strip the front spaces.
3423        $retVal =~ s/^\s+//;
3424        # Strip the back spaces.
3425        $retVal =~ s/\s+$//;
3426        # Return the result.
3427        return $retVal;
3428    }
3429    
3430  =head3 Pad  =head3 Pad
3431    
3432      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);
# Line 3182  Line 3488 
3488      return $retVal;      return $retVal;
3489  }  }
3490    
3491    =head3 Quoted
3492    
3493        my $string = Tracer::Quoted($var);
3494    
3495    Convert the specified value to a string and enclose it in single quotes.
3496    If it's undefined, the string C<undef> in angle brackets will be used
3497    instead.
3498    
3499    =over 4
3500    
3501    =item var
3502    
3503    Value to quote.
3504    
3505    =item RETURN
3506    
3507    Returns a string enclosed in quotes, or an indication the value is undefined.
3508    
3509    =back
3510    
3511    =cut
3512    
3513    sub Quoted {
3514        # Get the parameters.
3515        my ($var) = @_;
3516        # Declare the return variable.
3517        my $retVal;
3518        # Are we undefined?
3519        if (! defined $var) {
3520            $retVal = "<undef>";
3521        } else {
3522            # No, so convert to a string and enclose in quotes.
3523            $retVal = $var;
3524            $retVal =~ s/'/\\'/;
3525            $retVal = "'$retVal'";
3526        }
3527        # Return the result.
3528        return $retVal;
3529    }
3530    
3531  =head3 EOF  =head3 EOF
3532    
3533  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 3271  Line 3617 
3617  }  }
3618    
3619    
3620    =head3 GetMemorySize
3621    
3622        my $string = Tracer::GetMemorySize();
3623    
3624    Return a memory size string for the current process. The string will be
3625    in comma format, with a size indicator (K, M, G) at the end.
3626    
3627    =cut
3628    
3629    sub GetMemorySize {
3630        # Get the memory size from Unix.
3631        my ($retVal) = `ps h -o vsz $$`;
3632        # Remove the ending new-line.
3633        chomp $retVal;
3634        # Format and return the result.
3635        return CommaFormat($retVal) . "K";
3636    }
3637    
3638  =head3 CompareLists  =head3 CompareLists
3639    
3640      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);      my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex);
# Line 3343  Line 3707 
3707      my $cmp = Tracer::Cmp($a, $b);      my $cmp = Tracer::Cmp($a, $b);
3708    
3709  This method performs a universal sort comparison. Each value coming in is  This method performs a universal sort comparison. Each value coming in is
3710  separated into a leading text part and a trailing number part. The text  separated into a text parts and number parts. The text
3711  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
3712  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
3713  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
3714  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
3715  expected manner instead of lexically.  expected manner instead of lexically. Undefined values sort last.
3716    
3717  =over 4  =over 4
3718    
# Line 3382  Line 3746 
3746          $retVal = 1;          $retVal = 1;
3747      } else {      } else {
3748          # Here we have two real values. Parse the two strings.          # Here we have two real values. Parse the two strings.
3749          $a =~ /^(\D*)(\d*)$/;          my @aParsed = _Parse($a);
3750          my $aParsed = [$1, $2];          my @bParsed = _Parse($b);
3751          $b =~ /^(\D*)(\d*)$/;          # Loop through the first string.
3752          my $bParsed = [$1, $2];          while (! $retVal && @aParsed) {
3753          # Compare the string parts.              # Extract the string parts.
3754          $retVal = $aParsed->[0] cmp $bParsed->[0];              my $aPiece = shift(@aParsed);
3755                my $bPiece = shift(@bParsed) || '';
3756                # Extract the number parts.
3757                my $aNum = shift(@aParsed);
3758                my $bNum = shift(@bParsed) || 0;
3759                # Compare the string parts insensitively.
3760                $retVal = (lc($aPiece) cmp lc($bPiece));
3761                # If they're equal, compare them sensitively.
3762                if (! $retVal) {
3763                    $retVal = ($aPiece cmp $bPiece);
3764                    # If they're STILL equal, compare the number parts.
3765          if (! $retVal) {          if (! $retVal) {
3766              $retVal = $aParsed->[1] <=> $bParsed->[1];                      $retVal = $aNum <=> $bNum;
3767                    }
3768                }
3769          }          }
3770      }      }
3771      # Return the result.      # Return the result.
3772      return $retVal;      return $retVal;
3773  }  }
3774    
3775    # This method parses an input string into a string parts alternating with
3776    # number parts.
3777    sub _Parse {
3778        # Get the incoming string.
3779        my ($string) = @_;
3780        # The pieces will be put in here.
3781        my @retVal;
3782        # Loop through as many alpha/num sets as we can.
3783        while ($string =~ /^(\D*)(\d+)(.*)/) {
3784            # Push the alpha and number parts into the return string.
3785            push @retVal, $1, $2;
3786            # Save the residual.
3787            $string = $3;
3788        }
3789        # If there's still stuff left, add it to the end with a trailing
3790        # zero.
3791        if ($string) {
3792            push @retVal, $string, 0;
3793        }
3794        # Return the list.
3795        return @retVal;
3796    }
3797    
3798  =head3 ListEQ  =head3 ListEQ
3799    
3800      my $flag = Tracer::ListEQ(\@a, \@b);      my $flag = Tracer::ListEQ(\@a, \@b);
# Line 3785  Line 4184 
4184      return $retVal;      return $retVal;
4185  }  }
4186    
4187    =head3 SortByValue
4188    
4189        my @keys = Tracer::SortByValue(\%hash);
4190    
4191    Get a list of hash table keys sorted by hash table values.
4192    
4193    =over 4
4194    
4195    =item hash
4196    
4197    Hash reference whose keys are to be extracted.
4198    
4199    =item RETURN
4200    
4201    Returns a list of the hash keys, ordered so that the corresponding hash values
4202    are in alphabetical sequence.
4203    
4204    =back
4205    
4206    =cut
4207    
4208    sub SortByValue {
4209        # Get the parameters.
4210        my ($hash) = @_;
4211        # Sort the hash's keys using the values.
4212        my @retVal = sort { Cmp($hash->{$a}, $hash->{$b}) } keys %$hash;
4213        # Return the result.
4214        return @retVal;
4215    }
4216    
4217    =head3 GetSet
4218    
4219        my $value = Tracer::GetSet($object, $name => $newValue);
4220    
4221    Get or set the value of an object field. The object is treated as an
4222    ordinary hash reference. If a new value is specified, it is stored in the
4223    hash under the specified name and then returned. If no new value is
4224    specified, the current value is returned.
4225    
4226    =over 4
4227    
4228    =item object
4229    
4230    Reference to the hash that is to be interrogated or updated.
4231    
4232    =item name
4233    
4234    Name of the field. This is the hash key.
4235    
4236    =item newValue (optional)
4237    
4238    New value to be stored in the field. If no new value is specified, the current
4239    value of the field is returned.
4240    
4241    =item RETURN
4242    
4243    Returns the value of the named field in the specified hash.
4244    
4245    =back
4246    
4247    =cut
4248    
4249    sub GetSet {
4250        # Get the parameters.
4251        my ($object, $name, $newValue) = @_;
4252        # Is a new value specified?
4253        if (defined $newValue) {
4254            # Yes, so store it.
4255            $object->{$name} = $newValue;
4256        }
4257        # Return the result.
4258        return $object->{$name};
4259    }
4260    
4261  1;  1;

Legend:
Removed from v.1.108  
changed lines
  Added in v.1.129

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3