[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.59, Sat Jul 1 03:14:09 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    
36  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
37    
# Line 1346  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 1604  Line 1645 
1645    
1646  =head3 AddToListMap  =head3 AddToListMap
1647    
1648  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1649    
1650  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
1651  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 1660 
1660    
1661  Key for which the value is to be added.  Key for which the value is to be added.
1662    
1663  =item value  =item value1, value2, ... valueN
1664    
1665  Value to add to the key's value list.  List of values to add to the key's value list.
1666    
1667  =back  =back
1668    
# Line 1629  Line 1670 
1670    
1671  sub AddToListMap {  sub AddToListMap {
1672      # Get the parameters.      # Get the parameters.
1673      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1674      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1675      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1676          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1677      } else {      } else {
1678          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1679      }      }
1680  }  }
1681    
# Line 2008  Line 2049 
2049      }      }
2050  }  }
2051    
2052    =head3 SendSMS
2053    
2054    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2055    
2056    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2057    user name, password, and API ID for the relevant account in the hash reference variable
2058    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2059    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2060    is C<2561022>, then the FIG_Config file must contain
2061    
2062        $phone =  { user => 'BruceTheHumanPet',
2063                    password => 'silly',
2064                    api_id => '2561022' };
2065    
2066    The original purpose of this method was to insure Bruce would be notified immediately when the
2067    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2068    when you call this method.
2069    
2070    The message ID will be returned if successful, and C<undef> if an error occurs.
2071    
2072    =over 4
2073    
2074    =item phoneNumber
2075    
2076    Phone number to receive the message, in international format. A United States phone number
2077    would be prefixed by "1". A British phone number would be prefixed by "44".
2078    
2079    =item msg
2080    
2081    Message to send to the specified phone.
2082    
2083    =item RETURN
2084    
2085    Returns the message ID if successful, and C<undef> if the message could not be sent.
2086    
2087    =back
2088    
2089    =cut
2090    
2091    sub SendSMS {
2092        # Get the parameters.
2093        my ($phoneNumber, $msg) = @_;
2094        # Declare the return variable. If we do not change it, C<undef> will be returned.
2095        my $retVal;
2096        # Only proceed if we have phone support.
2097        if (! defined $FIG_Config::phone) {
2098            Trace("Phone support not present in FIG_Config.") if T(1);
2099        } else {
2100            # Get the phone data.
2101            my $parms = $FIG_Config::phone;
2102            # Get the Clickatell URL.
2103            my $url = "http://api.clickatell.com/http/";
2104            # Create the user agent.
2105            my $ua = LWP::UserAgent->new;
2106            # Request a Clickatell session.
2107            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2108                                         password => $parms->{password},
2109                                         api_id => $parms->{api_id},
2110                                         to => $phoneNumber,
2111                                         text => $msg});
2112            # Check for an error.
2113            if (! $resp->is_success) {
2114                Trace("Alert failed.") if T(1);
2115            } else {
2116                # Get the message ID.
2117                my $rstring = $resp->content;
2118                if ($rstring =~ /^ID:\s+(.*)$/) {
2119                    $retVal = $1;
2120                } else {
2121                    Trace("Phone attempt failed with $rstring") if T(1);
2122                }
2123            }
2124        }
2125        # Return the result.
2126        return $retVal;
2127    }
2128    
2129    =head3 CommaFormat
2130    
2131    C<< my $formatted = Tracer::CommaFormat($number); >>
2132    
2133    Insert commas into a number.
2134    
2135    =over 4
2136    
2137    =item number
2138    
2139    A sequence of digits.
2140    
2141    =item RETURN
2142    
2143    Returns the same digits with commas strategically inserted.
2144    
2145    =back
2146    
2147    =cut
2148    
2149    sub CommaFormat {
2150        # Get the parameters.
2151        my ($number) = @_;
2152        # Pad the length up to a multiple of three.
2153        my $padded = "$number";
2154        $padded = " " . $padded while length($padded) % 3 != 0;
2155        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2156        # cause the delimiters to be included in the output stream. The
2157        # GREP removes the empty strings in between the delimiters.
2158        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2159        # Clean out the spaces.
2160        $retVal =~ s/ //g;
2161        # Return the result.
2162        return $retVal;
2163    }
2164    =head3 SetPermissions
2165    
2166    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2167    
2168    Set the permissions for a directory and all the files and folders inside it.
2169    In addition, the group ownership will be changed to the specified value.
2170    
2171    This method is more vulnerable than most to permission and compatability
2172    problems, so it does internal error recovery.
2173    
2174    =over 4
2175    
2176    =item dirName
2177    
2178    Name of the directory to process.
2179    
2180    =item group
2181    
2182    Name of the group to be assigned.
2183    
2184    =item mask
2185    
2186    Permission mask. Bits that are C<1> in this mask will be ORed into the
2187    permission bits of any file or directory that does not already have them
2188    set to 1.
2189    
2190    =item otherMasks
2191    
2192    Map of search patterns to permission masks. If a directory name matches
2193    one of the patterns, that directory and all its members and subdirectories
2194    will be assigned the new pattern. For example, the following would
2195    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2196    
2197        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2198    
2199    The list is ordered, so the following would use 0777 for C<tmp1> and
2200    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2201    
2202        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2203                                                       '^tmp' => 0666);
2204    
2205    Note that the pattern matches are all case-insensitive, and only directory
2206    names are matched, not file names.
2207    
2208    =back
2209    
2210    =cut
2211    
2212    sub SetPermissions {
2213        # Get the parameters.
2214        my ($dirName, $group, $mask, @otherMasks) = @_;
2215        # Set up for error recovery.
2216        eval {
2217            # Switch to the specified directory.
2218            ChDir($dirName);
2219            # Get the group ID.
2220            my $gid = getgrnam($group);
2221            # Get the mask for tracing.
2222            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2223            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2224            my $fixCount = 0;
2225            my $lookCount = 0;
2226            # @dirs will be a stack of directories to be processed.
2227            my @dirs = (getcwd());
2228            while (scalar(@dirs) > 0) {
2229                # Get the current directory.
2230                my $dir = pop @dirs;
2231                # Check for a match to one of the specified directory names. To do
2232                # that, we need to pull the individual part of the name off of the
2233                # whole path.
2234                my $simpleName = $dir;
2235                if ($dir =~ m!/([^/]+)$!) {
2236                    $simpleName = $1;
2237                }
2238                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2239                # Search for a match.
2240                my $match = 0;
2241                my $i;
2242                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2243                    my $pattern = $otherMasks[$i];
2244                    if ($simpleName =~ /$pattern/i) {
2245                        $match = 1;
2246                    }
2247                }
2248                # Check for a match. Note we use $i-1 because the loop added 2
2249                # before terminating due to the match.
2250                if ($match && $otherMasks[$i-1] != $mask) {
2251                    # This directory matches one of the incoming patterns, and it's
2252                    # a different mask, so we process it recursively with that mask.
2253                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2254                } else {
2255                    # Here we can process normally. Get all of the non-hidden members.
2256                    my @submems = OpenDir($dir, 1);
2257                    for my $submem (@submems) {
2258                        # Get the full name.
2259                        my $thisMem = "$dir/$submem";
2260                        Trace("Checking member $thisMem.") if T(4);
2261                        $lookCount++;
2262                        if ($lookCount % 1000 == 0) {
2263                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2264                        }
2265                        # Fix the group.
2266                        chown -1, $gid, $thisMem;
2267                        # Insure this member is not a symlink.
2268                        if (! -l $thisMem) {
2269                            # Get its info.
2270                            my $fileInfo = stat $thisMem;
2271                            # Only proceed if we got the info. Otherwise, it's a hard link
2272                            # and we want to skip it anyway.
2273                            if ($fileInfo) {
2274                                my $fileMode = $fileInfo->mode;
2275                                if (($fileMode & $mask) != $mask) {
2276                                    # Fix this member.
2277                                    $fileMode |= $mask;
2278                                    chmod $fileMode, $thisMem;
2279                                    $fixCount++;
2280                                }
2281                                # If it's a subdirectory, stack it.
2282                                if (-d $thisMem) {
2283                                    push @dirs, $thisMem;
2284                                }
2285                            }
2286                        }
2287                    }
2288                }
2289            }
2290            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2291        };
2292        # Check for an error.
2293        if ($@) {
2294            Confess("SetPermissions error: $@");
2295        }
2296    }
2297    
2298  1;  1;

Legend:
Removed from v.1.45  
changed lines
  Added in v.1.59

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3