[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.68, Fri Sep 29 19:48:01 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        use URI::Escape;
37    
38  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
39    
# Line 275  Line 280 
280  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
281  can see this last in the command-line example above.  can see this last in the command-line example above.
282    
283    You can specify a different default trace level by setting C<$options->{trace}>
284    prior to calling this method.
285    
286  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
287  C<TransactFeatures>. It accepts a list of positional parameters plus the options  C<TransactFeatures>. It accepts a list of positional parameters plus the options
288  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 322 
322  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
323  upsetting the command-line utilities.  upsetting the command-line utilities.
324    
325    If the C<background> option is specified on the command line, then the
326    standard and error outputs will be directed to files in the temporary
327    directory, using the same suffix as the trace file. So, if the command
328    line specified
329    
330        -user=Bruce -background
331    
332    then the trace output would go to C<traceBruce.log>, the standard output to
333    C<outBruce.log>, and the error output to C<errBruce.log>. This is designed to
334    simplify starting a command in the background.
335    
336  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
337  be traced at level 0 and the program will exit without processing.  be traced at level 0 and the program will exit without processing.
338  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 349 
349          -start    start with this genome          -start    start with this genome
350          -tblFiles output TBL files containing the corrected IDs          -tblFiles output TBL files containing the corrected IDs
351    
352    The caller has the option of modifying the tracing scheme by placing a value
353    for C<trace> in the incoming options hash. The default value can be overridden,
354    or the tracing to the standard output can be turned off by suffixing a minus
355    sign to the trace level. So, for example,
356    
357        { trace => [0, "tracing level (default 0)"],
358           ...
359    
360    would set the default trace level to 0 instead of 2, while
361    
362        { trace => ["2-", "tracing level (default 2)"],
363           ...
364    
365    would leave the default at 2, but trace only to the log file, not to the
366    standard output.
367    
368  The parameters to this method are as follows.  The parameters to this method are as follows.
369    
370  =over 4  =over 4
# Line 347  Line 382 
382  by specifying the options as command-line switches prefixed by a hyphen.  by specifying the options as command-line switches prefixed by a hyphen.
383  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
384  specified on the command line, the option descriptions will be used to  specified on the command line, the option descriptions will be used to
385  explain the options.  explain the options. To turn off tracing to the standard output, add a
386    minus sign to the value for C<trace> (see above).
387    
388  =item parmHelp  =item parmHelp
389    
390  A string that vaguely describes the positional parameters. This is used  A string that vaguely describes the positional parameters. This is used
391  if the user specifies the C<-h> option.  if the user specifies the C<-h> option.
392    
393  =item ARGV  =item argv
394    
395  List of command line parameters, including the option switches, which must  List of command line parameters, including the option switches, which must
396  precede the positional parameters and be prefixed by a hyphen.  precede the positional parameters and be prefixed by a hyphen.
# Line 374  Line 410 
410      # Get the parameters.      # Get the parameters.
411      my ($categories, $options, $parmHelp, @argv) = @_;      my ($categories, $options, $parmHelp, @argv) = @_;
412      # Add the tracing options.      # Add the tracing options.
413        if (! exists $options->{trace}) {
414      $options->{trace} = [2, "tracing level"];      $options->{trace} = [2, "tracing level"];
415        }
416      $options->{sql} = [0, "turn on SQL tracing"];      $options->{sql} = [0, "turn on SQL tracing"];
417      $options->{h} = [0, "display command-line options"];      $options->{h} = [0, "display command-line options"];
418      $options->{user} = [$$, "trace log file name suffix"];      $options->{user} = [$$, "trace log file name suffix"];
419        $options->{background} = [0, "spool standard and error output"];
420      # Create a parsing hash from the options hash. The parsing hash      # Create a parsing hash from the options hash. The parsing hash
421      # contains the default values rather than the default value      # contains the default values rather than the default value
422      # 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 431 
431      }      }
432      # Parse the command line.      # Parse the command line.
433      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);      my ($retOptions, @retParameters) = ParseCommand(\%parseOptions, @argv);
434        # Get the logfile suffix.
435        my $suffix = $retOptions->{user};
436        # Check for background mode.
437        if ($retOptions->{background}) {
438            my $outFileName = "$FIG_Config::temp/out$suffix.log";
439            my $errFileName = "$FIG_Config::temp/err$suffix.log";
440            open STDOUT, ">$outFileName";
441            open STDERR, ">$errFileName";
442        }
443      # 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
444      # be traced.      # be traced.
445      my @cats = @{$categories};      my @cats = @{$categories};
# Line 400  Line 448 
448      }      }
449      # Add the default categories.      # Add the default categories.
450      push @cats, "Tracer", "FIG";      push @cats, "Tracer", "FIG";
451      # Next, we create the category string by prefixing the trace level      # Next, we create the category string by joining the categories.
452      # and joining the categories.      my $cats = join(" ", @cats);
453      my $cats = join(" ", $parseOptions{trace}, @cats);      # Check to determine whether or not the caller wants to turn off tracing
454        # to the standard output.
455        my $traceLevel = $retOptions->{trace};
456        my $textOKFlag = 1;
457        if ($traceLevel =~ /^(.)-/) {
458            $traceLevel = $1;
459            $textOKFlag = 0;
460        }
461        # Now we set up the trace mode.
462        my $traceMode;
463        # Verify that we can open a file in the FIG temporary directory.
464        my $traceFileName = "$FIG_Config::temp/trace$suffix.log";
465        if (open TESTTRACE, ">$traceFileName") {
466            # Here we can trace to a file.
467            $traceMode = ">$traceFileName";
468            if ($textOKFlag) {
469                # Echo to standard output if the text-OK flag is set.
470                $traceMode = "+$traceMode";
471            }
472            # Close the test file.
473            close TESTTRACE;
474        } else {
475            # Here we can't trace to a file. We trace to the standard output if it's
476            # okay, and the error log otherwise.
477            if ($textOKFlag) {
478                $traceMode = "TEXT";
479            } else {
480                $traceMode = "WARN";
481            }
482        }
483      # Now set up the tracing.      # Now set up the tracing.
484      my $suffix = $retOptions->{user};      TSetup("$traceLevel $cats", $traceMode);
     TSetup($cats, "+>$FIG_Config::temp/trace$suffix.log");  
485      # 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
486      # options and exit the program.      # options and exit the program.
487      if ($retOptions->{h}) {      if ($retOptions->{h}) {
# Line 1275  Line 1351 
1351      return @inputList;      return @inputList;
1352  }  }
1353    
1354    =head3 Percent
1355    
1356    C<< my $percent = Tracer::Percent($number, $base); >>
1357    
1358    Returns the percent of the base represented by the given number. If the base
1359    is zero, returns zero.
1360    
1361    =over 4
1362    
1363    =item number
1364    
1365    Percent numerator.
1366    
1367    =item base
1368    
1369    Percent base.
1370    
1371    =item RETURN
1372    
1373    Returns the percentage of the base represented by the numerator.
1374    
1375    =back
1376    
1377    =cut
1378    
1379    sub Percent {
1380        # Get the parameters.
1381        my ($number, $base) = @_;
1382        # Declare the return variable.
1383        my $retVal = 0;
1384        # Compute the percent.
1385        if ($base != 0) {
1386            $retVal = $number * 100 / $base;
1387        }
1388        # Return the result.
1389        return $retVal;
1390    }
1391    
1392  =head3 GetFile  =head3 GetFile
1393    
1394  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
# Line 1308  Line 1422 
1422      # Declare the return variable.      # Declare the return variable.
1423      my @retVal = ();      my @retVal = ();
1424      # Open the file for input.      # Open the file for input.
1425      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 {  
1426          # Read the whole file into the return variable, stripping off any terminator          # Read the whole file into the return variable, stripping off any terminator
1427          # characters.          # characters.
1428          my $lineCount = 0;          my $lineCount = 0;
1429          while (my $line = <INPUTFILE>) {      while (my $line = <$handle>) {
1430              $lineCount++;              $lineCount++;
1431              $line = Strip($line);              $line = Strip($line);
1432              push @retVal, $line;              push @retVal, $line;
1433          }          }
1434          # Close it.          # Close it.
1435          close INPUTFILE;      close $handle;
1436          my $actualLines = @retVal;          my $actualLines = @retVal;
     }  
1437      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1438      if (wantarray) {      if (wantarray) {
1439          return @retVal;          return @retVal;
# Line 1333  Line 1442 
1442      }      }
1443  }  }
1444    
1445    =head3 PutFile
1446    
1447    C<< Tracer::PutFile($fileName, \@lines); >>
1448    
1449    Write out a file from a list of lines of text.
1450    
1451    =over 4
1452    
1453    =item fileName
1454    
1455    Name of the output file.
1456    
1457    =item lines
1458    
1459    Reference to a list of text lines. The lines will be written to the file in order, with trailing
1460    new-line characters. Alternatively, may be a string, in which case the string will be written without
1461    modification.
1462    
1463    =back
1464    
1465    =cut
1466    
1467    sub PutFile {
1468        # Get the parameters.
1469        my ($fileName, $lines) = @_;
1470        # Open the output file.
1471        my $handle = Open(undef, ">$fileName");
1472        if (ref $lines ne 'ARRAY') {
1473            # Here we have a scalar, so we write it raw.
1474            print $handle $lines;
1475        } else {
1476            # Write the lines one at a time.
1477            for my $line (@{$lines}) {
1478                print $handle "$line\n";
1479            }
1480        }
1481        # Close the output file.
1482        close $handle;
1483    }
1484    
1485  =head3 QTrace  =head3 QTrace
1486    
1487  C<< my $data = QTrace($format); >>  C<< my $data = QTrace($format); >>
# Line 1533  Line 1682 
1682    
1683  =head3 AddToListMap  =head3 AddToListMap
1684    
1685  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1686    
1687  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
1688  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 1697 
1697    
1698  Key for which the value is to be added.  Key for which the value is to be added.
1699    
1700  =item value  =item value1, value2, ... valueN
1701    
1702  Value to add to the key's value list.  List of values to add to the key's value list.
1703    
1704  =back  =back
1705    
# Line 1558  Line 1707 
1707    
1708  sub AddToListMap {  sub AddToListMap {
1709      # Get the parameters.      # Get the parameters.
1710      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1711      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1712      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1713          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1714      } else {      } else {
1715          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1716      }      }
1717  }  }
1718    
# Line 1593  Line 1742 
1742          $retVal = 1;          $retVal = 1;
1743      } else {      } else {
1744          # Here debug mode is off, so we generate an error page.          # Here debug mode is off, so we generate an error page.
1745          my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");          my $pageString = PageBuilder::Build("<<Html/ErrorPage.html", {}, "Html");
1746          print $pageString;          print $pageString;
1747      }      }
1748      # Return the determination indicator.      # Return the determination indicator.
# Line 1764  Line 1913 
1913      my $query = CGI->new();      my $query = CGI->new();
1914      # Check for tracing. Set it up if the user asked for it.      # Check for tracing. Set it up if the user asked for it.
1915      if ($query->param('Trace')) {      if ($query->param('Trace')) {
1916          # Set up tracing to be queued for display at the bottom of the web page.          # Set up tracing.
1917          TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");          my $ttype = ($query->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1918            TSetup($query->param('Trace') . " FIG Tracer", $ttype);
1919          # Trace the parameter and environment data.          # Trace the parameter and environment data.
1920            TraceParms($query);
1921        } else {
1922            # Here tracing is to be turned off. All we allow is errors traced into the
1923            # error log.
1924            TSetup("0", "WARN");
1925        }
1926        # Create the variable hash.
1927        my $varHash = { DebugData => '' };
1928        # Return the query object and variable hash.
1929        return ($query, $varHash);
1930    }
1931    
1932    =head3 TraceParms
1933    
1934    C<< Tracer::TraceParms($query); >>
1935    
1936    Trace the CGI parameters at trace level CGI => 3 and the environment variables
1937    at level CGI => 4.
1938    
1939    =over 4
1940    
1941    =item query
1942    
1943    CGI query object containing the parameters to trace.
1944    
1945    =back
1946    
1947    =cut
1948    
1949    sub TraceParms {
1950        # Get the parameters.
1951        my ($query) = @_;
1952          if (T(CGI => 3)) {          if (T(CGI => 3)) {
1953              # Here we want to trace the parameter data.              # Here we want to trace the parameter data.
1954              my @names = $query->param;              my @names = $query->param;
1955              for my $parmName (sort @names) {              for my $parmName (sort @names) {
1956                  # Note we skip "Trace", which is for our use only.              # Note we skip the Trace parameters, which are for our use only.
1957                  if ($parmName ne 'Trace') {              if ($parmName ne 'Trace' && $parmName ne 'TF') {
1958                      my @values = $query->param($parmName);                      my @values = $query->param($parmName);
1959                      Trace("CGI: $parmName = " . join(", ", @values));                      Trace("CGI: $parmName = " . join(", ", @values));
1960                  }                  }
1961              }              }
1962            # Display the request method.
1963            my $method = $query->request_method();
1964            Trace("Method: $method");
1965          }          }
1966          if (T(CGI => 4)) {          if (T(CGI => 4)) {
1967              # Here we want the environment data too.              # Here we want the environment data too.
# Line 1784  Line 1969 
1969                  Trace("ENV: $envName = $ENV{$envName}");                  Trace("ENV: $envName = $ENV{$envName}");
1970              }              }
1971          }          }
     } else {  
         # Here tracing is to be turned off. All we allow is errors traced into the  
         # error log.  
         TSetup("0", "WARN");  
     }  
     # Create the variable hash.  
     my $varHash = { DebugData => '' };  
     # If we're in DEBUG mode, set up the debug mode data for forms.  
     if (Tracer::DebugMode) {  
         $varHash->{DebugData} = GetFile("Html/DebugFragment.html");  
     }  
     # Return the query object and variable hash.  
     return ($query, $varHash);  
1972  }  }
1973    
1974  =head3 ScriptFinish  =head3 ScriptFinish
# Line 1860  Line 2032 
2032      # Check for a template file situation.      # Check for a template file situation.
2033      my $outputString;      my $outputString;
2034      if (defined $varHash) {      if (defined $varHash) {
2035          # 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.
2036          $outputString = PageBuilder::Build("<$webData", $varHash, "Html");          my $template;
2037            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
2038                $template = "$FIG_Config::template_url/$webData";
2039            } else {
2040                $template = "<<$webData";
2041            }
2042            $outputString = PageBuilder::Build($template, $varHash, "Html");
2043      } else {      } else {
2044          # Here the user gave us a raw string.          # Here the user gave us a raw string.
2045          $outputString = $webData;          $outputString = $webData;
2046      }      }
2047      # Check for trace messages.      # Check for trace messages.
2048      if ($Destination eq "QUEUE") {      if ($Destination ne "NONE" && $TraceLevel > 0) {
2049          # We have trace messages, so we want to put them at the end of the body. This          # We have trace messages, so we want to put them at the end of the body. This
2050          # is either at the end of the whole string or at the beginning of the BODY          # is either at the end of the whole string or at the beginning of the BODY
2051          # end-tag.          # end-tag.
# Line 1875  Line 2053 
2053          if ($outputString =~ m#</body>#gi) {          if ($outputString =~ m#</body>#gi) {
2054              $pos = (pos $outputString) - 7;              $pos = (pos $outputString) - 7;
2055          }          }
2056          substr $outputString, $pos, 0, QTrace('Html');          # If the trace messages were queued, we unroll them. Otherwise, we display the
2057            # destination.
2058            my $traceHtml;
2059            if ($Destination eq "QUEUE") {
2060                $traceHtml = QTrace('Html');
2061            } elsif ($Destination =~ /^>>(.+)$/) {
2062                # Here the tracing output it to a file. We code it as a hyperlink so the user
2063                # can copy the file name into the clipboard easily.
2064                my $actualDest = $1;
2065                $traceHtml = "<p>Tracing output to <a href=\"$actualDest\">$actualDest</a>.</p>\n";
2066            } else {
2067                # Here we have one of the special destinations.
2068                $traceHtml = "<P>Tracing output type is $Destination.</p>\n";
2069            }
2070            substr $outputString, $pos, 0, $traceHtml;
2071      }      }
2072      # Write the output string.      # Write the output string.
2073      print $outputString;      print $outputString;
# Line 1901  Line 2093 
2093      my ($dirName) = @_;      my ($dirName) = @_;
2094      if (! -d $dirName) {      if (! -d $dirName) {
2095          Trace("Creating $dirName directory.") if T(2);          Trace("Creating $dirName directory.") if T(2);
2096          mkpath $dirName;          eval { mkpath $dirName; };
2097            if ($@) {
2098                Confess("Error creating $dirName: $@");
2099            }
2100        }
2101    }
2102    
2103    =head3 ChDir
2104    
2105    C<< ChDir($dirName); >>
2106    
2107    Change to the specified directory.
2108    
2109    =over 4
2110    
2111    =item dirName
2112    
2113    Name of the directory to which we want to change.
2114    
2115    =back
2116    
2117    =cut
2118    
2119    sub ChDir {
2120        my ($dirName) = @_;
2121        if (! -d $dirName) {
2122            Confess("Cannot change to directory $dirName: no such directory.");
2123        } else {
2124            Trace("Changing to directory $dirName.") if T(4);
2125            my $okFlag = chdir $dirName;
2126            if (! $okFlag) {
2127                Confess("Error switching to directory $dirName.");
2128            }
2129        }
2130    }
2131    
2132    =head3 SendSMS
2133    
2134    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2135    
2136    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2137    user name, password, and API ID for the relevant account in the hash reference variable
2138    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2139    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2140    is C<2561022>, then the FIG_Config file must contain
2141    
2142        $phone =  { user => 'BruceTheHumanPet',
2143                    password => 'silly',
2144                    api_id => '2561022' };
2145    
2146    The original purpose of this method was to insure Bruce would be notified immediately when the
2147    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2148    when you call this method.
2149    
2150    The message ID will be returned if successful, and C<undef> if an error occurs.
2151    
2152    =over 4
2153    
2154    =item phoneNumber
2155    
2156    Phone number to receive the message, in international format. A United States phone number
2157    would be prefixed by "1". A British phone number would be prefixed by "44".
2158    
2159    =item msg
2160    
2161    Message to send to the specified phone.
2162    
2163    =item RETURN
2164    
2165    Returns the message ID if successful, and C<undef> if the message could not be sent.
2166    
2167    =back
2168    
2169    =cut
2170    
2171    sub SendSMS {
2172        # Get the parameters.
2173        my ($phoneNumber, $msg) = @_;
2174        # Declare the return variable. If we do not change it, C<undef> will be returned.
2175        my $retVal;
2176        # Only proceed if we have phone support.
2177        if (! defined $FIG_Config::phone) {
2178            Trace("Phone support not present in FIG_Config.") if T(1);
2179        } else {
2180            # Get the phone data.
2181            my $parms = $FIG_Config::phone;
2182            # Get the Clickatell URL.
2183            my $url = "http://api.clickatell.com/http/";
2184            # Create the user agent.
2185            my $ua = LWP::UserAgent->new;
2186            # Request a Clickatell session.
2187            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2188                                         password => $parms->{password},
2189                                         api_id => $parms->{api_id},
2190                                         to => $phoneNumber,
2191                                         text => $msg});
2192            # Check for an error.
2193            if (! $resp->is_success) {
2194                Trace("Alert failed.") if T(1);
2195            } else {
2196                # Get the message ID.
2197                my $rstring = $resp->content;
2198                if ($rstring =~ /^ID:\s+(.*)$/) {
2199                    $retVal = $1;
2200                } else {
2201                    Trace("Phone attempt failed with $rstring") if T(1);
2202                }
2203      }      }
2204  }  }
2205        # Return the result.
2206        return $retVal;
2207    }
2208    
2209    =head3 CommaFormat
2210    
2211    C<< my $formatted = Tracer::CommaFormat($number); >>
2212    
2213    Insert commas into a number.
2214    
2215    =over 4
2216    
2217    =item number
2218    
2219    A sequence of digits.
2220    
2221    =item RETURN
2222    
2223    Returns the same digits with commas strategically inserted.
2224    
2225    =back
2226    
2227    =cut
2228    
2229    sub CommaFormat {
2230        # Get the parameters.
2231        my ($number) = @_;
2232        # Pad the length up to a multiple of three.
2233        my $padded = "$number";
2234        $padded = " " . $padded while length($padded) % 3 != 0;
2235        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2236        # cause the delimiters to be included in the output stream. The
2237        # GREP removes the empty strings in between the delimiters.
2238        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2239        # Clean out the spaces.
2240        $retVal =~ s/ //g;
2241        # Return the result.
2242        return $retVal;
2243    }
2244    =head3 SetPermissions
2245    
2246    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2247    
2248    Set the permissions for a directory and all the files and folders inside it.
2249    In addition, the group ownership will be changed to the specified value.
2250    
2251    This method is more vulnerable than most to permission and compatability
2252    problems, so it does internal error recovery.
2253    
2254    =over 4
2255    
2256    =item dirName
2257    
2258    Name of the directory to process.
2259    
2260    =item group
2261    
2262    Name of the group to be assigned.
2263    
2264    =item mask
2265    
2266    Permission mask. Bits that are C<1> in this mask will be ORed into the
2267    permission bits of any file or directory that does not already have them
2268    set to 1.
2269    
2270    =item otherMasks
2271    
2272    Map of search patterns to permission masks. If a directory name matches
2273    one of the patterns, that directory and all its members and subdirectories
2274    will be assigned the new pattern. For example, the following would
2275    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2276    
2277        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2278    
2279    The list is ordered, so the following would use 0777 for C<tmp1> and
2280    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2281    
2282        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2283                                                       '^tmp' => 0666);
2284    
2285    Note that the pattern matches are all case-insensitive, and only directory
2286    names are matched, not file names.
2287    
2288    =back
2289    
2290    =cut
2291    
2292    sub SetPermissions {
2293        # Get the parameters.
2294        my ($dirName, $group, $mask, @otherMasks) = @_;
2295        # Set up for error recovery.
2296        eval {
2297            # Switch to the specified directory.
2298            ChDir($dirName);
2299            # Get the group ID.
2300            my $gid = getgrnam($group);
2301            # Get the mask for tracing.
2302            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2303            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2304            my $fixCount = 0;
2305            my $lookCount = 0;
2306            # @dirs will be a stack of directories to be processed.
2307            my @dirs = (getcwd());
2308            while (scalar(@dirs) > 0) {
2309                # Get the current directory.
2310                my $dir = pop @dirs;
2311                # Check for a match to one of the specified directory names. To do
2312                # that, we need to pull the individual part of the name off of the
2313                # whole path.
2314                my $simpleName = $dir;
2315                if ($dir =~ m!/([^/]+)$!) {
2316                    $simpleName = $1;
2317                }
2318                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2319                # Search for a match.
2320                my $match = 0;
2321                my $i;
2322                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2323                    my $pattern = $otherMasks[$i];
2324                    if ($simpleName =~ /$pattern/i) {
2325                        $match = 1;
2326                    }
2327                }
2328                # Check for a match. Note we use $i-1 because the loop added 2
2329                # before terminating due to the match.
2330                if ($match && $otherMasks[$i-1] != $mask) {
2331                    # This directory matches one of the incoming patterns, and it's
2332                    # a different mask, so we process it recursively with that mask.
2333                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2334                } else {
2335                    # Here we can process normally. Get all of the non-hidden members.
2336                    my @submems = OpenDir($dir, 1);
2337                    for my $submem (@submems) {
2338                        # Get the full name.
2339                        my $thisMem = "$dir/$submem";
2340                        Trace("Checking member $thisMem.") if T(4);
2341                        $lookCount++;
2342                        if ($lookCount % 1000 == 0) {
2343                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2344                        }
2345                        # Fix the group.
2346                        chown -1, $gid, $thisMem;
2347                        # Insure this member is not a symlink.
2348                        if (! -l $thisMem) {
2349                            # Get its info.
2350                            my $fileInfo = stat $thisMem;
2351                            # Only proceed if we got the info. Otherwise, it's a hard link
2352                            # and we want to skip it anyway.
2353                            if ($fileInfo) {
2354                                my $fileMode = $fileInfo->mode;
2355                                if (($fileMode & $mask) != $mask) {
2356                                    # Fix this member.
2357                                    $fileMode |= $mask;
2358                                    chmod $fileMode, $thisMem;
2359                                    $fixCount++;
2360                                }
2361                                # If it's a subdirectory, stack it.
2362                                if (-d $thisMem) {
2363                                    push @dirs, $thisMem;
2364                                }
2365                            }
2366                        }
2367                    }
2368                }
2369            }
2370            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2371        };
2372        # Check for an error.
2373        if ($@) {
2374            Confess("SetPermissions error: $@");
2375        }
2376    }
2377    
2378    =head3 CompareLists
2379    
2380    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2381    
2382    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2383    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2384    The return value contains a list of items that are only in the new list
2385    (inserted) and only in the old list (deleted).
2386    
2387    =over 4
2388    
2389    =item newList
2390    
2391    Reference to a list of new tuples.
2392    
2393    =item oldList
2394    
2395    Reference to a list of old tuples.
2396    
2397    =item keyIndex (optional)
2398    
2399    Index into each tuple of its key field. The default is 0.
2400    
2401    =item RETURN
2402    
2403    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2404    list (inserted) followed by a reference to the list of items that are only in the old
2405    list (deleted).
2406    
2407    =back
2408    
2409    =cut
2410    
2411    sub CompareLists {
2412        # Get the parameters.
2413        my ($newList, $oldList, $keyIndex) = @_;
2414        if (! defined $keyIndex) {
2415            $keyIndex = 0;
2416        }
2417        # Declare the return variables.
2418        my ($inserted, $deleted) = ([], []);
2419        # Loop through the two lists simultaneously.
2420        my ($newI, $oldI) = (0, 0);
2421        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2422        while ($newI < $newN || $oldI < $oldN) {
2423            # Get the current object in each list. Note that if one
2424            # of the lists is past the end, we'll get undef.
2425            my $newItem = $newList->[$newI];
2426            my $oldItem = $oldList->[$oldI];
2427            if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2428                # The old item is not in the new list, so mark it deleted.
2429                push @{$deleted}, $oldItem;
2430                $oldI++;
2431            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2432                # The new item is not in the old list, so mark it inserted.
2433                push @{$inserted}, $newItem;
2434                $newI++;
2435            } else {
2436                # The item is in both lists, so push forward.
2437                $oldI++;
2438                $newI++;
2439            }
2440        }
2441        # Return the result.
2442        return ($inserted, $deleted);
2443    }
2444    
2445    =head3 GetLine
2446    
2447    C<< my @data = Tracer::GetLine($handle); >>
2448    
2449    Read a line of data from a tab-delimited file.
2450    
2451    =over 4
2452    
2453    =item handle
2454    
2455    Open file handle from which to read.
2456    
2457    =item RETURN
2458    
2459    Returns a list of the fields in the record read. The fields are presumed to be
2460    tab-delimited. If we are at the end of the file, then an empty list will be
2461    returned. If an empty line is read, a single list item consisting of a null
2462    string will be returned.
2463    
2464    =back
2465    
2466    =cut
2467    
2468    sub GetLine {
2469        # Get the parameters.
2470        my ($handle) = @_;
2471        # Declare the return variable.
2472        my @retVal = ();
2473        # Read from the file.
2474        my $line = <$handle>;
2475        # Only proceed if we found something.
2476        if (defined $line) {
2477            # Remove the new-line.
2478            chomp $line;
2479            # If the line is empty, return a single empty string; otherwise, parse
2480            # it into fields.
2481            if ($line eq "") {
2482                push @retVal, "";
2483            } else {
2484                push @retVal, split /\t/,$line;
2485            }
2486        }
2487        # Return the result.
2488        return @retVal;
2489    }
2490    
2491    =head3 PutLine
2492    
2493    C<< Tracer::PutLine($handle, \@fields); >>
2494    
2495    Write a line of data to a tab-delimited file. The specified field values will be
2496    output in tab-separated form, with a trailing new-line.
2497    
2498    =over 4
2499    
2500    =item handle
2501    
2502    Output file handle.
2503    
2504    =item fields
2505    
2506    List of field values.
2507    
2508    =back
2509    
2510    =cut
2511    
2512    sub PutLine {
2513        # Get the parameters.
2514        my ($handle, $fields) = @_;
2515        # Write the data.
2516        print $handle join("\t", @{$fields}) . "\n";
2517    }
2518    
2519    =head3 GenerateURL
2520    
2521    C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >>
2522    
2523    Generate a GET-style URL for the specified page with the specified parameter
2524    names and values. The values will be URL-escaped automatically. So, for
2525    example
2526    
2527        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
2528    
2529    would return
2530    
2531        form.cgi?type=1&string=%22high%20pass%22%20or%20highway
2532    
2533    =over 4
2534    
2535    =item page
2536    
2537    Page URL.
2538    
2539    =item parameters
2540    
2541    Hash mapping parameter names to parameter values.
2542    
2543    =item RETURN
2544    
2545    Returns a GET-style URL that goes to the specified page and passes in the
2546    specified parameters and values.
2547    
2548    =back
2549    
2550    =cut
2551    
2552    sub GenerateURL {
2553        # Get the parameters.
2554        my ($page, %parameters) = @_;
2555        # Prime the return variable with the page URL.
2556        my $retVal = $page;
2557        # Loop through the parameters, creating parameter elements in a list.
2558        my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
2559        # If the list is nonempty, tack it on.
2560        if (@parmList) {
2561            $retVal .= "?" . join("&", @parmList);
2562        }
2563        # Return the result.
2564        return $retVal;
2565    }
2566    
2567  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3