[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.114, Thu Oct 16 22:27:09 2008 UTC revision 1.115, Mon Jan 19 20:50:17 2009 UTC
# Line 18  Line 18 
18    
19  package Tracer;  package Tracer;
20    
     require Exporter;  
     @ISA = ('Exporter');  
     @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup EmergencyKey ETracing Constrain Insure ChDir Emergency 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 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 39  Line 39 
39      use POSIX qw(strftime);      use POSIX qw(strftime);
40      use Time::Zone;      use Time::Zone;
41      use Fcntl qw(:DEFAULT :flock);      use Fcntl qw(:DEFAULT :flock);
42        use Data::Dumper;
43    
44    
45  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
# Line 504  Line 505 
505      }      }
506  }  }
507    
508    =head3 TraceDump
509    
510        TraceDump($title, $object);
511    
512    Dump an object to the trace log. This method simply calls the C<Dumper>
513    function, but routes the output to the trace log instead of returning it
514    as a string. The output is arranged so that it comes out monospaced when
515    it appears in an HTML trace dump.
516    
517    =over 4
518    
519    =item title
520    
521    Title to give to the object being dumped.
522    
523    =item object
524    
525    Reference to a list, hash, or object to dump.
526    
527    =back
528    
529    =cut
530    
531    sub TraceDump {
532        # Get the parameters.
533        my ($title, $object) = @_;
534        # Trace the object.
535        Trace("Object dump for $title:\n" . Dumper($object));
536    }
537    
538  =head3 T  =head3 T
539    
540      my $switch = T($category, $traceLevel);      my $switch = T($category, $traceLevel);
# Line 646  Line 677 
677      # Set up the category and level.      # Set up the category and level.
678      $LastCategory = "(confess)";      $LastCategory = "(confess)";
679      $LastLevel = 0;      $LastLevel = 0;
     if (! defined($FIG_Config::no_tool_hdr)) {  
         # Here we have a tool header. Display its length so that the user can adjust the line numbers.  
         my $toolHeaderFile = "$FIG_Config::fig_disk/dist/releases/current/$FIG_Config::arch/tool_hdr";  
         # Only proceed if the tool header file is actually present.  
         if (-f $toolHeaderFile) {  
             my $fh;  
             if (open $fh, "<$toolHeaderFile") {  
                 my @lines = <$fh>;  
                 Trace("Tool header has " . scalar(@lines) . " lines.");  
             }  
         }  
     }  
680      # Trace the call stack.      # Trace the call stack.
681      Cluck($message);      Cluck($message);
682      # Abort the program.      # Abort the program.
# Line 1311  Line 1330 
1330      # Get the parameters.      # Get the parameters.
1331      my ($cgi) = @_;      my ($cgi) = @_;
1332      if (T(CGI => 2)) {      if (T(CGI => 2)) {
1333          # Here we trace the GET-style URL for the script.          # Here we trace the GET-style URL for the script, but only if it's
1334          Trace("[URL] " . $cgi->url(-relative => 1, -query => 1));          # relatively small.
1335            my $url = $cgi->url(-relative => 1, -query => 1);
1336            my $len = length($url);
1337            if ($len < 500) {
1338                Trace("[URL] $url");
1339            } elsif ($len > 2048) {
1340                Trace("[URL] URL is too long to use with GET ($len characters).");
1341            } else {
1342                Trace("[URL] URL length is $len characters.");
1343            }
1344      }      }
1345      if (T(CGI => 3)) {      if (T(CGI => 3)) {
1346          # Here we want to trace the parameter data.          # Here we want to trace the parameter data.
# Line 2815  Line 2843 
2843    
2844  =head2 Other Useful Methods  =head2 Other Useful Methods
2845    
2846    =head3 IDHASH
2847    
2848        my $hash = SHTargetSearch::IDHASH(@keys);
2849    
2850    This is a dinky little method that converts a list of values to a reference
2851    to hash of values to labels. The values and labels are the same.
2852    
2853    =cut
2854    
2855    sub IDHASH {
2856        my %retVal = map { $_ => $_ } @_;
2857        return \%retVal;
2858    }
2859    
2860    =head3 Pluralize
2861    
2862        my $plural = Tracer::Pluralize($word);
2863    
2864    This is a very simple pluralization utility. It adds an C<s> at the end
2865    of the input word unless it already ends in an C<s>, in which case it
2866    adds C<es>.
2867    
2868    =over 4
2869    
2870    =item word
2871    
2872    Singular word to pluralize.
2873    
2874    =item RETURN
2875    
2876    Returns the probable plural form of the word.
2877    
2878    =back
2879    
2880    =cut
2881    
2882    sub Pluralize {
2883        # Get the parameters.
2884        my ($word) = @_;
2885        # Declare the return variable.
2886        my $retVal;
2887        if ($word =~ /s$/) {
2888            $retVal = $word . 'es';
2889        } else {
2890            $retVal = $word . 's';
2891        }
2892        # Return the result.
2893        return $retVal;
2894    }
2895    
2896    =head3 Numeric
2897    
2898        my $okFlag = Tracer::Numeric($string);
2899    
2900    Return the value of the specified string if it is numeric, or an undefined value
2901    if it is not numeric.
2902    
2903    =over 4
2904    
2905    =item string
2906    
2907    String to check.
2908    
2909    =item RETURN
2910    
2911    Returns the numeric value of the string if successful, or C<undef> if the string
2912    is not numeric.
2913    
2914    =back
2915    
2916    =cut
2917    
2918    sub Numeric {
2919        # Get the parameters.
2920        my ($string) = @_;
2921        # We'll put the value in here if we succeed.
2922        my $retVal;
2923        # Get a working copy of the string.
2924        my $copy = $string;
2925        # Trim leading and trailing spaces.
2926        $copy =~ s/^\s+//;
2927        $copy =~ s/\s+$//;
2928        # Check the result.
2929        if ($copy =~ /^[+-]?\d+$/) {
2930            $retVal = $copy;
2931        } elsif ($copy =~ /^([+-]\d+|\d*)[eE][+-]?\d+$/) {
2932            $retVal = $copy;
2933        } elsif ($copy =~ /^([+-]\d+|\d*)\.\d*([eE][+-]?\d+)?$/) {
2934            $retVal = $copy;
2935        }
2936        # Return the result.
2937        return $retVal;
2938    }
2939    
2940    
2941  =head3 ParseParm  =head3 ParseParm
2942    
2943      my $listValue = Tracer::ParseParm($string);      my $listValue = Tracer::ParseParm($string);
# Line 3057  Line 3180 
3180      return $retVal;      return $retVal;
3181  }  }
3182    
3183    =head3 In
3184    
3185        my $flag = Tracer::In($value, $min, $max);
3186    
3187    Return TRUE if the value is between the minimum and the maximum, else FALSE.
3188    
3189    =cut
3190    
3191    sub In {
3192        return ($_[0] <= $_[2] && $_[0] >= $_[1]);
3193    }
3194    
3195    
3196  =head3 Constrain  =head3 Constrain
3197    
3198      my $constrained = Constrain($value, $min, $max);      my $constrained = Constrain($value, $min, $max);
# Line 3200  Line 3336 
3336      return $retVal;      return $retVal;
3337  }  }
3338    
3339    =head3 Trim
3340    
3341        my $string = Tracer::Trim($line);
3342    
3343    Trim all spaces from the beginning and ending of a string.
3344    
3345    =over 4
3346    
3347    =item line
3348    
3349    Line of text to be trimmed.
3350    
3351    =item RETURN
3352    
3353    The same line of text with all whitespace chopped off either end.
3354    
3355    =back
3356    
3357    =cut
3358    
3359    sub Trim {
3360        # Get a copy of the parameter string.
3361        my ($string) = @_;
3362        my $retVal = (defined $string ? $string : "");
3363        # Strip the front spaces.
3364        $retVal =~ s/^\s+//;
3365        # Strip the back spaces.
3366        $retVal =~ s/\s+$//;
3367        # Return the result.
3368        return $retVal;
3369    }
3370    
3371  =head3 Pad  =head3 Pad
3372    
3373      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);      my $paddedString = Tracer::Pad($string, $len, $left, $padChar);
# Line 3461  Line 3629 
3629          $retVal = 1;          $retVal = 1;
3630      } else {      } else {
3631          # Here we have two real values. Parse the two strings.          # Here we have two real values. Parse the two strings.
3632          $a =~ /^(\D*)(\d*)$/;          my $aParsed = _Parse($a);
3633          my $aParsed = [$1, $2];          my $bParsed = _Parse($b);
3634          $b =~ /^(\D*)(\d*)$/;          # Compare the string parts insensitively.
3635          my $bParsed = [$1, $2];          $retVal = (lc $aParsed->[0] cmp lc $bParsed->[0]);
3636          # Compare the string parts.          # If they're equal, compare them sensitively.
3637          $retVal = $aParsed->[0] cmp $bParsed->[0];          if (! $retVal) {
3638                $retVal = ($aParsed->[0] cmp $bParsed->[0]);
3639            }
3640            # If they're STILL equal, compare the number parts.
3641          if (! $retVal) {          if (! $retVal) {
3642              $retVal = $aParsed->[1] <=> $bParsed->[1];              $retVal = $aParsed->[1] <=> $bParsed->[1];
3643          }          }
# Line 3475  Line 3646 
3646      return $retVal;      return $retVal;
3647  }  }
3648    
3649    # This method parses an input string into a string part and a number part.
3650    sub _Parse {
3651        my ($string) = @_;
3652        my ($alpha, $num);
3653        if ($string =~ /^(.*?)(\d+(?:\.\d+)?)$/) {
3654            $alpha = $1;
3655            $num = $2;
3656        } else {
3657            $alpha = $string;
3658            $num = 0;
3659        }
3660        return [$alpha, $num];
3661    }
3662    
3663  =head3 ListEQ  =head3 ListEQ
3664    
3665      my $flag = Tracer::ListEQ(\@a, \@b);      my $flag = Tracer::ListEQ(\@a, \@b);
# Line 3864  Line 4049 
4049      return $retVal;      return $retVal;
4050  }  }
4051    
4052    =head3 SortByValue
4053    
4054        my @keys = Tracer::SortByValue(\%hash);
4055    
4056    Get a list of hash table keys sorted by hash table values.
4057    
4058    =over 4
4059    
4060    =item hash
4061    
4062    Hash reference whose keys are to be extracted.
4063    
4064    =item RETURN
4065    
4066    Returns a list of the hash keys, ordered so that the corresponding hash values
4067    are in alphabetical sequence.
4068    
4069    =back
4070    
4071    =cut
4072    
4073    sub SortByValue {
4074        # Get the parameters.
4075        my ($hash) = @_;
4076        # Sort the hash's keys using the values.
4077        my @retVal = sort { Cmp($hash->{$a}, $hash->{$b}) } keys %$hash;
4078        # Return the result.
4079        return @retVal;
4080    }
4081    
4082    =head3 GetSet
4083    
4084        my $value = Tracer::GetSet($object, $name => $newValue);
4085    
4086    Get or set the value of an object field. The object is treated as an
4087    ordinary hash reference. If a new value is specified, it is stored in the
4088    hash under the specified name and then returned. If no new value is
4089    specified, the current value is returned.
4090    
4091    =over 4
4092    
4093    =item object
4094    
4095    Reference to the hash that is to be interrogated or updated.
4096    
4097    =item name
4098    
4099    Name of the field. This is the hash key.
4100    
4101    =item newValue (optional)
4102    
4103    New value to be stored in the field. If no new value is specified, the current
4104    value of the field is returned.
4105    
4106    =item RETURN
4107    
4108    Returns the value of the named field in the specified hash.
4109    
4110    =back
4111    
4112    =cut
4113    
4114    sub GetSet {
4115        # Get the parameters.
4116        my ($object, $name, $newValue) = @_;
4117        # Is a new value specified?
4118        if (defined $newValue) {
4119            # Yes, so store it.
4120            $object->{$name} = $newValue;
4121        }
4122        # Return the result.
4123        return $object->{$name};
4124    }
4125    
4126  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3