[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.64, Thu Sep 14 23:06:00 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        use Time::HiRes 'gettimeofday';
36    
37  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
38    
# Line 1348  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 1381  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 1406  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 1606  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 1621  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 1631  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 1666  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 1933  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 2010  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  =head3 SetPermissions
2201    
2202  C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>  C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
# Line 2081  Line 2268 
2268              # 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
2269              # whole path.              # whole path.
2270              my $simpleName = $dir;              my $simpleName = $dir;
2271              if ($dir =~ m!/(.+)$!) {              if ($dir =~ m!/([^/]+)$!) {
2272                  $simpleName = $1;                  $simpleName = $1;
2273              }              }
2274                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2275              # Search for a match.              # Search for a match.
2276              my $match = 0;              my $match = 0;
2277              my $i;              my $i;
# Line 2120  Line 2308 
2308                          # and we want to skip it anyway.                          # and we want to skip it anyway.
2309                          if ($fileInfo) {                          if ($fileInfo) {
2310                              my $fileMode = $fileInfo->mode;                              my $fileMode = $fileInfo->mode;
2311                              if (($fileMode & $mask) == 0) {                              if (($fileMode & $mask) != $mask) {
2312                                  # Fix this member.                                  # Fix this member.
2313                                  $fileMode |= $mask;                                  $fileMode |= $mask;
2314                                  chmod $fileMode, $thisMem;                                  chmod $fileMode, $thisMem;
# Line 2143  Line 2331 
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.52  
changed lines
  Added in v.1.64

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3