[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.65, Tue Sep 19 19:28:48 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        use URI::Escape;
37    
38  =head1 Tracing and Debugging Helpers  =head1 Tracing and Debugging Helpers
39    
# Line 1346  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 1379  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 1404  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.
1461    
1462    =back
1463    
1464    =cut
1465    
1466    sub PutFile {
1467        # Get the parameters.
1468        my ($fileName, $lines) = @_;
1469        # Open the output file.
1470        my $handle = Open(undef, ">$fileName");
1471        # Write the lines.
1472        for my $line (@{$lines}) {
1473            print $handle "$line\n";
1474        }
1475        # Close the output file.
1476        close $handle;
1477    }
1478    
1479  =head3 QTrace  =head3 QTrace
1480    
1481  C<< my $data = QTrace($format); >>  C<< my $data = QTrace($format); >>
# Line 1604  Line 1676 
1676    
1677  =head3 AddToListMap  =head3 AddToListMap
1678    
1679  C<< Tracer::AddToListMap(\%hash, $key, $value); >>  C<< Tracer::AddToListMap(\%hash, $key, $value1, $value2, ... valueN); >>
1680    
1681  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
1682  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 1691 
1691    
1692  Key for which the value is to be added.  Key for which the value is to be added.
1693    
1694  =item value  =item value1, value2, ... valueN
1695    
1696  Value to add to the key's value list.  List of values to add to the key's value list.
1697    
1698  =back  =back
1699    
# Line 1629  Line 1701 
1701    
1702  sub AddToListMap {  sub AddToListMap {
1703      # Get the parameters.      # Get the parameters.
1704      my ($hash, $key, $value) = @_;      my ($hash, $key, @values) = @_;
1705      # Process according to whether or not the key already has a value.      # Process according to whether or not the key already has a value.
1706      if (! exists $hash->{$key}) {      if (! exists $hash->{$key}) {
1707          $hash->{$key} = [$value];          $hash->{$key} = [@values];
1708      } else {      } else {
1709          push @{$hash->{$key}}, $value;          push @{$hash->{$key}}, @values;
1710      }      }
1711  }  }
1712    
# Line 1664  Line 1736 
1736          $retVal = 1;          $retVal = 1;
1737      } else {      } else {
1738          # Here debug mode is off, so we generate an error page.          # Here debug mode is off, so we generate an error page.
1739          my $pageString = PageBuilder::Build("<Html/ErrorPage.html", {}, "Html");          my $pageString = PageBuilder::Build("<<Html/ErrorPage.html", {}, "Html");
1740          print $pageString;          print $pageString;
1741      }      }
1742      # Return the determination indicator.      # Return the determination indicator.
# Line 1835  Line 1907 
1907      my $query = CGI->new();      my $query = CGI->new();
1908      # Check for tracing. Set it up if the user asked for it.      # Check for tracing. Set it up if the user asked for it.
1909      if ($query->param('Trace')) {      if ($query->param('Trace')) {
1910          # Set up tracing to be queued for display at the bottom of the web page.          # Set up tracing.
1911          TSetup($query->param('Trace') . " FIG Tracer", "QUEUE");          my $ttype = ($query->param('TF') ? ">$FIG_Config::temp/Trace$$.log" : "QUEUE");
1912            TSetup($query->param('Trace') . " FIG Tracer", $ttype);
1913          # Trace the parameter and environment data.          # Trace the parameter and environment data.
1914            TraceParms($query);
1915        } else {
1916            # Here tracing is to be turned off. All we allow is errors traced into the
1917            # error log.
1918            TSetup("0", "WARN");
1919        }
1920        # Create the variable hash.
1921        my $varHash = { DebugData => '' };
1922        # Return the query object and variable hash.
1923        return ($query, $varHash);
1924    }
1925    
1926    =head3 TraceParms
1927    
1928    C<< Tracer::TraceParms($query); >>
1929    
1930    Trace the CGI parameters at trace level CGI => 3 and the environment variables
1931    at level CGI => 4.
1932    
1933    =over 4
1934    
1935    =item query
1936    
1937    CGI query object containing the parameters to trace.
1938    
1939    =back
1940    
1941    =cut
1942    
1943    sub TraceParms {
1944        # Get the parameters.
1945        my ($query) = @_;
1946          if (T(CGI => 3)) {          if (T(CGI => 3)) {
1947              # Here we want to trace the parameter data.              # Here we want to trace the parameter data.
1948              my @names = $query->param;              my @names = $query->param;
# Line 1855  Line 1960 
1960                  Trace("ENV: $envName = $ENV{$envName}");                  Trace("ENV: $envName = $ENV{$envName}");
1961              }              }
1962          }          }
     } 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);  
1963  }  }
1964    
1965  =head3 ScriptFinish  =head3 ScriptFinish
# Line 1931  Line 2023 
2023      # Check for a template file situation.      # Check for a template file situation.
2024      my $outputString;      my $outputString;
2025      if (defined $varHash) {      if (defined $varHash) {
2026          # 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.
2027          $outputString = PageBuilder::Build("<$webData", $varHash, "Html");          my $template;
2028            if ($FIG_Config::template_url && $webData =~ /\.php$/) {
2029                $template = "$FIG_Config::template_url/$webData";
2030            } else {
2031                $template = "<<$webData";
2032            }
2033            $outputString = PageBuilder::Build($template, $varHash, "Html");
2034      } else {      } else {
2035          # Here the user gave us a raw string.          # Here the user gave us a raw string.
2036          $outputString = $webData;          $outputString = $webData;
# Line 2008  Line 2106 
2106      }      }
2107  }  }
2108    
2109    =head3 SendSMS
2110    
2111    C<< my $msgID = Tracer::SendSMS($phoneNumber, $msg); >>
2112    
2113    Send a text message to a phone number using Clickatell. The FIG_Config file must contain the
2114    user name, password, and API ID for the relevant account in the hash reference variable
2115    I<$FIG_Config::phone>, using the keys C<user>, C<password>, and C<api_id>. For
2116    example, if the user name is C<BruceTheHumanPet>, the password is C<silly>, and the API ID
2117    is C<2561022>, then the FIG_Config file must contain
2118    
2119        $phone =  { user => 'BruceTheHumanPet',
2120                    password => 'silly',
2121                    api_id => '2561022' };
2122    
2123    The original purpose of this method was to insure Bruce would be notified immediately when the
2124    Sprout Load terminates. Care should be taken if you do not wish Bruce to be notified immediately
2125    when you call this method.
2126    
2127    The message ID will be returned if successful, and C<undef> if an error occurs.
2128    
2129    =over 4
2130    
2131    =item phoneNumber
2132    
2133    Phone number to receive the message, in international format. A United States phone number
2134    would be prefixed by "1". A British phone number would be prefixed by "44".
2135    
2136    =item msg
2137    
2138    Message to send to the specified phone.
2139    
2140    =item RETURN
2141    
2142    Returns the message ID if successful, and C<undef> if the message could not be sent.
2143    
2144    =back
2145    
2146    =cut
2147    
2148    sub SendSMS {
2149        # Get the parameters.
2150        my ($phoneNumber, $msg) = @_;
2151        # Declare the return variable. If we do not change it, C<undef> will be returned.
2152        my $retVal;
2153        # Only proceed if we have phone support.
2154        if (! defined $FIG_Config::phone) {
2155            Trace("Phone support not present in FIG_Config.") if T(1);
2156        } else {
2157            # Get the phone data.
2158            my $parms = $FIG_Config::phone;
2159            # Get the Clickatell URL.
2160            my $url = "http://api.clickatell.com/http/";
2161            # Create the user agent.
2162            my $ua = LWP::UserAgent->new;
2163            # Request a Clickatell session.
2164            my $resp = $ua->post("$url/sendmsg", { user => $parms->{user},
2165                                         password => $parms->{password},
2166                                         api_id => $parms->{api_id},
2167                                         to => $phoneNumber,
2168                                         text => $msg});
2169            # Check for an error.
2170            if (! $resp->is_success) {
2171                Trace("Alert failed.") if T(1);
2172            } else {
2173                # Get the message ID.
2174                my $rstring = $resp->content;
2175                if ($rstring =~ /^ID:\s+(.*)$/) {
2176                    $retVal = $1;
2177                } else {
2178                    Trace("Phone attempt failed with $rstring") if T(1);
2179                }
2180            }
2181        }
2182        # Return the result.
2183        return $retVal;
2184    }
2185    
2186    =head3 CommaFormat
2187    
2188    C<< my $formatted = Tracer::CommaFormat($number); >>
2189    
2190    Insert commas into a number.
2191    
2192    =over 4
2193    
2194    =item number
2195    
2196    A sequence of digits.
2197    
2198    =item RETURN
2199    
2200    Returns the same digits with commas strategically inserted.
2201    
2202    =back
2203    
2204    =cut
2205    
2206    sub CommaFormat {
2207        # Get the parameters.
2208        my ($number) = @_;
2209        # Pad the length up to a multiple of three.
2210        my $padded = "$number";
2211        $padded = " " . $padded while length($padded) % 3 != 0;
2212        # This is a fancy PERL trick. The parentheses in the SPLIT pattern
2213        # cause the delimiters to be included in the output stream. The
2214        # GREP removes the empty strings in between the delimiters.
2215        my $retVal = join(",", grep { $_ ne '' } split(/(...)/, $padded));
2216        # Clean out the spaces.
2217        $retVal =~ s/ //g;
2218        # Return the result.
2219        return $retVal;
2220    }
2221    =head3 SetPermissions
2222    
2223    C<< Tracer::SetPermissions($dirName, $group, $mask, %otherMasks); >>
2224    
2225    Set the permissions for a directory and all the files and folders inside it.
2226    In addition, the group ownership will be changed to the specified value.
2227    
2228    This method is more vulnerable than most to permission and compatability
2229    problems, so it does internal error recovery.
2230    
2231    =over 4
2232    
2233    =item dirName
2234    
2235    Name of the directory to process.
2236    
2237    =item group
2238    
2239    Name of the group to be assigned.
2240    
2241    =item mask
2242    
2243    Permission mask. Bits that are C<1> in this mask will be ORed into the
2244    permission bits of any file or directory that does not already have them
2245    set to 1.
2246    
2247    =item otherMasks
2248    
2249    Map of search patterns to permission masks. If a directory name matches
2250    one of the patterns, that directory and all its members and subdirectories
2251    will be assigned the new pattern. For example, the following would
2252    assign 01664 to most files, but would use 01777 for directories named C<tmp>.
2253    
2254        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp$' => 01777);
2255    
2256    The list is ordered, so the following would use 0777 for C<tmp1> and
2257    0666 for C<tmp>, C<tmp2>, or C<tmp3>.
2258    
2259        Tracer::SetPermissions($dirName, 'fig', 01664, '^tmp1' => 0777,
2260                                                       '^tmp' => 0666);
2261    
2262    Note that the pattern matches are all case-insensitive, and only directory
2263    names are matched, not file names.
2264    
2265    =back
2266    
2267    =cut
2268    
2269    sub SetPermissions {
2270        # Get the parameters.
2271        my ($dirName, $group, $mask, @otherMasks) = @_;
2272        # Set up for error recovery.
2273        eval {
2274            # Switch to the specified directory.
2275            ChDir($dirName);
2276            # Get the group ID.
2277            my $gid = getgrnam($group);
2278            # Get the mask for tracing.
2279            my $traceMask = sprintf("%04o", $mask) . "($mask)";
2280            Trace("Fixing permissions for directory $dirName using group $group($gid) and mask $traceMask.") if T(2);
2281            my $fixCount = 0;
2282            my $lookCount = 0;
2283            # @dirs will be a stack of directories to be processed.
2284            my @dirs = (getcwd());
2285            while (scalar(@dirs) > 0) {
2286                # Get the current directory.
2287                my $dir = pop @dirs;
2288                # Check for a match to one of the specified directory names. To do
2289                # that, we need to pull the individual part of the name off of the
2290                # whole path.
2291                my $simpleName = $dir;
2292                if ($dir =~ m!/([^/]+)$!) {
2293                    $simpleName = $1;
2294                }
2295                Trace("Simple directory name for $dir is $simpleName.") if T(4);
2296                # Search for a match.
2297                my $match = 0;
2298                my $i;
2299                for ($i = 0; $i < $#otherMasks && ! $match; $i += 2) {
2300                    my $pattern = $otherMasks[$i];
2301                    if ($simpleName =~ /$pattern/i) {
2302                        $match = 1;
2303                    }
2304                }
2305                # Check for a match. Note we use $i-1 because the loop added 2
2306                # before terminating due to the match.
2307                if ($match && $otherMasks[$i-1] != $mask) {
2308                    # This directory matches one of the incoming patterns, and it's
2309                    # a different mask, so we process it recursively with that mask.
2310                    SetPermissions($dir, $group, $otherMasks[$i-1], @otherMasks);
2311                } else {
2312                    # Here we can process normally. Get all of the non-hidden members.
2313                    my @submems = OpenDir($dir, 1);
2314                    for my $submem (@submems) {
2315                        # Get the full name.
2316                        my $thisMem = "$dir/$submem";
2317                        Trace("Checking member $thisMem.") if T(4);
2318                        $lookCount++;
2319                        if ($lookCount % 1000 == 0) {
2320                            Trace("$lookCount members examined. Current is $thisMem. Mask is $traceMask") if T(3);
2321                        }
2322                        # Fix the group.
2323                        chown -1, $gid, $thisMem;
2324                        # Insure this member is not a symlink.
2325                        if (! -l $thisMem) {
2326                            # Get its info.
2327                            my $fileInfo = stat $thisMem;
2328                            # Only proceed if we got the info. Otherwise, it's a hard link
2329                            # and we want to skip it anyway.
2330                            if ($fileInfo) {
2331                                my $fileMode = $fileInfo->mode;
2332                                if (($fileMode & $mask) != $mask) {
2333                                    # Fix this member.
2334                                    $fileMode |= $mask;
2335                                    chmod $fileMode, $thisMem;
2336                                    $fixCount++;
2337                                }
2338                                # If it's a subdirectory, stack it.
2339                                if (-d $thisMem) {
2340                                    push @dirs, $thisMem;
2341                                }
2342                            }
2343                        }
2344                    }
2345                }
2346            }
2347            Trace("$lookCount files and directories processed, $fixCount fixed.") if T(2);
2348        };
2349        # Check for an error.
2350        if ($@) {
2351            Confess("SetPermissions error: $@");
2352        }
2353    }
2354    
2355    =head3 CompareLists
2356    
2357    C<< my ($inserted, $deleted) = Tracer::CompareLists(\@newList, \@oldList, $keyIndex); >>
2358    
2359    Compare two lists of tuples, and return a hash analyzing the differences. The lists
2360    are presumed to be sorted alphabetically by the value in the $keyIndex column.
2361    The return value contains a list of items that are only in the new list
2362    (inserted) and only in the old list (deleted).
2363    
2364    =over 4
2365    
2366    =item newList
2367    
2368    Reference to a list of new tuples.
2369    
2370    =item oldList
2371    
2372    Reference to a list of old tuples.
2373    
2374    =item keyIndex (optional)
2375    
2376    Index into each tuple of its key field. The default is 0.
2377    
2378    =item RETURN
2379    
2380    Returns a 2-tuple consisting of a reference to the list of items that are only in the new
2381    list (inserted) followed by a reference to the list of items that are only in the old
2382    list (deleted).
2383    
2384    =back
2385    
2386    =cut
2387    
2388    sub CompareLists {
2389        # Get the parameters.
2390        my ($newList, $oldList, $keyIndex) = @_;
2391        if (! defined $keyIndex) {
2392            $keyIndex = 0;
2393        }
2394        # Declare the return variables.
2395        my ($inserted, $deleted) = ([], []);
2396        # Loop through the two lists simultaneously.
2397        my ($newI, $oldI) = (0, 0);
2398        my ($newN, $oldN) = (scalar @{$newList}, scalar @{$oldList});
2399        while ($newI < $newN || $oldI < $oldN) {
2400            # Get the current object in each list. Note that if one
2401            # of the lists is past the end, we'll get undef.
2402            my $newItem = $newList->[$newI];
2403            my $oldItem = $oldList->[$oldI];
2404            if (! defined($newItem) || defined($oldItem) && $newItem->[$keyIndex] gt $oldItem->[$keyIndex]) {
2405                # The old item is not in the new list, so mark it deleted.
2406                push @{$deleted}, $oldItem;
2407                $oldI++;
2408            } elsif (! defined($oldItem) || $oldItem->[$keyIndex] gt $newItem->[$keyIndex]) {
2409                # The new item is not in the old list, so mark it inserted.
2410                push @{$inserted}, $newItem;
2411                $newI++;
2412            } else {
2413                # The item is in both lists, so push forward.
2414                $oldI++;
2415                $newI++;
2416            }
2417        }
2418        # Return the result.
2419        return ($inserted, $deleted);
2420    }
2421    
2422    =head3 GetLine
2423    
2424    C<< my @data = Tracer::GetLine($handle); >>
2425    
2426    Read a line of data from a tab-delimited file.
2427    
2428    =over 4
2429    
2430    =item handle
2431    
2432    Open file handle from which to read.
2433    
2434    =item RETURN
2435    
2436    Returns a list of the fields in the record read. The fields are presumed to be
2437    tab-delimited. If we are at the end of the file, then an empty list will be
2438    returned. If an empty line is read, a single list item consisting of a null
2439    string will be returned.
2440    
2441    =back
2442    
2443    =cut
2444    
2445    sub GetLine {
2446        # Get the parameters.
2447        my ($handle) = @_;
2448        # Declare the return variable.
2449        my @retVal = ();
2450        # Read from the file.
2451        my $line = <$handle>;
2452        # Only proceed if we found something.
2453        if (defined $line) {
2454            # Remove the new-line.
2455            chomp $line;
2456            # If the line is empty, return a single empty string; otherwise, parse
2457            # it into fields.
2458            if ($line eq "") {
2459                push @retVal, "";
2460            } else {
2461                push @retVal, split /\t/,$line;
2462            }
2463        }
2464        # Return the result.
2465        return @retVal;
2466    }
2467    
2468    =head3 PutLine
2469    
2470    C<< Tracer::PutLine($handle, \@fields); >>
2471    
2472    Write a line of data to a tab-delimited file. The specified field values will be
2473    output in tab-separated form, with a trailing new-line.
2474    
2475    =over 4
2476    
2477    =item handle
2478    
2479    Output file handle.
2480    
2481    =item fields
2482    
2483    List of field values.
2484    
2485    =back
2486    
2487    =cut
2488    
2489    sub PutLine {
2490        # Get the parameters.
2491        my ($handle, $fields) = @_;
2492        # Write the data.
2493        print $handle join("\t", @{$fields}) . "\n";
2494    }
2495    
2496    =head3 GenerateURL
2497    
2498    C<< my $queryUrl = Tracer::GenerateURL($page, %parameters); >>
2499    
2500    Generate a GET-style URL for the specified page with the specified parameter
2501    names and values. The values will be URL-escaped automatically. So, for
2502    example
2503    
2504        Tracer::GenerateURL("form.cgi", type => 1, string => "\"high pass\" or highway")
2505    
2506    would return
2507    
2508        form.cgi?type=1&string=%22high%20pass%22%20or%20highway
2509    
2510    =over 4
2511    
2512    =item page
2513    
2514    Page URL.
2515    
2516    =item parameters
2517    
2518    Hash mapping parameter names to parameter values.
2519    
2520    =item RETURN
2521    
2522    Returns a GET-style URL that goes to the specified page and passes in the
2523    specified parameters and values.
2524    
2525    =back
2526    
2527    =cut
2528    
2529    sub GenerateURL {
2530        # Get the parameters.
2531        my ($page, %parameters) = @_;
2532        # Prime the return variable with the page URL.
2533        my $retVal = $page;
2534        # Loop through the parameters, creating parameter elements in a list.
2535        my @parmList = map { "$_=" . uri_escape($parameters{$_}) } keys %parameters;
2536        # If the list is nonempty, tack it on.
2537        if (@parmList) {
2538            $retVal .= "?" . join("&", @parmList);
2539        }
2540        # Return the result.
2541        return $retVal;
2542    }
2543    
2544  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3