[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.64, Thu Sep 14 23:06:00 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        use LWP::UserAgent;
35        use Time::HiRes 'gettimeofday';
36    
37  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
38    
# Line 275  Line 279 
279  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
280  can see this last in the command-line example above.  can see this last in the command-line example above.
281    
282    You can specify a different default trace level by setting C<$options->{trace}>
283    prior to calling this method.
284    
285  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
286  C<TransactFeatures>. It accepts a list of positional parameters plus the options  C<TransactFeatures>. It accepts a list of positional parameters plus the options
287  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 321 
321  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
322  upsetting the command-line utilities.  upsetting the command-line utilities.
323    
324    If the C<background> option is specified on the command line, then the
325    standard and error outputs will be directed to files in the temporary
326    directory, using the same suffix as the trace file. So, if the command
327    line specified
328    
329        -user=Bruce -background
330    
331    then the trace output would go to C<traceBruce.log>, the standard output to
332    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
333    simplify starting a command in the background.
334    
335  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
336  be traced at level 0 and the program will exit without processing.  be traced at level 0 and the program will exit without processing.
337  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 348 
348          -start    start with this genome          -start    start with this genome
349          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
350    
351    The caller has the option of modifying the tracing scheme by placing a value
352    for C<trace> in the incoming options hash. The default value can be overridden,
353    or the tracing to the standard output can be turned off by suffixing a minus
354    sign to the trace level. So, for example,
355    
356        { trace => [0, "tracing level (default 0)"],
357           ...
358    
359    would set the default trace level to 0 instead of 2, while
360    
361        { trace => ["2-", "tracing level (default 2)"],
362           ...
363    
364    would leave the default at 2, but trace only to the log file, not to the
365    standard output.
366    
367  The parameters to this method are as follows.  The parameters to this method are as follows.
368    
369  =over 4  =over 4
# Line 347  Line 381 
381  by specifying the options as command-line switches prefixed by a hyphen.  by specifying the options as command-line switches prefixed by a hyphen.
382  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
383  specified on the command line, the option descriptions will be used to  specified on the command line, the option descriptions will be used to
384  explain the options.  explain the options. To turn off tracing to the standard output, add a
385    minus sign to the value for C<trace> (see above).
386    
387  =item parmHelp  =item parmHelp
388    
389  A string that vaguely describes the positional parameters. This is used  A string that vaguely describes the positional parameters. This is used
390  if the user specifies the C<-h> option.  if the user specifies the C<-h> option.
391    
392  =item ARGV  =item argv
393    
394  List of command line parameters, including the option switches, which must  List of command line parameters, including the option switches, which must
395  precede the positional parameters and be prefixed by a hyphen.  precede the positional parameters and be prefixed by a hyphen.
# Line 374  Line 409 
409      # Get the parameters.      # Get the parameters.
410      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
411      # Add the tracing options.      # Add the tracing options.
412        if (! exists $options->{trace}) {
413      $options->{trace} = [2, "tracing level"];      $options->{trace} = [2, "tracing level"];
414        }
415      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
416      $options->{h} = [0, "display command-line options"];      $options->{h} = [0, "display command-line options"];
417      $options->{user} = [$$, "trace log file name suffix"];      $options->{user} = [$$, "trace log file name suffix"];
418        $options->{background} = [0, "spool standard and error output"];
419      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
420      # contains the default values rather than the default value      # contains the default values rather than the default value
421      # 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 430 
430      }      }
431      # Parse the command line.      # Parse the command line.
432      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
433        # Get the logfile suffix.
434        my $suffix = $retOptions->{user};
435        # Check for background mode.
436        if ($retOptions->{background}) {
437            my $outFileName = "$FIG_Config::temp/out$suffix.log";
438            my $errFileName = "$FIG_Config::temp/err$suffix.log";
439            open STDOUT, ">$outFileName";
440            open STDERR, ">$errFileName";
441        }
442      # 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
443      # be traced.      # be traced.
444      my @cats = @{$categories};      my @cats = @{$categories};
# Line 400  Line 447 
447      }      }
448      # Add the default categories.      # Add the default categories.
449      push @cats, "Tracer", "FIG";      push @cats, "Tracer", "FIG";
450      # Next, we create the category string by prefixing the trace level      # Next, we create the category string by joining the categories.
451      # and joining the categories.      my $cats = join(" ", @cats);
452      my $cats = join(" ", $parseOptions{trace}, @cats);      # Check to determine whether or not the caller wants to turn off tracing
453        # to the standard output.
454        my $traceLevel = $retOptions->{trace};
455        my $textOKFlag = 1;
456        if ($traceLevel =~ /^(.)-/) {
457            $traceLevel = $1;
458            $textOKFlag = 0;
459        }
460        # Now we set up the trace mode.
461        my $traceMode;
462        # Verify that we can open a file in the FIG temporary directory.
463        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
464        if (open TESTTRACE, ">$traceFileName") {
465            # Here we can trace to a file.
466            $traceMode = ">$traceFileName";
467            if ($textOKFlag) {
468                # Echo to standard output if the text-OK flag is set.
469                $traceMode = "+$traceMode";
470            }
471            # Close the test file.
472            close TESTTRACE;
473        } else {
474            # Here we can't trace to a file. We trace to the standard output if it's
475            # okay, and the error log otherwise.
476            if ($textOKFlag) {
477                $traceMode = "TEXT";
478            } else {
479                $traceMode = "WARN";
480            }
481        }
482      # Now set up the tracing.      # Now set up the tracing.
483      my $suffix = $retOptions->{user};      TSetup("$traceLevel $cats", $traceMode);
     TSetup($cats, "+>$FIG_Config::temp/trace$suffix.log");  
484      # 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
485      # options and exit the program.      # options and exit the program.
486      if ($retOptions->{h}) {      if ($retOptions->{h}) {
# Line 1275  Line 1350 
1350      return @inputList;      return @inputList;
1351  }  }
1352    
1353    =head3 Percent
1354    
1355    C<< my $percent = Tracer::Percent($number, $base); >>
1356    
1357    Returns the percent of the base represented by the given number. If the base
1358    is zero, returns zero.
1359    
1360    =over 4
1361    
1362    =item number
1363    
1364    Percent numerator.
1365    
1366    =item base
1367    
1368    Percent base.
1369    
1370    =item RETURN
1371    
1372    Returns the percentage of the base represented by the numerator.
1373    
1374    =back
1375    
1376    =cut
1377    
1378    sub Percent {
1379        # Get the parameters.
1380        my ($number, $base) = @_;
1381        # Declare the return variable.
1382        my $retVal = 0;
1383        # Compute the percent.
1384        if ($base != 0) {
1385            $retVal = $number * 100 / $base;
1386        }
1387        # Return the result.
1388        return $retVal;
1389    }
1390    
1391  =head3 GetFile  =head3 GetFile
1392    
1393  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
# Line 1308  Line 1421 
1421      # Declare the return variable.      # Declare the return variable.
1422      my @retVal = ();      my @retVal = ();
1423      # Open the file for input.      # Open the file for input.
1424      my $ok = open INPUTFILE, "<$fileName";      my $handle = Open(undef, "<$fileName");
     if (!$ok) {  
         # If we had an error, trace it. We will automatically return a null value.  
         Trace("Could not open \"$fileName\" for input: $!") if T(0);  
     } else {  
1425          # Read the whole file into the return variable, stripping off any terminator          # Read the whole file into the return variable, stripping off any terminator
1426          # characters.          # characters.
1427          my $lineCount = 0;          my $lineCount = 0;
1428          while (my $line = <INPUTFILE>) {      while (my $line = <$handle>) {
1429              $lineCount++;              $lineCount++;
1430              $line = Strip($line);              $line = Strip($line);
1431              push @retVal, $line;              push @retVal, $line;
1432          }          }
1433          # Close it.          # Close it.
1434          close INPUTFILE;      close $handle;
1435          my $actualLines = @retVal;          my $actualLines = @retVal;
     }  
1436      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1437      if (wantarray) {      if (wantarray) {
1438          return @retVal;          return @retVal;
# Line 1333  Line 1441 
1441      }      }
1442  }  }
1443    
1444    =head3 PutFile
1445    
1446    C<< Tracer::PutFile($fileName, \@lines); >>
1447    
1448    Write out a file from a list of lines of text.
1449    
1450    =over 4
1451    
1452    =item fileName
1453    
1454    Name of the output file.
1455    
1456    =item lines
1457    
1458    Reference to a list of text lines. The lines will be written to the file in order, with trailing
1459    new-line characters.
1460    
1461    =back
1462    
1463    =cut
1464    
1465    sub PutFile {
1466        # Get the parameters.
1467        my ($fileName, $lines) = @_;
1468        # Open the output file.
1469        my $handle = Open(undef, ">$fileName");
1470        # Write the lines.
1471        for my $line (@{$lines}) {
1472            print $handle "$line\n";
1473        }
1474        # Close the output file.
1475        close $handle;
1476    }
1477    
1478  =head3 QTrace  =head3 QTrace
1479    
1480  C<< my $data = QTrace($format); >>  C<< my $data = QTrace($format); >>
# Line 1533  Line 1675 
1675    
1676  =head3 AddToListMap  =head3 AddToListMap
1677    
1678  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1679    
1680  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
1681  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 1690 
1690    
1691  Key for which the value is to be added.  Key for which the value is to be added.
1692    
1693  =item value  =item value1, value2, ... valueN
1694    
1695  Value to add to the key's value list.  List of values to add to the key's value list.
1696    
1697  =back  =back
1698    
# Line 1558  Line 1700 
1700    
1701  sub AddToListMap {  sub AddToListMap {
1702      # Get the parameters.      # Get the parameters.
1703      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1704      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1705      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1706          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1707      } else {      } else {
1708          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1709      }      }
1710  }  }
1711    
# Line 1593  Line 1735 
1735          $retVal = 1;          $retVal = 1;
1736      } else {      } else {
1737          # Here debug mode is off, so we generate an error page.          # Here debug mode is off, so we generate an error page.
1738          my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");          my $pageString = PageBuilder::Build("<<Html/ErrorPage.html", {}, "Html");
1739          print $pageString;          print $pageString;
1740      }      }
1741      # Return the determination indicator.      # Return the determination indicator.
# Line 1860  Line 2002 
2002      # Check for a template file situation.      # Check for a template file situation.
2003      my $outputString;      my $outputString;
2004      if (defined $varHash) {      if (defined $varHash) {
2005          # Here we have a template file. We need to apply the variables to the template.          # Here we have a template file. We need to determine the template type.
2006          $outputString = PageBuilder::Build("<$webData", $varHash, "Html");          my $template;
2007            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
2008                $template = "$FIG_Config::template_url/$webData";
2009            } else {
2010                $template = "<<$webData";
2011            }
2012            $outputString = PageBuilder::Build($template, $varHash, "Html");
2013      } else {      } else {
2014          # Here the user gave us a raw string.          # Here the user gave us a raw string.
2015          $outputString = $webData;          $outputString = $webData;
# Line 1901  Line 2049 
2049      my ($dirName) = @_;      my ($dirName) = @_;
2050      if (! -d $dirName) {      if (! -d $dirName) {
2051          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(2);
2052          mkpath $dirName;          eval { mkpath $dirName; };
2053            if ($@) {
2054                Confess("Error creating $dirName: $@");
2055            }
2056        }
2057    }
2058    
2059    =head3 ChDir
2060    
2061    C<< ChDir($dirName); >>
2062    
2063    Change to the specified directory.
2064    
2065    =over 4
2066    
2067    =item dirName
2068    
2069    Name of the directory to which we want to change.
2070    
2071    =back
2072    
2073    =cut
2074    
2075    sub ChDir {
2076        my ($dirName) = @_;
2077        if (! -d $dirName) {
2078            Confess("Cannot change to directory $dirName: no such directory.");
2079        } else {
2080            Trace("Changing to directory $dirName.") if T(4);
2081            my $okFlag = chdir $dirName;
2082            if (! $okFlag) {
2083                Confess("Error switching to directory $dirName.");
2084      }      }
2085  }  }
2086    }
2087    
2088    =head3 SendSMS
2089    
2090    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2091    
2092    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2093    user name, password, and API ID for the relevant account in the hash reference variable
2094    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2095    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2096    is C<2561022>, then the FIG_Config file must contain
2097    
2098        $phone =  { user => 'BruceTheHumanPet',
2099                    password => 'silly',
2100                    api_id => '2561022' };
2101    
2102    The original purpose of this method was to insure Bruce would be notified immediately when the
2103    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2104    when you call this method.
2105    
2106    The message ID will be returned if successful, and C<undef> if an error occurs.
2107    
2108    =over 4
2109    
2110    =item phoneNumber
2111    
2112    Phone number to receive the message, in international format. A United States phone number
2113    would be prefixed by "1". A British phone number would be prefixed by "44".
2114    
2115    =item msg
2116    
2117    Message to send to the specified phone.
2118    
2119    =item RETURN
2120    
2121    Returns the message ID if successful, and C<undef> if the message could not be sent.
2122    
2123    =back
2124    
2125    =cut
2126    
2127    sub SendSMS {
2128        # Get the parameters.
2129        my ($phoneNumber, $msg) = @_;
2130        # Declare the return variable. If we do not change it, C<undef> will be returned.
2131        my $retVal;
2132        # Only proceed if we have phone support.
2133        if (! defined $FIG_Config::phone) {
2134            Trace("Phone support not present in FIG_Config.") if T(1);
2135        } else {
2136            # Get the phone data.
2137            my $parms = $FIG_Config::phone;
2138            # Get the Clickatell URL.
2139            my $url = "http://api.clickatell.com/http/";
2140            # Create the user agent.
2141            my $ua = LWP::UserAgent->new;
2142            # Request a Clickatell session.
2143            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2144                                         password => $parms->{password},
2145                                         api_id => $parms->{api_id},
2146                                         to => $phoneNumber,
2147                                         text => $msg});
2148            # Check for an error.
2149            if (! $resp->is_success) {
2150                Trace("Alert failed.") if T(1);
2151            } else {
2152                # Get the message ID.
2153                my $rstring = $resp->content;
2154                if ($rstring =~ /^ID:\s+(.*)$/) {
2155                    $retVal = $1;
2156                } else {
2157                    Trace("Phone attempt failed with $rstring") if T(1);
2158                }
2159            }
2160        }
2161        # Return the result.
2162        return $retVal;
2163    }
2164    
2165    =head3 CommaFormat
2166    
2167    C<< my $formatted = Tracer::CommaFormat($number); >>
2168    
2169    Insert commas into a number.
2170    
2171    =over 4
2172    
2173    =item number
2174    
2175    A sequence of digits.
2176    
2177    =item RETURN
2178    
2179    Returns the same digits with commas strategically inserted.
2180    
2181    =back
2182    
2183    =cut
2184    
2185    sub CommaFormat {
2186        # Get the parameters.
2187        my ($number) = @_;
2188        # Pad the length up to a multiple of three.
2189        my $padded = "$number";
2190        $padded = " " . $padded while length($padded) % 3 != 0;
2191        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2192        # cause the delimiters to be included in the output stream. The
2193        # GREP removes the empty strings in between the delimiters.
2194        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2195        # Clean out the spaces.
2196        $retVal =~ s/ //g;
2197        # Return the result.
2198        return $retVal;
2199    }
2200    =head3 SetPermissions
2201    
2202    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2203    
2204    Set the permissions for a directory and all the files and folders inside it.
2205    In addition, the group ownership will be changed to the specified value.
2206    
2207    This method is more vulnerable than most to permission and compatability
2208    problems, so it does internal error recovery.
2209    
2210    =over 4
2211    
2212    =item dirName
2213    
2214    Name of the directory to process.
2215    
2216    =item group
2217    
2218    Name of the group to be assigned.
2219    
2220    =item mask
2221    
2222    Permission mask. Bits that are C<1> in this mask will be ORed into the
2223    permission bits of any file or directory that does not already have them
2224    set to 1.
2225    
2226    =item otherMasks
2227    
2228    Map of search patterns to permission masks. If a directory name matches
2229    one of the patterns, that directory and all its members and subdirectories
2230    will be assigned the new pattern. For example, the following would
2231    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2232    
2233        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2234    
2235    The list is ordered, so the following would use 0777 for C<tmp1> and
2236    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2237    
2238        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2239                                                       '^tmp' => 0666);
2240    
2241    Note that the pattern matches are all case-insensitive, and only directory
2242    names are matched, not file names.
2243    
2244    =back
2245    
2246    =cut
2247    
2248    sub SetPermissions {
2249        # Get the parameters.
2250        my ($dirName, $group, $mask, @otherMasks) = @_;
2251        # Set up for error recovery.
2252        eval {
2253            # Switch to the specified directory.
2254            ChDir($dirName);
2255            # Get the group ID.
2256            my $gid = getgrnam($group);
2257            # Get the mask for tracing.
2258            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2259            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2260            my $fixCount = 0;
2261            my $lookCount = 0;
2262            # @dirs will be a stack of directories to be processed.
2263            my @dirs = (getcwd());
2264            while (scalar(@dirs) > 0) {
2265                # Get the current directory.
2266                my $dir = pop @dirs;
2267                # Check for a match to one of the specified directory names. To do
2268                # that, we need to pull the individual part of the name off of the
2269                # whole path.
2270                my $simpleName = $dir;
2271                if ($dir =~ m!/([^/]+)$!) {
2272                    $simpleName = $1;
2273                }
2274                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2275                # Search for a match.
2276                my $match = 0;
2277                my $i;
2278                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2279                    my $pattern = $otherMasks[$i];
2280                    if ($simpleName =~ /$pattern/i) {
2281                        $match = 1;
2282                    }
2283                }
2284                # Check for a match. Note we use $i-1 because the loop added 2
2285                # before terminating due to the match.
2286                if ($match && $otherMasks[$i-1] != $mask) {
2287                    # This directory matches one of the incoming patterns, and it's
2288                    # a different mask, so we process it recursively with that mask.
2289                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2290                } else {
2291                    # Here we can process normally. Get all of the non-hidden members.
2292                    my @submems = OpenDir($dir, 1);
2293                    for my $submem (@submems) {
2294                        # Get the full name.
2295                        my $thisMem = "$dir/$submem";
2296                        Trace("Checking member $thisMem.") if T(4);
2297                        $lookCount++;
2298                        if ($lookCount % 1000 == 0) {
2299                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2300                        }
2301                        # Fix the group.
2302                        chown -1, $gid, $thisMem;
2303                        # Insure this member is not a symlink.
2304                        if (! -l $thisMem) {
2305                            # Get its info.
2306                            my $fileInfo = stat $thisMem;
2307                            # Only proceed if we got the info. Otherwise, it's a hard link
2308                            # and we want to skip it anyway.
2309                            if ($fileInfo) {
2310                                my $fileMode = $fileInfo->mode;
2311                                if (($fileMode & $mask) != $mask) {
2312                                    # Fix this member.
2313                                    $fileMode |= $mask;
2314                                    chmod $fileMode, $thisMem;
2315                                    $fixCount++;
2316                                }
2317                                # If it's a subdirectory, stack it.
2318                                if (-d $thisMem) {
2319                                    push @dirs, $thisMem;
2320                                }
2321                            }
2322                        }
2323                    }
2324                }
2325            }
2326            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2327        };
2328        # Check for an error.
2329        if ($@) {
2330            Confess("SetPermissions error: $@");
2331        }
2332    }
2333    
2334    =head3 CompareLists
2335    
2336    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2337    
2338    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2339    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2340    The return value contains a list of items that are only in the new list
2341    (inserted) and only in the old list (deleted).
2342    
2343    =over 4
2344    
2345    =item newList
2346    
2347    Reference to a list of new tuples.
2348    
2349    =item oldList
2350    
2351    Reference to a list of old tuples.
2352    
2353    =item keyIndex (optional)
2354    
2355    Index into each tuple of its key field. The default is 0.
2356    
2357    =item RETURN
2358    
2359    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2360    list (inserted) followed by a reference to the list of items that are only in the old
2361    list (deleted).
2362    
2363    =back
2364    
2365    =cut
2366    
2367    sub CompareLists {
2368        # Get the parameters.
2369        my ($newList, $oldList, $keyIndex) = @_;
2370        if (! defined $keyIndex) {
2371            $keyIndex = 0;
2372        }
2373        # Declare the return variables.
2374        my ($inserted, $deleted) = ([], []);
2375        # Loop through the two lists simultaneously.
2376        my ($newI, $oldI) = (0, 0);
2377        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2378        while ($newI < $newN || $oldI < $oldN) {
2379            # Get the current object in each list. Note that if one
2380            # of the lists is past the end, we'll get undef.
2381            my $newItem = $newList->[$newI];
2382            my $oldItem = $oldList->[$oldI];
2383            if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2384                # The old item is not in the new list, so mark it deleted.
2385                push @{$deleted}, $oldItem;
2386                $oldI++;
2387            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2388                # The new item is not in the old list, so mark it inserted.
2389                push @{$inserted}, $newItem;
2390                $newI++;
2391            } else {
2392                # The item is in both lists, so push forward.
2393                $oldI++;
2394                $newI++;
2395            }
2396        }
2397        # Return the result.
2398        return ($inserted, $deleted);
2399    }
2400    
2401  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3