[Bio] / FigKernelPackages / ServerThing.pm Repository:
ViewVC logotype

View of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (download) (as text) (annotate)
Sun Mar 14 14:30:12 2010 UTC (9 years, 11 months ago) by parrello
Branch: MAIN
Changes since 1.37: +1 -1 lines
*** empty log message ***

#!/usr/bin/perl -w

package ServerThing;

    use strict;
    use Tracer;
    use YAML;
    use ERDB;
    use TestUtils;
    use Time::HiRes;
    use File::Temp;
    use ErrorMessage;
    use CGI;
    no warnings qw(once);

    # Maximum number of requests to run per invocation.
    use constant MAX_REQUESTS => 5000;

=head1 General Server Helper

This package provides a method-- I<RunServer>-- that can be called from a CGI
script to perform the duties of a FIG server. RunServer is called with two
parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>) and
the first command-line parameter. The command-line parameter (if defined) will
be used as the tracing key, and also indicates that the script is being invoked
from the command line rather than over the web.

=cut

sub RunServer {
    # Get the parameters.
    my ($serverName, $key) = @_;
    # Set up tracing. We never do CGI tracing here; the only question is whether
    # or not the caller passed in a tracing key. If he didn't, we use the server
    # name.
    ETracing($key || $serverName, destType => 'APPEND', level => '0 ServerThing');
    # Turn off YAML compression, which causes problems with some of our hash keys.
    $YAML::CompressSeries = 0;
    # Create the server object.
    Trace("Requiring $serverName for task $$.") if T(3);
    eval {
        require "$serverName.pm";
    };
    # If we have an error, create an error document.
    if ($@) {
        SendError($@, "Could not load server module.");
    } else {
        # Having successfully loaded the server code, we create the object.
        my $serverThing = eval("$serverName" . '->new()');
        Trace("$serverName object created for task $$.") if T(2);
        # If we have an error, create an error document.
        if ($@) {
            SendError($@, "Could not start server.");
        } else {
            # No error, so now we can process the request.
            my $cgi;
            if (! defined $key) {
                # No tracing key, so presume we're a web service. Check for Fast CGI.
                if ($ENV{REQUEST_METHOD} eq '') {
                    # Count the number of requests.
                    my $requests = 0;
                    Trace("Starting Fast CGI loop.") if T(3);
                    # Loop through the fast CGI requests. If we have request throttling,
                    # we exit after a maximum number of requests has been exceeded.
                    require CGI::Fast;
                    while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
                           ($cgi = new CGI::Fast())) {
                        RunRequest($cgi, $serverThing);
                        Trace("Request $requests complete in task $$.") if T(3);
                    }
                    Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
                } else {
                    # Here we have a normal web service (non-Fast).
                    my $cgi = CGI->new();
                    # Check for a source parameter. This gets used as the tracing key.
                    $key = $cgi->param('source');
                    # Run this request.
                    RunRequest($cgi, $serverThing);
                }
            } else {
                # We're being invoked from the command line. Use the tracing
                # key to find the parm file and create the CGI object from that.
                my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
                $cgi = CGI->new($ih);
                # Run this request.
                RunRequest($cgi, $serverThing);
            }
        }
    }
}


=head2 Server Utility Methods

The methods in this section are utilities of general use to the various
server modules.

=head3 AddSubsystemFilter

    ServerThing::AddSubsystemFilter(\$filter, $args);

Add subsystem filtering information to the specified query filter clause
based on data in the argument hash. The argument hash will be checked for
the C<-usable> parameter, which includes or excludes unusuable subsystems, and
the C<-exclude> parameter, which lists types of subsystems that should be
excluded.

=over 4

=item filter

Reference to the current filter string. If additional filtering is required,
this string will be updated.

=item args

Reference to the parameter hash for the current server call. This hash will
be examined for the C<-usable> and C<-exclude> parameters.

=back

=cut

use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
                                         experimental   => 1,
                                         private        => 1 };

sub AddSubsystemFilter {
    # Get the parameters.
    my ($filter, $args) = @_;
    # We'll put the new filter stuff in here.
    my @newFilters;
    # Unless unusable subsystems are desired, we must add a clause to the filter.
    # The default is that only usable subsystems are included.
    my $usable = 1;
    # This default can be overridden by the "-usable" parameter.
    if (exists $args->{-usable}) {
        $usable = $args->{-usable};
    }
    # If we're restricting to usable subsystems, add a filter to that effect.
    if ($usable) {
        push @newFilters, "Subsystem(usable) = 1";
    }
    # Check for exclusion filters.
    my $exclusions = ServerThing::GetIdList(-exclude => $args, 1);
    for my $exclusion (@$exclusions) {
        if (! SS_TYPE_EXCLUDE_ITEMS->{$exclusion}) {
            Confess("Invalid exclusion type \"$exclusion\".");
        } else {
            # Here we have to exclude subsystems of the specified type.
            push @newFilters, "Subsystem($exclusion) = 0";
        }
    }
    # Do we need to update the incoming filter?
    if (@newFilters) {
        # Yes. If the incoming filter is nonempty, push it onto the list
        # so it gets included in the result.
        if ($$filter) {
            push @newFilters, $$filter;
        }
        # Put all the filters together to form the new filter.
        $$filter = join(" AND ", @newFilters);
        Trace("Subsystem filter is $$filter.") if T(ServerUtilities => 3);
    }
}



=head3 GetIdList

    my $ids = ServerThing::GetIdList($name => $args, $optional);

Get a named list of IDs from an argument structure. If the IDs are
missing, or are not a list, an error will occur.

=over 4

=item name

Name of the argument structure member that should contain the ID list.

=item args

Argument structure from which the ID list is to be extracted.

=item optional (optional)

If TRUE, then a missing value will not generate an error. Instead, an empty list
will be returned. The default is FALSE.

=item RETURN

Returns a reference to a list of IDs taken from the argument structure.

=back

=cut

sub GetIdList {
    # Get the parameters.
    my ($name, $args, $optional) = @_;
    # Declare the return variable.
    my $retVal;
    # Check the argument format.
    if (! defined $args && $optional) {
        # Here there are no parameters, but the arguments are optional so it's
        # okay.
        $retVal = [];
    } elsif (ref $args ne 'HASH') {
        # Here we have an invalid parameter structure.
        Confess("No '$name' parameter present.");
    } else {
        # Here we have a hash with potential parameters in it. Try to get the
        # IDs from the argument structure.
        $retVal = $args->{$name};
        # Was a member found?
        if (! defined $retVal) {
            # No. If we're optional, return an empty list; otherwise throw an error.
            if ($optional) {
                $retVal = [];
            } else {
                Confess("No '$name' parameter found.");
            }
        } else {
            # Here we found something. Get the parameter type. We want a list reference.
            # If it's a scalar, we'll convert it to a singleton list. If it's anything
            # else, it's an error.
            my $type = ref $retVal;
            if (! $type) {
                $retVal = [$retVal];
            } elsif ($type ne 'ARRAY') {
                Confess("The '$name' parameter must be a list.");
            }
        }
    }
    # Return the result.
    return $retVal;
}


=head3 RunTool

    ServerThing::RunTool($name => $cmd);

Run a command-line tool. A non-zero return value from the tool will cause
a fatal error, and the tool's error log will be traced.

=over 4

=item name

Name to give to the tool in the error output.

=item cmd

Command to use for running the tool. This should be the complete command line.
The command should not contain any fancy piping, though it may redirect the
standard input and output. The command will be modified by this method to
redirect the error output to a temporary file.

=back

=cut

sub RunTool {
    # Get the parameters.
    my ($name, $cmd) = @_;
    # Compute the log file name.
    my $errorLog = "$FIG_Config::temp/errors$$.log";
    # Execute the command.
    Trace("Executing command: $cmd") if T(ServerUtilities => 3);
    my $res = system("$cmd 2> $errorLog");
    Trace("Return from $name tool is $res.") if T(ServerUtilities => 3);
    # Check the result code.
    if ($res != 0) {
        # We have an error. If tracing is on, trace it.
        if (T(ServerUtilities => 1)) {
            TraceErrorLog($name, $errorLog);
        }
        # Delete the error log.
        unlink $errorLog;
        # Confess the error.
        Confess("$name command failed with error code $res.");
    } else {
        # Everything worked. Trace the error log if necessary.
        if (T(ServerUtilities => 3) && -s $errorLog) {
            TraceErrorLog($name, $errorLog);
        }
        # Delete the error log if there is one.
        unlink $errorLog;
    }
}


=head2 Gene Correspondence File Methods

These methods relate to gene correspondence files, which are generated by the
L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
copied into the organism directories themselves. At that point, the code below
will be modified to check the organism directories first and use the cache
directory if no file is found there.

A gene correspondence file contains correspondences from a source genome to a
target genome. Most such correspondences are bidirectional best hits. A unidirectional
best hit may exist from the source genome to the target genome or in the reverse
direction from the targtet genome to the source genome. The cache directory itself
is divided into subdirectories by organism. The subdirectory has the source genome
name and the files themselves are named by the target genome.

Some of the files are invalid and will be erased when they are found. A file is
considered invalid if it has a non-numeric value in a numeric column or if it
does not have any unidirectional hits from the target genome to the source
genome.

The process of managing the correspondence files is tricky and dangerous because
of the possibility of race conditions. It can take several minutes to generate a
file, and if two processes try to generate the same file at the same time we need
to make sure they don't step on each other.

In stored files, the source genome ID is always lexically lower than the target
genome ID. If a correspondence in the reverse direction is desired, the converse
file is found and the contents flipped automatically as they are read. So, the
correspondence from B<360108.3> to B<100226.1> would be found in a file with the
name B<360108.3> in the directory for B<100226.1>. Since this file actually has
B<100226.1> as the source and B<360108.3> as the target, the columns are
re-ordered and the arrows reversed before the file contents are passed to the
caller.

=head4 Gene Correspondence List

A gene correspondence file contains 18 columns. These are usually packaged as
a reference to list of lists. Each sub-list has the following format.

=over 4

=item 0

The ID of a PEG in genome 1.

=item 1

The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".

=item 2

Count of the number of pairs of matching genes were found in the context.

=item 3

Pairs of corresponding genes from the contexts.

=item 4

The function of the gene in genome 1.

=item 5

The function of the gene in genome 2.

=item 6

Comma-separated list of aliases for the gene in genome 1 (any protein with an
identical sequence is considered an alias, whether or not it is actually the
name of the same gene in the same genome).

=item 7

Comma-separated list of aliases for the gene in genome 2 (any protein with an
identical sequence is considered an alias, whether or not it is actually the
name of the same gene in the same genome).

=item 8

Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.

=item 9

Percent identity over the region of the detected match.

=item 10

The P-score for the detected match.

=item 11

Beginning match coordinate in the protein encoded by the gene in genome 1.

=item 12

Ending match coordinate in the protein encoded by the gene in genome 1.

=item 13

Length of the protein encoded by the gene in genome 1.

=item 14

Beginning match coordinate in the protein encoded by the gene in genome 2.

=item 15

Ending match coordinate in the protein encoded by the gene in genome 2.

=item 16

Length of the protein encoded by the gene in genome 2.

=item 17

Bit score for the match. Divide by the length of the longer PEG to get
what we often refer to as a "normalized bit score".

=back

In the actual files, there will also be reverse correspondences indicated by a
back-arrow ("<-") in item (8). The output returned by the servers, however,
is filtered so that only forward correspondences occur. If a converse file
is used, the columns are re-ordered and the arrows reversed so that it looks
correct.

=cut

# hash for reversing the arrows
use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
# list of columns that contain numeric values that need to be validated
use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];

=head3 CheckForGeneCorrespondenceFile

    my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);

Try to find a gene correspondence file for the specified genome pairing. If the
file exists, its name and an indication of whether or not it is in the correct
direction will be returned.

=over 4

=item genome1

Source genome for the desired correspondence.

=item genome2

Target genome for the desired correspondence.

=item RETURN

Returns a two-element list. The first element is the name of the file containing the
correspondence, or C<undef> if the file does not exist. The second element is TRUE
if the correspondence would be forward or FALSE if the file needs to be flipped.

=back

=cut

sub CheckForGeneCorrespondenceFile {
    # Get the parameters.
    my ($genome1, $genome2) = @_;
    # Declare the return variables.
    my ($fileName, $converse);
    # Determine the ordering of the genome IDs.
    my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
    $converse = ($genomeA ne $genome1);
    # Look for a file containing the desired correspondence. (The code to check for a
    # pre-computed file in the organism directories is currently turned off, because
    # these files are all currently invalid.)
    my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
    if (0 && -f $testFileName) {
        # Use the pre-computed file.
        Trace("Using pre-computed file $fileName for genome correspondence.") if T(3);
        $fileName = $testFileName;
    } elsif (-f $corrFileName) {
        $fileName = $corrFileName;
        Trace("Using cached file $fileName for genome correspondence.") if T(3);
    }
    # Return the result.
    return ($fileName, $converse);
}


=head3 ComputeCorrespondenceFileName

    my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);

Compute the name to be given to a genome correspondence file in the organism cache
and return the source and target genomes that would be in it.

=over 4

=item genome1

Source genome for the desired correspondence.

=item genome2

Target genome for the desired correspondence.

=item RETURN

Returns a three-element list. The first element is the name of the file to contain the
correspondence, the second element is the name of the genome that would act as the
source genome in the file, and the third element is the name of the genome that would
act as the target genome in the file.

=back

=cut

sub ComputeCorrespondenceFileName {
    # Get the parameters.
    my ($genome1, $genome2) = @_;
    # Declare the return variables.
    my ($fileName, $genomeA, $genomeB);
    # Determine the ordering of the genome IDs.
    if ($genome1 lt $genome2) {
        ($genomeA, $genomeB) = ($genome1, $genome2);
    } else {
        ($genomeA, $genomeB) = ($genome2, $genome1);
    }
    # Insure the source organism has a subdirectory in the organism cache.
    my $orgDir = "$FIG_Config::orgCache/$genomeA";
    Tracer::Insure($orgDir, 0777);
    # Compute the name of the correspondence file for the appropriate target genome.
    $fileName = "$orgDir/$genomeB";
    # Return the results.
    return ($fileName, $genomeA, $genomeB);
}


=head3 CreateGeneCorrespondenceFile

    my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);

Create a new gene correspondence file in the organism cache for the specified
genome correspondence. The name of the new file will be returned along with
an indicator of whether or not it is in the correct direction.

=over 4

=item genome1

Source genome for the desired correspondence.

=item genome2

Target genome for the desired correspondence.

=item RETURN

Returns a two-element list. The first element is the name of the file containing the
correspondence, or C<undef> if an error occurred. The second element is TRUE
if the correspondence would be forward or FALSE if the file needs to be flipped.

=back

=cut

sub CreateGeneCorrespondenceFile {
    # Get the parameters.
    my ($genome1, $genome2) = @_;
    # Declare the return variables.
    my ($fileName, $converse);
    # Compute the ultimate name for the correspondence file.
    my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
    $converse = ($genome1 ne $genomeA);
    # Generate a temporary file name in the same directory. We'll build the temporary
    # file and then rename it when we're done.
    my $tempFileName = "$corrFileName.$$.tmp";
    # This will be set to FALSE if we detect an error.
    my $fileOK = 1;
    # The file handles will be put in here.
    my ($ih, $oh);
    # Protect from errors.
    eval {
        # Open the temporary file for output.
        $oh = Open(undef, ">$tempFileName");
        # Open a pipe to get the correspondence data.
        $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
        Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
        # Copy the pipe date into the temporary file.
        while (! eof $ih) {
            my $line = <$ih>;
            print $oh $line;
        }
        # Close both files. If the close fails we need to know: it means there was a pipe
        # error.
        $fileOK &&= close $ih;
        $fileOK &&= close $oh;
    };
    if ($@) {
        # Here a fatal error of some sort occurred. We need to force the files closed.
        close $ih if $ih;
        close $oh if $oh;
    } elsif ($fileOK) {
        # Here everything worked. Try to rename the temporary file to the real
        # file name.
        if (rename $tempFileName, $corrFileName) {
            # Everything is ok, fix the permissions and return the file name.
            chmod 0664, $corrFileName;
            $fileName = $corrFileName;
            Trace("Created correspondence file $fileName.") if T(3);
        }
    }
    # If the temporary file exists, delete it.
    if (-f $tempFileName) {
        unlink $tempFileName;
    }
    # Return the results.
    return ($fileName, $converse);
}


=head3 ReadGeneCorrespondenceFile

    my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);

Return the contents of the specified gene correspondence file in the form of
a list of lists, with backward correspondences filtered out. If the file is
for the converse of the desired correspondence, the columns will be reordered
automatically so that it looks as if the file were designed for the proper
direction.

=over 4

=item fileName

The name of the gene correspondence file to read.

=item converse (optional)

TRUE if the file is for the converse of the desired correspondence, else FALSE.
If TRUE, the file columns will be reorderd automatically. The default is FALSE,
meaning we want to use the file as it appears on disk.

=item RETURN

Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
If the file's contents are invalid or an error occurs, an undefined value will be
returned.

=back

=cut

sub ReadGeneCorrespondenceFile {
    # Get the parameters.
    my ($fileName, $converse) = @_;
    # Declare the return variable. We will only put something in here if we are
    # completely successful.
    my $retVal;
    # This value will be set to 1 if an error is detected.
    my $error = 0;
    # Try to open the file.
    my $ih;
    Trace("Reading correspondence file $fileName.") if T(3);
    if (! open $ih, "<$fileName") {
        # Here the open failed, so we have an error.
        Trace("Failed to open gene correspondence file $fileName: $!") if T(3);
        $error = 1;
    }
    # The gene correspondence list will be built in here.
    my @corrList;
    # This variable will be set to TRUE if we find a reverse correspondence somewhere
    # in the file. Not finding one is an error.
    my $reverseFound = 0;
    # Loop until we hit the end of the file or an error occurs. We must check the error
    # first in case the file handle failed to open.
    while (! $error && ! eof $ih) {
        # Get the current line.
        my @row = Tracer::GetLine($ih);
        # Get the correspondence direction and check for a reverse arrow.
        $reverseFound = 1 if ($row[8] eq '<-');
        # If we're in converse mode, reformat the line.
        if ($converse) {
            ($row[1], $row[0], $row[2], $row[3], $row[5], $row[4], $row[7], $row[6],
             ARROW_FLIP->{$row[8]}, $row[9], $row[10], $row[14], $row[15], $row[16],
             $row[11], $row[12], $row[13], $row[17]) = @row;
        }
        # Validate the row.
        if (ValidateGeneCorrespondenceRow(\@row)) {
            Trace("Invalid row $. found in correspondence file $fileName.") if T(3);
            $error = 1;
        }
        # If this row is in the correct direction, keep it.
        if ($row[8] ne '<-') {
            push @corrList, \@row;
        }
    }
    # Close the input file.
    close $ih;
    # If we have no errors and we found a reverse arrow, keep the result.
    if (! $error) {
        if ($reverseFound) {
            $retVal = \@corrList;
        } else {
            Trace("No reverse arrow found in correspondence file $fileName.") if T(3);
        }
    }
    # Return the result (if any).
    return $retVal;
}


=head3 ValidateGeneCorrespondenceRow

    my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);

Validate a gene correspondence row. The numeric fields are checked to insure they
are numeric and the source and target gene IDs are validated. The return value will
indicate the number of errors found.

=over 4

=item row

Reference to a list containing a single row from a L</Gene Correspondence List>.

=item RETURN

Returns the number of errors found in the row. A return of C<0> indicates the row
is valid.

=back

=cut

sub ValidateGeneCorrespondenceRow {
    # Get the parameters.
    my ($row, $genome1, $genome2) = @_;
    # Denote no errors have been found so far.
    my $retVal = 0;
    # Check for non-numeric values in the number columns.
    for my $col (@{NUM_COLS()}) {
        unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
            $retVal++;
        }
    }
    # Check the gene IDs.
    for my $col (0, 1) {
        unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
            $retVal++;
        }
    }
    # Verify the arrow.
    unless (exists ARROW_FLIP->{$row->[8]}) {
        $retVal++;
    }
    # Return the error count.
    return $retVal;
}


=head2 Internal Utility Methods

The methods in this section are used internally by this package.

=head3 RunRequest

    ServerThing::RunRequest($cgi, $serverName);

Run a request from the specified server using the incoming CGI parameter
object for the parameters.

=over 4

=item cgi

CGI query object containing the parameters from the web service request.

=item serverThing

Server object against which to run the request.

=back

=cut

sub RunRequest {
    # Get the parameters.
    my ($cgi, $serverThing, $docURL) = @_;
    # Determine the request type.
    if ($cgi->param('pod')) {
        # Here we have a documentation request. In this case, we produce POD HTML.
        ProducePod($cgi->param('pod'));
    } elsif ($cgi->param('code')) {
        # Here the user wants to see the code for one of our scripts.
        LineNumberize($cgi->param('code'));
    } elsif ($cgi->param('file')) {
        # Here we have a file request. Process according to the type.
        my $type = $cgi->param('file');
        if ($type eq 'open') {
            OpenFile($cgi->param('name'));
        } elsif ($type eq 'create') {
            CreateFile();
        } elsif ($type eq 'read') {
            ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
        } elsif ($type eq 'write') {
            WriteChunk($cgi->param('name'), $cgi->param('data'));
        } else {
            Die("Invalid file function \"$type\".");
        }
    } else {
        # The default is a function request. Get the function name.
        my $function = $cgi->param('function') || "";
        Trace("Server function for task $$ is $function.") if T(3);
        # Insure the function name is valid.
        Die("Invalid function name.")
            if $function =~ /\W/;
        # The parameter structure will go in here.
        my $args;
        # Start the timer.
        my $start = time();
        # The output document goes in here.
        my $document;
        # The sapling database goes in here.
        my $sapling;
        # Protect from errors.
        eval {
            # Parse the arguments.
            $args = YAML::Load($cgi->param('args'));
        };
        # Check to make sure we got everything.
        if ($@) {
            SendError($@, "Error formatting parameters.");
        } elsif (! $function) {
            SendError("No function specified.", "No function specified.");
        } else {
            $document = eval { $serverThing->$function($args) };
            # If we have an error, create an error document.
            if ($@) {
                SendError($@, "Error detected by service.");
                Trace("Error encountered by service: $@") if T(0);
            } else {
                # No error, so we output the result.
                print $cgi->header(-type => 'text/plain');
                my $string = YAML::Dump($document);
                print $string;
                MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
            }
        }
        # Stop the timer.
        my $duration = int(time() - $start + 0.5);
        Trace("Function $function executed in $duration seconds by task $$.") if T(2);
    }
}

=head3 CreateFile

    ServerThing::CreateFile();

Create a new, empty temporary file and send its name back to the client.

=cut

sub CreateFile {
    ##TODO: Code
}

=head3 OpenFile

    ServerThing::OpenFile($name);

Send the length of the named file back to the client.

=over 4

=item name

##TODO: name description

=back

=cut

sub OpenFile {
    # Get the parameters.
    my ($name) = @_;
    ##TODO: Code
}

=head3 ReadChunk

    ServerThing::ReadChunk($name, $location, $size);

Read the indicated number of bytes from the specified location of the
named file and send them back to the client.

=over 4

=item name

##TODO: name description

=item location

##TODO: location description

=item size

##TODO: size description

=back

=cut

sub ReadChunk {
    # Get the parameters.
    my ($name, $location, $size) = @_;
    ##TODO: Code
}

=head3 WriteChunk

    ServerThing::WriteChunk($name, $data);

Write the specified data to the named file.

=over 4

=item name

##TODO: name description

=item data

##TODO: data description

=back

=cut

sub WriteChunk {
    # Get the parameters.
    my ($name, $data) = @_;
    ##TODO: Code
}


=head3 LineNumberize

    ServerThing::LineNumberize($module);

Output the module line by line with line numbers

=over 4

=item module

Name of the module to line numberized

=back

=cut

sub LineNumberize {
    # Get the parameters.
    my ($module) = @_;
    my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
    # Start the output page.
    print CGI::header();
    print CGI::start_html(-title => 'Documentation Page',
                          -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
    # Protect from errors.
    eval {
        if (-e $fks_path) {
            print "<pre>\n";
            my $i = 1;
            foreach my $line (`cat $fks_path`) {
                print "$i.\t$line";
                $i++;
            }
            print "</pre>\n";
        } else {
            print "File $fks_path not found";
        }
    };
    # Process any error.
    if ($@) {
        print CGI::blockquote({ class => 'error' }, $@);
    }
    # Close off the page.
    print CGI::end_html();

}

=head3 ProducePod

    ServerThing::ProducePod($module);

Output the POD documentation for the specified module.

=over 4

=item module

Name of the module whose POD document is to be displayed.

=back

=cut

sub ProducePod {
    # Get the parameters.
    my ($module) = @_;
    # Start the output page.
    print CGI::header();
    print CGI::start_html(-title => 'Documentation Page',
                          -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
    # Protect from errors.
    eval {
        # We'll format the HTML text in here.
        require DocUtils;
        my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
        # Output the POD HTML.
        print $html;
    };
    # Process any error.
    if ($@) {
        print CGI::blockquote({ class => 'error' }, $@);
    }
    # Close off the page.
    print CGI::end_html();

}

=head3 TraceErrorLog

    ServerThing::TraceErrorLog($name, $errorLog);

Trace the specified error log file. This is a very dinky routine that
performs a task required by L</RunTool> in multiple places.

=over 4

=item name

Name of the tool relevant to the log file.

=item errorLog

Name of the log file.

=back

=cut

sub TraceErrorLog {
    my ($name, $errorLog) = @_;
    my $errorData = Tracer::GetFile($errorLog);
    Trace("$name error log:\n$errorData");
}

=head3 SendError

    ServerThing::SendError($message, $status);

Fail an HTTP request with the specified error message and the specified
status message.

=over 4

=item message

Detailed error message. This is sent as the page content.

=item status

Status message. This is sent as part of the status code.

=back

=cut

sub SendError {
    # Get the parameters.
    my ($message, $status) = @_;
    Trace("Error \"$status\" $message") if T(2);
    # Check for a DBserver error. These can be retried and get a special status
    # code.
    my $realStatus;
    if ($message =~ /DBServer Error:\s+/) {
        $realStatus = "503 $status";
    } else {
        $realStatus = "500 $status";
    }
    # Print the header and the status message.
    print CGI::header(-type => 'text/plain',
                      -status => $realStatus);
    # Print the detailed message.
    print $message;
}


1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3