[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.45, Mon May 8 20:37:02 2006 UTC revision 1.64, Thu Sep 14 23:06:00 2006 UTC
# Line 24  Line 24 
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 1346  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 1379  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 1404  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 1604  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 1619  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 1629  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 1664  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 1931  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 2008  Line 2085 
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.45  
changed lines
  Added in v.1.64

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3