[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.52, Wed Jun 14 01:12:42 2006 UTC revision 1.62, Thu Aug 24 07:58:29 2006 UTC
# Line 31  Line 31 
31      use File::Basename;      use File::Basename;
32      use File::Path;      use File::Path;
33      use File::stat;      use File::stat;
34        use LWP::UserAgent;
35    
36  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
37    
# Line 1348  Line 1349 
1349      return @inputList;      return @inputList;
1350  }  }
1351    
1352    =head3 Percent
1353    
1354    C<< my $percent = Tracer::Percent($number, $base); >>
1355    
1356    Returns the percent of the base represented by the given number. If the base
1357    is zero, returns zero.
1358    
1359    =over 4
1360    
1361    =item number
1362    
1363    Percent numerator.
1364    
1365    =item base
1366    
1367    Percent base.
1368    
1369    =item RETURN
1370    
1371    Returns the percentage of the base represented by the numerator.
1372    
1373    =back
1374    
1375    =cut
1376    
1377    sub Percent {
1378        # Get the parameters.
1379        my ($number, $base) = @_;
1380        # Declare the return variable.
1381        my $retVal = 0;
1382        # Compute the percent.
1383        if ($base != 0) {
1384            $retVal = $number * 100 / $base;
1385        }
1386        # Return the result.
1387        return $retVal;
1388    }
1389    
1390  =head3 GetFile  =head3 GetFile
1391    
1392  C<< my @fileContents = Tracer::GetFile($fileName); >>  C<< my @fileContents = Tracer::GetFile($fileName); >>
# Line 1381  Line 1420 
1420      # Declare the return variable.      # Declare the return variable.
1421      my @retVal = ();      my @retVal = ();
1422      # Open the file for input.      # Open the file for input.
1423      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 {  
1424          # Read the whole file into the return variable, stripping off any terminator          # Read the whole file into the return variable, stripping off any terminator
1425          # characters.          # characters.
1426          my $lineCount = 0;          my $lineCount = 0;
1427          while (my $line = <INPUTFILE>) {      while (my $line = <$handle>) {
1428              $lineCount++;              $lineCount++;
1429              $line = Strip($line);              $line = Strip($line);
1430              push @retVal, $line;              push @retVal, $line;
1431          }          }
1432          # Close it.          # Close it.
1433          close INPUTFILE;      close $handle;
1434          my $actualLines = @retVal;          my $actualLines = @retVal;
     }  
1435      # Return the file's contents in the desired format.      # Return the file's contents in the desired format.
1436      if (wantarray) {      if (wantarray) {
1437          return @retVal;          return @retVal;
# Line 1406  Line 1440 
1440      }      }
1441  }  }
1442    
1443    =head3 PutFile
1444    
1445    C<< Tracer::PutFile($fileName, \@lines); >>
1446    
1447    Write out a file from a list of lines of text.
1448    
1449    =over 4
1450    
1451    =item fileName
1452    
1453    Name of the output file.
1454    
1455    =item lines
1456    
1457    Reference to a list of text lines. The lines will be written to the file in order, with trailing
1458    new-line characters.
1459    
1460    =back
1461    
1462    =cut
1463    
1464    sub PutFile {
1465        # Get the parameters.
1466        my ($fileName, $lines) = @_;
1467        # Open the output file.
1468        my $handle = Open(undef, ">$fileName");
1469        # Write the lines.
1470        for my $line (@{$lines}) {
1471            print $handle "$line\n";
1472        }
1473        # Close the output file.
1474        close $handle;
1475    }
1476    
1477  =head3 QTrace  =head3 QTrace
1478    
1479  C<< my $data = QTrace($format); >>  C<< my $data = QTrace($format); >>
# Line 1606  Line 1674 
1674    
1675  =head3 AddToListMap  =head3 AddToListMap
1676    
1677  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1678    
1679  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
1680  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 1621  Line 1689 
1689    
1690  Key for which the value is to be added.  Key for which the value is to be added.
1691    
1692  =item value  =item value1, value2, ... valueN
1693    
1694  Value to add to the key's value list.  List of values to add to the key's value list.
1695    
1696  =back  =back
1697    
# Line 1631  Line 1699 
1699    
1700  sub AddToListMap {  sub AddToListMap {
1701      # Get the parameters.      # Get the parameters.
1702      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1703      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1704      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1705          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1706      } else {      } else {
1707          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1708      }      }
1709  }  }
1710    
# Line 1666  Line 1734 
1734          $retVal = 1;          $retVal = 1;
1735      } else {      } else {
1736          # Here debug mode is off, so we generate an error page.          # Here debug mode is off, so we generate an error page.
1737          my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");          my $pageString = PageBuilder::Build("<<Html/ErrorPage.html", {}, "Html");
1738          print $pageString;          print $pageString;
1739      }      }
1740      # Return the determination indicator.      # Return the determination indicator.
# Line 1934  Line 2002 
2002      my $outputString;      my $outputString;
2003      if (defined $varHash) {      if (defined $varHash) {
2004          # Here we have a template file. We need to apply the variables to the template.          # Here we have a template file. We need to apply the variables to the template.
2005          $outputString = PageBuilder::Build("<$webData", $varHash, "Html");          $outputString = PageBuilder::Build("<<$webData", $varHash, "Html");
2006      } else {      } else {
2007          # Here the user gave us a raw string.          # Here the user gave us a raw string.
2008          $outputString = $webData;          $outputString = $webData;
# Line 2010  Line 2078 
2078      }      }
2079  }  }
2080    
2081    =head3 SendSMS
2082    
2083    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2084    
2085    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2086    user name, password, and API ID for the relevant account in the hash reference variable
2087    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2088    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2089    is C<2561022>, then the FIG_Config file must contain
2090    
2091        $phone =  { user => 'BruceTheHumanPet',
2092                    password => 'silly',
2093                    api_id => '2561022' };
2094    
2095    The original purpose of this method was to insure Bruce would be notified immediately when the
2096    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2097    when you call this method.
2098    
2099    The message ID will be returned if successful, and C<undef> if an error occurs.
2100    
2101    =over 4
2102    
2103    =item phoneNumber
2104    
2105    Phone number to receive the message, in international format. A United States phone number
2106    would be prefixed by "1". A British phone number would be prefixed by "44".
2107    
2108    =item msg
2109    
2110    Message to send to the specified phone.
2111    
2112    =item RETURN
2113    
2114    Returns the message ID if successful, and C<undef> if the message could not be sent.
2115    
2116    =back
2117    
2118    =cut
2119    
2120    sub SendSMS {
2121        # Get the parameters.
2122        my ($phoneNumber, $msg) = @_;
2123        # Declare the return variable. If we do not change it, C<undef> will be returned.
2124        my $retVal;
2125        # Only proceed if we have phone support.
2126        if (! defined $FIG_Config::phone) {
2127            Trace("Phone support not present in FIG_Config.") if T(1);
2128        } else {
2129            # Get the phone data.
2130            my $parms = $FIG_Config::phone;
2131            # Get the Clickatell URL.
2132            my $url = "http://api.clickatell.com/http/";
2133            # Create the user agent.
2134            my $ua = LWP::UserAgent->new;
2135            # Request a Clickatell session.
2136            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2137                                         password => $parms->{password},
2138                                         api_id => $parms->{api_id},
2139                                         to => $phoneNumber,
2140                                         text => $msg});
2141            # Check for an error.
2142            if (! $resp->is_success) {
2143                Trace("Alert failed.") if T(1);
2144            } else {
2145                # Get the message ID.
2146                my $rstring = $resp->content;
2147                if ($rstring =~ /^ID:\s+(.*)$/) {
2148                    $retVal = $1;
2149                } else {
2150                    Trace("Phone attempt failed with $rstring") if T(1);
2151                }
2152            }
2153        }
2154        # Return the result.
2155        return $retVal;
2156    }
2157    
2158    =head3 CommaFormat
2159    
2160    C<< my $formatted = Tracer::CommaFormat($number); >>
2161    
2162    Insert commas into a number.
2163    
2164    =over 4
2165    
2166    =item number
2167    
2168    A sequence of digits.
2169    
2170    =item RETURN
2171    
2172    Returns the same digits with commas strategically inserted.
2173    
2174    =back
2175    
2176    =cut
2177    
2178    sub CommaFormat {
2179        # Get the parameters.
2180        my ($number) = @_;
2181        # Pad the length up to a multiple of three.
2182        my $padded = "$number";
2183        $padded = " " . $padded while length($padded) % 3 != 0;
2184        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2185        # cause the delimiters to be included in the output stream. The
2186        # GREP removes the empty strings in between the delimiters.
2187        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2188        # Clean out the spaces.
2189        $retVal =~ s/ //g;
2190        # Return the result.
2191        return $retVal;
2192    }
2193  =head3 SetPermissions  =head3 SetPermissions
2194    
2195  C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>  C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
# Line 2081  Line 2261 
2261              # that, we need to pull the individual part of the name off of the              # that, we need to pull the individual part of the name off of the
2262              # whole path.              # whole path.
2263              my $simpleName = $dir;              my $simpleName = $dir;
2264              if ($dir =~ m!/(.+)$!) {              if ($dir =~ m!/([^/]+)$!) {
2265                  $simpleName = $1;                  $simpleName = $1;
2266              }              }
2267                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2268              # Search for a match.              # Search for a match.
2269              my $match = 0;              my $match = 0;
2270              my $i;              my $i;
# Line 2120  Line 2301 
2301                          # and we want to skip it anyway.                          # and we want to skip it anyway.
2302                          if ($fileInfo) {                          if ($fileInfo) {
2303                              my $fileMode = $fileInfo->mode;                              my $fileMode = $fileInfo->mode;
2304                              if (($fileMode & $mask) == 0) {                              if (($fileMode & $mask) != $mask) {
2305                                  # Fix this member.                                  # Fix this member.
2306                                  $fileMode |= $mask;                                  $fileMode |= $mask;
2307                                  chmod $fileMode, $thisMem;                                  chmod $fileMode, $thisMem;
# Line 2143  Line 2324 
2324      }      }
2325  }  }
2326    
2327    =head3 CompareLists
2328    
2329    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2330    
2331    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2332    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2333    The return value contains a list of items that are only in the new list
2334    (inserted) and only in the old list (deleted).
2335    
2336    =over 4
2337    
2338    =item newList
2339    
2340    Reference to a list of new tuples.
2341    
2342    =item oldList
2343    
2344    Reference to a list of old tuples.
2345    
2346    =item keyIndex (optional)
2347    
2348    Index into each tuple of its key field. The default is 0.
2349    
2350    =item RETURN
2351    
2352    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2353    list (inserted) followed by a reference to the list of items that are only in the old
2354    list (deleted).
2355    
2356    =back
2357    
2358    =cut
2359    
2360    sub CompareLists {
2361        # Get the parameters.
2362        my ($newList, $oldList, $keyIndex) = @_;
2363        if (! defined $keyIndex) {
2364            $keyIndex = 0;
2365        }
2366        # Declare the return variables.
2367        my ($inserted, $deleted) = ([], []);
2368        # Loop through the two lists simultaneously.
2369        my ($newI, $oldI) = (0, 0);
2370        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2371        while ($newI < $newN || $oldI < $oldN) {
2372            # Get the current object in each list. Note that if one
2373            # of the lists is past the end, we'll get undef.
2374            my $newItem = $newList->[$newI];
2375            my $oldItem = $oldList->[$oldI];
2376            if (! defined($newItem) || $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2377                # The old item is not in the new list, so mark it deleted.
2378                push @{$deleted}, $oldItem;
2379                $oldI++;
2380            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2381                # The new item is not in the old list, so mark it inserted.
2382                push @{$inserted}, $newItem;
2383                $newI++;
2384            } else {
2385                # The item is in both lists, so push forward.
2386                $oldI++;
2387                $newI++;
2388            }
2389        }
2390        # Return the result.
2391        return ($inserted, $deleted);
2392    }
2393    
2394    
2395  1;  1;

Legend:
Removed from v.1.52  
changed lines
  Added in v.1.62

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3