[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.39, Fri Feb 24 19:45:29 2006 UTC revision 1.58, Thu Jun 29 19:02:48 2006 UTC
# Line 19  Line 19 
19    
20      require Exporter;      require Exporter;
21      @ISA = ('Exporter');      @ISA = ('Exporter');
22      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup ScriptSetup ScriptFinish Insure);      @EXPORT = qw(Trace T TSetup QTrace Confess Cluck Min Max Assert Open OpenDir TICK StandardSetup ScriptSetup ScriptFinish Insure ChDir);
23      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);      @EXPORT_OK = qw(GetFile GetOptions Merge MergeOptions ParseCommand ParseRecord UnEscape Escape);
24      use strict;      use strict;
25      use Carp qw(longmess croak);      use Carp qw(longmess croak);
26      use CGI;      use CGI;
27        use Cwd;
28      use FIG_Config;      use FIG_Config;
29      use PageBuilder;      use PageBuilder;
30      use Digest::MD5;      use Digest::MD5;
31      use File::Basename;      use File::Basename;
32      use File::Path;      use File::Path;
33        use File::stat;
34    
35  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
36    
# Line 275  Line 277 
277  of a keyword, the value is separated from the option name by an equal sign. You  of a keyword, the value is separated from the option name by an equal sign. You
278  can see this last in the command-line example above.  can see this last in the command-line example above.
279    
280    You can specify a different default trace level by setting C<$options->{trace}>
281    prior to calling this method.
282    
283  An example at this point would help. Consider, for example, the command-line utility  An example at this point would help. Consider, for example, the command-line utility
284  C<TransactFeatures>. It accepts a list of positional parameters plus the options  C<TransactFeatures>. It accepts a list of positional parameters plus the options
285  C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute  C<safe>, C<noAlias>, C<start>, and C<tblFiles>. To start up this command, we execute
# Line 314  Line 319 
319  need to be added in the future, they can be processed by this method without  need to be added in the future, they can be processed by this method without
320  upsetting the command-line utilities.  upsetting the command-line utilities.
321    
322    If the C<background> option is specified on the command line, then the
323    standard and error outputs will be directed to files in the temporary
324    directory, using the same suffix as the trace file. So, if the command
325    line specified
326    
327        -user=Bruce -background
328    
329    then the trace output would go to C<traceBruce.log>, the standard output to
330    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
331    simplify starting a command in the background.
332    
333  Finally, if the special option C<-h> is specified, the option names will  Finally, if the special option C<-h> is specified, the option names will
334  be traced at level 0 and the program will exit without processing.  be traced at level 0 and the program will exit without processing.
335  This provides a limited help capability. For example, if the user enters  This provides a limited help capability. For example, if the user enters
# Line 330  Line 346 
346          -start    start with this genome          -start    start with this genome
347          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
348    
349    The caller has the option of modifying the tracing scheme by placing a value
350    for C<trace> in the incoming options hash. The default value can be overridden,
351    or the tracing to the standard output can be turned off by suffixing a minus
352    sign to the trace level. So, for example,
353    
354        { trace => [0, "tracing level (default 0)"],
355           ...
356    
357    would set the default trace level to 0 instead of 2, while
358    
359        { trace => ["2-", "tracing level (default 2)"],
360           ...
361    
362    would leave the default at 2, but trace only to the log file, not to the
363    standard output.
364    
365  The parameters to this method are as follows.  The parameters to this method are as follows.
366    
367  =over 4  =over 4
# Line 347  Line 379 
379  by specifying the options as command-line switches prefixed by a hyphen.  by specifying the options as command-line switches prefixed by a hyphen.
380  Tracing-related options may be added to this hash. If the C<-h> option is  Tracing-related options may be added to this hash. If the C<-h> option is
381  specified on the command line, the option descriptions will be used to  specified on the command line, the option descriptions will be used to
382  explain the options.  explain the options. To turn off tracing to the standard output, add a
383    minus sign to the value for C<trace> (see above).
384    
385  =item parmHelp  =item parmHelp
386    
387  A string that vaguely describes the positional parameters. This is used  A string that vaguely describes the positional parameters. This is used
388  if the user specifies the C<-h> option.  if the user specifies the C<-h> option.
389    
390  =item ARGV  =item argv
391    
392  List of command line parameters, including the option switches, which must  List of command line parameters, including the option switches, which must
393  precede the positional parameters and be prefixed by a hyphen.  precede the positional parameters and be prefixed by a hyphen.
# Line 374  Line 407 
407      # Get the parameters.      # Get the parameters.
408      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
409      # Add the tracing options.      # Add the tracing options.
410        if (! exists $options->{trace}) {
411      $options->{trace} = [2, "tracing level"];      $options->{trace} = [2, "tracing level"];
412        }
413      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
414      $options->{h} = [0, "display command-line options"];      $options->{h} = [0, "display command-line options"];
415      $options->{user} = [$$, "trace log file name suffix"];      $options->{user} = [$$, "trace log file name suffix"];
416        $options->{background} = [0, "spool standard and error output"];
417      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
418      # contains the default values rather than the default value      # contains the default values rather than the default value
419      # 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 392  Line 428 
428      }      }
429      # Parse the command line.      # Parse the command line.
430      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
431        # Get the logfile suffix.
432        my $suffix = $retOptions->{user};
433        # Check for background mode.
434        if ($retOptions->{background}) {
435            my $outFileName = "$FIG_Config::temp/out$suffix.log";
436            my $errFileName = "$FIG_Config::temp/err$suffix.log";
437            open STDOUT, ">$outFileName";
438            open STDERR, ">$errFileName";
439        }
440      # Now we want to set up tracing. First, we need to know if SQL is to      # Now we want to set up tracing. First, we need to know if SQL is to
441      # be traced.      # be traced.
442      my @cats = @{$categories};      my @cats = @{$categories};
# Line 400  Line 445 
445      }      }
446      # Add the default categories.      # Add the default categories.
447      push @cats, "Tracer", "FIG";      push @cats, "Tracer", "FIG";
448      # Next, we create the category string by prefixing the trace level      # Next, we create the category string by joining the categories.
449      # and joining the categories.      my $cats = join(" ", @cats);
450      my $cats = join(" ", $parseOptions{trace}, @cats);      # Check to determine whether or not the caller wants to turn off tracing
451        # to the standard output.
452        my $traceLevel = $retOptions->{trace};
453        my $textOKFlag = 1;
454        if ($traceLevel =~ /^(.)-/) {
455            $traceLevel = $1;
456            $textOKFlag = 0;
457        }
458        # Now we set up the trace mode.
459        my $traceMode;
460        # Verify that we can open a file in the FIG temporary directory.
461        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
462        if (open TESTTRACE, ">$traceFileName") {
463            # Here we can trace to a file.
464            $traceMode = ">$traceFileName";
465            if ($textOKFlag) {
466                # Echo to standard output if the text-OK flag is set.
467                $traceMode = "+$traceMode";
468            }
469            # Close the test file.
470            close TESTTRACE;
471        } else {
472            # Here we can't trace to a file. We trace to the standard output if it's
473            # okay, and the error log otherwise.
474            if ($textOKFlag) {
475                $traceMode = "TEXT";
476            } else {
477                $traceMode = "WARN";
478            }
479        }
480      # Now set up the tracing.      # Now set up the tracing.
481      my $suffix = $retOptions->{user};      TSetup("$traceLevel $cats", $traceMode);
     TSetup($cats, "+>$FIG_Config::temp/trace$suffix.log");  
482      # Check for the "h" option. If it is specified, dump the command-line      # Check for the "h" option. If it is specified, dump the command-line
483      # options and exit the program.      # options and exit the program.
484      if ($retOptions->{h}) {      if ($retOptions->{h}) {
# Line 1275  Line 1348 
1348      return @inputList;      return @inputList;
1349  }  }
1350    
1351    =head3 Percent
1352    
1353    C<< my $percent = Tracer::Percent($number, $base); >>
1354    
1355    Returns the percent of the base represented by the given number. If the base
1356    is zero, returns zero.
1357    
1358    =over 4
1359    
1360    =item number
1361    
1362    Percent numerator.
1363    
1364    =item base
1365    
1366    Percent base.
1367    
1368    =item RETURN
1369    
1370    Returns the percentage of the base represented by the numerator.
1371    
1372    =back
1373    
1374    =cut
1375    
1376    sub Percent {
1377        # Get the parameters.
1378        my ($number, $base) = @_;
1379        # Declare the return variable.
1380        my $retVal = 0;
1381        # Compute the percent.
1382        if ($base != 0) {
1383            $retVal = $number * 100 / $base;
1384        }
1385        # Return the result.
1386        return $retVal;
1387    }
1388    
1389  =head3 GetFile  =head3 GetFile
1390    
1391  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
# Line 1533  Line 1644 
1644    
1645  =head3 AddToListMap  =head3 AddToListMap
1646    
1647  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1648    
1649  Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list  Add a key-value pair to a hash of lists. If no value exists for the key, a singleton list
1650  is created for the key. Otherwise, the new value is pushed onto the list.  is created for the key. Otherwise, the new value is pushed onto the list.
# Line 1548  Line 1659 
1659    
1660  Key for which the value is to be added.  Key for which the value is to be added.
1661    
1662  =item value  =item value1, value2, ... valueN
1663    
1664  Value to add to the key's value list.  List of values to add to the key's value list.
1665    
1666  =back  =back
1667    
# Line 1558  Line 1669 
1669    
1670  sub AddToListMap {  sub AddToListMap {
1671      # Get the parameters.      # Get the parameters.
1672      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1673      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1674      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1675          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1676      } else {      } else {
1677          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1678      }      }
1679  }  }
1680    
# Line 1901  Line 2012 
2012      my ($dirName) = @_;      my ($dirName) = @_;
2013      if (! -d $dirName) {      if (! -d $dirName) {
2014          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(2);
2015          mkpath $dirName;          eval { mkpath $dirName; };
2016            if ($@) {
2017                Confess("Error creating $dirName: $@");
2018            }
2019        }
2020    }
2021    
2022    =head3 ChDir
2023    
2024    C<< ChDir($dirName); >>
2025    
2026    Change to the specified directory.
2027    
2028    =over 4
2029    
2030    =item dirName
2031    
2032    Name of the directory to which we want to change.
2033    
2034    =back
2035    
2036    =cut
2037    
2038    sub ChDir {
2039        my ($dirName) = @_;
2040        if (! -d $dirName) {
2041            Confess("Cannot change to directory $dirName: no such directory.");
2042        } else {
2043            Trace("Changing to directory $dirName.") if T(4);
2044            my $okFlag = chdir $dirName;
2045            if (! $okFlag) {
2046                Confess("Error switching to directory $dirName.");
2047            }
2048        }
2049    }
2050    
2051    =head3 CommaFormat
2052    
2053    C<< my $formatted = Tracer::CommaFormat($number); >>
2054    
2055    Insert commas into a number.
2056    
2057    =over 4
2058    
2059    =item number
2060    
2061    A sequence of digits.
2062    
2063    =item RETURN
2064    
2065    Returns the same digits with commas strategically inserted.
2066    
2067    =back
2068    
2069    =cut
2070    
2071    sub CommaFormat {
2072        # Get the parameters.
2073        my ($number) = @_;
2074        # Pad the length up to a multiple of three.
2075        my $padded = "$number";
2076        $padded = " " . $padded while length($padded) % 3 != 0;
2077        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2078        # cause the delimiters to be included in the output stream. The
2079        # GREP removes the empty strings in between the delimiters.
2080        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2081        # Clean out the spaces.
2082        $retVal =~ s/ //g;
2083        # Return the result.
2084        return $retVal;
2085    }
2086    =head3 SetPermissions
2087    
2088    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2089    
2090    Set the permissions for a directory and all the files and folders inside it.
2091    In addition, the group ownership will be changed to the specified value.
2092    
2093    This method is more vulnerable than most to permission and compatability
2094    problems, so it does internal error recovery.
2095    
2096    =over 4
2097    
2098    =item dirName
2099    
2100    Name of the directory to process.
2101    
2102    =item group
2103    
2104    Name of the group to be assigned.
2105    
2106    =item mask
2107    
2108    Permission mask. Bits that are C<1> in this mask will be ORed into the
2109    permission bits of any file or directory that does not already have them
2110    set to 1.
2111    
2112    =item otherMasks
2113    
2114    Map of search patterns to permission masks. If a directory name matches
2115    one of the patterns, that directory and all its members and subdirectories
2116    will be assigned the new pattern. For example, the following would
2117    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2118    
2119        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2120    
2121    The list is ordered, so the following would use 0777 for C<tmp1> and
2122    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2123    
2124        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2125                                                       '^tmp' => 0666);
2126    
2127    Note that the pattern matches are all case-insensitive, and only directory
2128    names are matched, not file names.
2129    
2130    =back
2131    
2132    =cut
2133    
2134    sub SetPermissions {
2135        # Get the parameters.
2136        my ($dirName, $group, $mask, @otherMasks) = @_;
2137        # Set up for error recovery.
2138        eval {
2139            # Switch to the specified directory.
2140            ChDir($dirName);
2141            # Get the group ID.
2142            my $gid = getgrnam($group);
2143            # Get the mask for tracing.
2144            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2145            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2146            my $fixCount = 0;
2147            my $lookCount = 0;
2148            # @dirs will be a stack of directories to be processed.
2149            my @dirs = (getcwd());
2150            while (scalar(@dirs) > 0) {
2151                # Get the current directory.
2152                my $dir = pop @dirs;
2153                # Check for a match to one of the specified directory names. To do
2154                # that, we need to pull the individual part of the name off of the
2155                # whole path.
2156                my $simpleName = $dir;
2157                if ($dir =~ m!/([^/]+)$!) {
2158                    $simpleName = $1;
2159                }
2160                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2161                # Search for a match.
2162                my $match = 0;
2163                my $i;
2164                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2165                    my $pattern = $otherMasks[$i];
2166                    if ($simpleName =~ /$pattern/i) {
2167                        $match = 1;
2168                    }
2169                }
2170                # Check for a match. Note we use $i-1 because the loop added 2
2171                # before terminating due to the match.
2172                if ($match && $otherMasks[$i-1] != $mask) {
2173                    # This directory matches one of the incoming patterns, and it's
2174                    # a different mask, so we process it recursively with that mask.
2175                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2176                } else {
2177                    # Here we can process normally. Get all of the non-hidden members.
2178                    my @submems = OpenDir($dir, 1);
2179                    for my $submem (@submems) {
2180                        # Get the full name.
2181                        my $thisMem = "$dir/$submem";
2182                        Trace("Checking member $thisMem.") if T(4);
2183                        $lookCount++;
2184                        if ($lookCount % 1000 == 0) {
2185                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2186                        }
2187                        # Fix the group.
2188                        chown -1, $gid, $thisMem;
2189                        # Insure this member is not a symlink.
2190                        if (! -l $thisMem) {
2191                            # Get its info.
2192                            my $fileInfo = stat $thisMem;
2193                            # Only proceed if we got the info. Otherwise, it's a hard link
2194                            # and we want to skip it anyway.
2195                            if ($fileInfo) {
2196                                my $fileMode = $fileInfo->mode;
2197                                if (($fileMode & $mask) != $mask) {
2198                                    # Fix this member.
2199                                    $fileMode |= $mask;
2200                                    chmod $fileMode, $thisMem;
2201                                    $fixCount++;
2202                                }
2203                                # If it's a subdirectory, stack it.
2204                                if (-d $thisMem) {
2205                                    push @dirs, $thisMem;
2206                                }
2207                            }
2208                        }
2209                    }
2210                }
2211            }
2212            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2213        };
2214        # Check for an error.
2215        if ($@) {
2216            Confess("SetPermissions error: $@");
2217      }      }
2218  }  }
2219    

Legend:
Removed from v.1.39  
changed lines
  Added in v.1.58

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3