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

Diff of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6, Thu Aug 27 19:44:45 2009 UTC revision 1.47, Tue Apr 13 20:05:49 2010 UTC
# Line 7  Line 7 
7      use YAML;      use YAML;
8      use ERDB;      use ERDB;
9      use TestUtils;      use TestUtils;
     use DocUtils;  
10      use Time::HiRes;      use Time::HiRes;
11      use ErrorDocument;      use File::Temp;
12        use ErrorMessage;
13      use CGI;      use CGI;
14        no warnings qw(once);
15    
16        # Maximum number of requests to run per invocation.
17        use constant MAX_REQUESTS => 5000;
18    
19  =head1 General Server Helper  =head1 General Server Helper
20    
21  This package provides a method-- I<RunServer>-- that can be called from a CGI  This package provides a method-- I<RunServer>-- that can be called from a CGI
22  script to perform the duties of a FIG server. RunServer is called with three  script to perform the duties of a FIG server. RunServer is called with two
23  parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>),  parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>) and
24  the first command-line parameter, and the URL prefix to use for the documentation.  the first command-line parameter. The command-line parameter (if defined) will
25  The command-line parameter (if defined) will be used as the tracing key, and is  be used as the tracing key, and also indicates that the script is being invoked
26  used to indicate that the script is being invoked from the command line rather  from the command line rather than over the web.
 than over the web.  
27    
28  =cut  =cut
29    
30  sub RunServer {  sub RunServer {
31      # Get the parameters.      # Get the parameters.
32      my ($serverName, $key, $docURL) = @_;      my ($serverName, $key) = @_;
33      # Get the CGI parameters.      # Set up tracing. We never do CGI tracing here; the only question is whether
34        # or not the caller passed in a tracing key. If he didn't, we use the server
35        # name.
36        ETracing($key || $serverName, destType => 'APPEND', level => '0 ServerThing');
37        # Turn off YAML compression, which causes problems with some of our hash keys.
38        $YAML::CompressSeries = 0;
39        # Create the server object.
40        Trace("Requiring $serverName for task $$.") if T(3);
41        eval {
42            require "$serverName.pm";
43        };
44        # If we have an error, create an error document.
45        if ($@) {
46            SendError($@, "Could not load server module.");
47        } else {
48            # Having successfully loaded the server code, we create the object.
49            my $serverThing = eval("$serverName" . '->new()');
50            Trace("$serverName object created for task $$.") if T(2);
51            # If we have an error, create an error document.
52            if ($@) {
53                SendError($@, "Could not start server.");
54            } else {
55                # No error, so now we can process the request.
56      my $cgi;      my $cgi;
57      if (! defined $key) {      if (! defined $key) {
58          # No tracing key, so presume we're a web service. Check for Fast CGI.          # No tracing key, so presume we're a web service. Check for Fast CGI.
59          if ($ENV{REQUEST_METHOD} eq '') {          if ($ENV{REQUEST_METHOD} eq '') {
60              # Here we're doing Fast CGI. In this case, the tracing key is the                      # Count the number of requests.
61              # server name.                      my $requests = 0;
62              ETracing($serverName);                      Trace("Starting Fast CGI loop.") if T(3);
63              # Loop through the fast CGI requests.                      # Loop through the fast CGI requests. If we have request throttling,
64                        # we exit after a maximum number of requests has been exceeded.
65              require CGI::Fast;              require CGI::Fast;
66              while ($cgi = new CGI::Fast()) {                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
67                  RunRequest($cgi, $serverName, $docURL);                             ($cgi = new CGI::Fast())) {
68                            RunRequest($cgi, $serverThing);
69                            Trace("Request $requests complete in task $$.") if T(3);
70              }              }
71                        Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
72          } else {          } else {
73              # Here we have a normal web service (non-Fast).              # Here we have a normal web service (non-Fast).
74              my $cgi = CGI->new();              my $cgi = CGI->new();
75              # Check for a source parameter. This gets used as the tracing key.              # Check for a source parameter. This gets used as the tracing key.
76              $key = $cgi->param('source');              $key = $cgi->param('source');
             if (! $key) {  
                 # No source parameter, so do normal setup. Note we turn off  
                 # CGI parameter tracing.  
                 ETracing($cgi, 'noParms');  
             } else {  
                 # Set up tracing using the specified key.  
                 ETracing($key);  
             }  
77              # Run this request.              # Run this request.
78              RunRequest($cgi, $serverName, $docURL);                      RunRequest($cgi, $serverThing);
79          }          }
80      } else {      } else {
81          # We're being invoked from the command line. Use the tracing          # We're being invoked from the command line. Use the tracing
82          # key to find the parm file and create the CGI object from that.          # key to find the parm file and create the CGI object from that.
83          my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");          my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
84          $cgi = CGI->new($ih);          $cgi = CGI->new($ih);
         # Set up tracing using the specified key.  
         ETracing($key);  
85          # Run this request.          # Run this request.
86          RunRequest($cgi, $serverName, $docURL);                  RunRequest($cgi, $serverThing);
87                }
88            }
89      }      }
90  }  }
91    
92    
93  =head3 RunRequest  =head2 Server Utility Methods
94    
95      ServerThing::RunRequest($cgi, $serverName, $docURL);  The methods in this section are utilities of general use to the various
96    server modules.
97    
98  Run a request from the specified server using the incoming CGI parameter  =head3 AddSubsystemFilter
 object for the parameters.  
99    
100  =over 4      ServerThing::AddSubsystemFilter(\$filter, $args);
101    
102  =item cgi  Add subsystem filtering information to the specified query filter clause
103    based on data in the argument hash. The argument hash will be checked for
104    the C<-usable> parameter, which includes or excludes unusuable subsystems, and
105    the C<-exclude> parameter, which lists types of subsystems that should be
106    excluded.
107    
108  CGI query object containing the parameters from the web service request.  =over 4
109    
110  =item serverName  =item filter
111    
112  Name of the server to be used for running the request.  Reference to the current filter string. If additional filtering is required,
113    this string will be updated.
114    
115  =item docURL  =item args
116    
117  URL to be used for a documentation request.  Reference to the parameter hash for the current server call. This hash will
118    be examined for the C<-usable> and C<-exclude> parameters.
119    
120  =back  =back
121    
122  =cut  =cut
123    
124  sub RunRequest {  use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
125                                             experimental   => 1,
126                                             private        => 1 };
127    
128    sub AddSubsystemFilter {
129      # Get the parameters.      # Get the parameters.
130      my ($cgi, $serverName, $docURL) = @_;      my ($filter, $args) = @_;
131      Trace("Running $serverName server request.") if T(3);      # We'll put the new filter stuff in here.
132      # Is this a documentation request?      my @newFilters;
133      my $module = $cgi->param('pod');      # Unless unusable subsystems are desired, we must add a clause to the filter.
134      if ($module) {      # The default is that only usable subsystems are included.
135          # Here we have a documentation request. In this case, we produce POD HTML.      my $usable = 1;
136          # Start the output page.      # This default can be overridden by the "-usable" parameter.
137          print CGI::header();      if (exists $args->{-usable}) {
138          print CGI::start_html(-title => 'Documentation Page',          $usable = $args->{-usable};
                               -style => { src => "$FIG_Config::cgi_url/Html/css/ERDB.css" });  
         # Protect from errors.  
         eval {  
             # We'll format the HTML text in here.  
             my $html = DocUtils::ShowPod($module, $docURL);  
             # Output the POD HTML.  
             print $html;  
         };  
         # Process any error.  
         if ($@) {  
             print CGI::blockquote({ class => 'error' }, $@);  
139          }          }
140          # Close off the page.      # If we're restricting to usable subsystems, add a filter to that effect.
141          print CGI::end_html();      if ($usable) {
142      } else {          push @newFilters, "Subsystem(usable) = 1";
         # Here we have a function request. Get the function name.  
         my $function = $cgi->param('function') || "";  
         Trace("Server function 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 ($@) {  
             $document = ErrorDocument->new('<initialization>', $@);  
         } elsif (! $function) {  
             $document = ErrorDocument->new('<missing>', "No function specified.");  
         } else {  
             # We're okay, so load the server function object.  
             Trace("Requiring $serverName") if T(3);  
             eval {  
                 require "$serverName.pm";  
             };  
             # If we have an error, create an error document.  
             if ($@) {  
                 $document = ErrorDocument->new($function, $@);  
                 Trace("Error loading server module: $@") if T(2);  
             } else {  
                 # Having successfully loaded the server code, we create the object.  
                 my $serverThing = eval("$serverName" . '->new()');  
                 # If we have an error, create an error document.  
                 if ($@) {  
                     $document = ErrorDocument->new($function, $@);  
                     Trace("Error creating server function object: $@") if T(2);  
                 } else {  
                     # No error, so execute the server method.  
                     Trace("Executing $function.") if T(2);  
                     $document = eval("\$serverThing->$function(\$args)");  
                     # If we have an error, create an error document.  
                     if ($@) {  
                         $document = ErrorDocument->new($function, $@);  
                         Trace("Error encountered by service: $@") if T(2);  
143                      }                      }
144        # Check for exclusion filters.
145        my $exclusions = ServerThing::GetIdList(-exclude => $args, 1);
146        for my $exclusion (@$exclusions) {
147            if (! SS_TYPE_EXCLUDE_ITEMS->{$exclusion}) {
148                Confess("Invalid exclusion type \"$exclusion\".");
149            } else {
150                # Here we have to exclude subsystems of the specified type.
151                push @newFilters, "Subsystem($exclusion) = 0";
152                  }                  }
153              }              }
154        # Do we need to update the incoming filter?
155        if (@newFilters) {
156            # Yes. If the incoming filter is nonempty, push it onto the list
157            # so it gets included in the result.
158            if ($$filter) {
159                push @newFilters, $$filter;
160          }          }
161          # Stop the timer.          # Put all the filters together to form the new filter.
162          my $duration = int(time() - $start + 0.5);          $$filter = join(" AND ", @newFilters);
163          Trace("Function executed in $duration seconds.") if T(2);          Trace("Subsystem filter is $$filter.") if T(ServerUtilities => 3);
         # Output the YAML.  
         print $cgi->header(-type => 'text/plain');  
         print YAML::Dump($document);  
164      }      }
165  }  }
166    
167    
 =head2 Utility Methods  
   
 The methods in this section are utilities of general use to the various  
 server modules.  
168    
169  =head3 GetIdList  =head3 GetIdList
170    
171      my $ids = ServerThing::GetIdList($name => $args);      my $ids = ServerThing::GetIdList($name => $args, $optional);
172    
173  Get a named list of IDs from an argument structure. If the IDs are  Get a named list of IDs from an argument structure. If the IDs are
174  missing, or are not a list, an error will occur.  missing, or are not a list, an error will occur.
# Line 205  Line 183 
183    
184  Argument structure from which the ID list is to be extracted.  Argument structure from which the ID list is to be extracted.
185    
186    =item optional (optional)
187    
188    If TRUE, then a missing value will not generate an error. Instead, an empty list
189    will be returned. The default is FALSE.
190    
191  =item RETURN  =item RETURN
192    
193  Returns a reference to a list of IDs taken from the argument structure.  Returns a reference to a list of IDs taken from the argument structure.
# Line 215  Line 198 
198    
199  sub GetIdList {  sub GetIdList {
200      # Get the parameters.      # Get the parameters.
201      my ($name, $args) = @_;      my ($name, $args, $optional) = @_;
202      # Try to get the IDs from the argument structure.      # Declare the return variable.
203      my $retVal = $args->{$name};      my $retVal;
204      # Throw an error if no member was found.      # Check the argument format.
205      Confess("No '$name' parameter found.") if ! defined $retVal;      if (! defined $args && $optional) {
206      # Get the parameter type. We was a list reference. If it's a scalar, we'll          # Here there are no parameters, but the arguments are optional so it's
207      # convert it to a singleton list. If it's anything else, it's an error.          # okay.
208            $retVal = [];
209        } elsif (ref $args ne 'HASH') {
210            # Here we have an invalid parameter structure.
211            Confess("No '$name' parameter present.");
212        } else {
213            # Here we have a hash with potential parameters in it. Try to get the
214            # IDs from the argument structure.
215            $retVal = $args->{$name};
216            # Was a member found?
217            if (! defined $retVal) {
218                # No. If we're optional, return an empty list; otherwise throw an error.
219                if ($optional) {
220                    $retVal = [];
221                } else {
222                    Confess("No '$name' parameter found.");
223                }
224            } else {
225                # Here we found something. Get the parameter type. We want a list reference.
226                # If it's a scalar, we'll convert it to a singleton list. If it's anything
227                # else, it's an error.
228      my $type = ref $retVal;      my $type = ref $retVal;
229      if (! $type) {      if (! $type) {
230          $retVal = [$retVal];          $retVal = [$retVal];
231      } elsif ($type ne 'ARRAY') {      } elsif ($type ne 'ARRAY') {
232          Confess("The '$name' parameter must be a list.");          Confess("The '$name' parameter must be a list.");
233      }      }
234            }
235        }
236        # Return the result.
237        return $retVal;
238    }
239    
240    
241    =head3 RunTool
242    
243        ServerThing::RunTool($name => $cmd);
244    
245    Run a command-line tool. A non-zero return value from the tool will cause
246    a fatal error, and the tool's error log will be traced.
247    
248    =over 4
249    
250    =item name
251    
252    Name to give to the tool in the error output.
253    
254    =item cmd
255    
256    Command to use for running the tool. This should be the complete command line.
257    The command should not contain any fancy piping, though it may redirect the
258    standard input and output. The command will be modified by this method to
259    redirect the error output to a temporary file.
260    
261    =back
262    
263    =cut
264    
265    sub RunTool {
266        # Get the parameters.
267        my ($name, $cmd) = @_;
268        # Compute the log file name.
269        my $errorLog = "$FIG_Config::temp/errors$$.log";
270        # Execute the command.
271        Trace("Executing command: $cmd") if T(ServerUtilities => 3);
272        my $res = system("$cmd 2> $errorLog");
273        Trace("Return from $name tool is $res.") if T(ServerUtilities => 3);
274        # Check the result code.
275        if ($res != 0) {
276            # We have an error. If tracing is on, trace it.
277            if (T(ServerUtilities => 1)) {
278                TraceErrorLog($name, $errorLog);
279            }
280            # Delete the error log.
281            unlink $errorLog;
282            # Confess the error.
283            Confess("$name command failed with error code $res.");
284        } else {
285            # Everything worked. Trace the error log if necessary.
286            if (T(ServerUtilities => 3) && -s $errorLog) {
287                TraceErrorLog($name, $errorLog);
288            }
289            # Delete the error log if there is one.
290            unlink $errorLog;
291        }
292    }
293    
294    
295    =head2 Gene Correspondence File Methods
296    
297    These methods relate to gene correspondence files, which are generated by the
298    L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
299    organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
300    copied into the organism directories themselves. At that point, the code below
301    will be modified to check the organism directories first and use the cache
302    directory if no file is found there.
303    
304    A gene correspondence file contains correspondences from a source genome to a
305    target genome. Most such correspondences are bidirectional best hits. A unidirectional
306    best hit may exist from the source genome to the target genome or in the reverse
307    direction from the targtet genome to the source genome. The cache directory itself
308    is divided into subdirectories by organism. The subdirectory has the source genome
309    name and the files themselves are named by the target genome.
310    
311    Some of the files are invalid and will be erased when they are found. A file is
312    considered invalid if it has a non-numeric value in a numeric column or if it
313    does not have any unidirectional hits from the target genome to the source
314    genome.
315    
316    The process of managing the correspondence files is tricky and dangerous because
317    of the possibility of race conditions. It can take several minutes to generate a
318    file, and if two processes try to generate the same file at the same time we need
319    to make sure they don't step on each other.
320    
321    In stored files, the source genome ID is always lexically lower than the target
322    genome ID. If a correspondence in the reverse direction is desired, the converse
323    file is found and the contents flipped automatically as they are read. So, the
324    correspondence from B<360108.3> to B<100226.1> would be found in a file with the
325    name B<360108.3> in the directory for B<100226.1>. Since this file actually has
326    B<100226.1> as the source and B<360108.3> as the target, the columns are
327    re-ordered and the arrows reversed before the file contents are passed to the
328    caller.
329    
330    =head4 Gene Correspondence List
331    
332    A gene correspondence file contains 18 columns. These are usually packaged as
333    a reference to list of lists. Each sub-list has the following format.
334    
335    =over 4
336    
337    =item 0
338    
339    The ID of a PEG in genome 1.
340    
341    =item 1
342    
343    The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".
344    
345    =item 2
346    
347    Count of the number of pairs of matching genes were found in the context.
348    
349    =item 3
350    
351    Pairs of corresponding genes from the contexts.
352    
353    =item 4
354    
355    The function of the gene in genome 1.
356    
357    =item 5
358    
359    The function of the gene in genome 2.
360    
361    =item 6
362    
363    Comma-separated list of aliases for the gene in genome 1 (any protein with an
364    identical sequence is considered an alias, whether or not it is actually the
365    name of the same gene in the same genome).
366    
367    =item 7
368    
369    Comma-separated list of aliases for the gene in genome 2 (any protein with an
370    identical sequence is considered an alias, whether or not it is actually the
371    name of the same gene in the same genome).
372    
373    =item 8
374    
375    Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.
376    
377    =item 9
378    
379    Percent identity over the region of the detected match.
380    
381    =item 10
382    
383    The P-score for the detected match.
384    
385    =item 11
386    
387    Beginning match coordinate in the protein encoded by the gene in genome 1.
388    
389    =item 12
390    
391    Ending match coordinate in the protein encoded by the gene in genome 1.
392    
393    =item 13
394    
395    Length of the protein encoded by the gene in genome 1.
396    
397    =item 14
398    
399    Beginning match coordinate in the protein encoded by the gene in genome 2.
400    
401    =item 15
402    
403    Ending match coordinate in the protein encoded by the gene in genome 2.
404    
405    =item 16
406    
407    Length of the protein encoded by the gene in genome 2.
408    
409    =item 17
410    
411    Bit score for the match. Divide by the length of the longer PEG to get
412    what we often refer to as a "normalized bit score".
413    
414    =back
415    
416    In the actual files, there will also be reverse correspondences indicated by a
417    back-arrow ("<-") in item (8). The output returned by the servers, however,
418    is filtered so that only forward correspondences occur. If a converse file
419    is used, the columns are re-ordered and the arrows reversed so that it looks
420    correct.
421    
422    =cut
423    
424    # hash for reversing the arrows
425    use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
426    # list of columns that contain numeric values that need to be validated
427    use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];
428    
429    =head3 CheckForGeneCorrespondenceFile
430    
431        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
432    
433    Try to find a gene correspondence file for the specified genome pairing. If the
434    file exists, its name and an indication of whether or not it is in the correct
435    direction will be returned.
436    
437    =over 4
438    
439    =item genome1
440    
441    Source genome for the desired correspondence.
442    
443    =item genome2
444    
445    Target genome for the desired correspondence.
446    
447    =item RETURN
448    
449    Returns a two-element list. The first element is the name of the file containing the
450    correspondence, or C<undef> if the file does not exist. The second element is TRUE
451    if the correspondence would be forward or FALSE if the file needs to be flipped.
452    
453    =back
454    
455    =cut
456    
457    sub CheckForGeneCorrespondenceFile {
458        # Get the parameters.
459        my ($genome1, $genome2) = @_;
460        # Declare the return variables.
461        my ($fileName, $converse);
462        # Determine the ordering of the genome IDs.
463        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
464        $converse = ($genomeA ne $genome1);
465        # Look for a file containing the desired correspondence. (The code to check for a
466        # pre-computed file in the organism directories is currently turned off, because
467        # these files are all currently invalid.)
468        my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
469        if (0 && -f $testFileName) {
470            # Use the pre-computed file.
471            Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
472            $fileName = $testFileName;
473        } elsif (-f $corrFileName) {
474            $fileName = $corrFileName;
475            Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
476        }
477      # Return the result.      # Return the result.
478        return ($fileName, $converse);
479    }
480    
481    
482    =head3 ComputeCorrespondenceFileName
483    
484        my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);
485    
486    Compute the name to be given to a genome correspondence file in the organism cache
487    and return the source and target genomes that would be in it.
488    
489    =over 4
490    
491    =item genome1
492    
493    Source genome for the desired correspondence.
494    
495    =item genome2
496    
497    Target genome for the desired correspondence.
498    
499    =item RETURN
500    
501    Returns a three-element list. The first element is the name of the file to contain the
502    correspondence, the second element is the name of the genome that would act as the
503    source genome in the file, and the third element is the name of the genome that would
504    act as the target genome in the file.
505    
506    =back
507    
508    =cut
509    
510    sub ComputeCorrespondenceFileName {
511        # Get the parameters.
512        my ($genome1, $genome2) = @_;
513        # Declare the return variables.
514        my ($fileName, $genomeA, $genomeB);
515        # Determine the ordering of the genome IDs.
516        if (MustFlipGenomeIDs($genome1, $genome2)) {
517            ($genomeA, $genomeB) = ($genome2, $genome1);
518        } else {
519            ($genomeA, $genomeB) = ($genome1, $genome2);
520        }
521        # Insure the source organism has a subdirectory in the organism cache.
522        my $orgDir = ComputeCorrespondenceDirectory($genomeA);
523        # Compute the name of the correspondence file for the appropriate target genome.
524        $fileName = "$orgDir/$genomeB";
525        # Return the results.
526        return ($fileName, $genomeA, $genomeB);
527    }
528    
529    
530    =head3 ComputeCorresopndenceDirectory
531    
532        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
533    
534    Return the name of the directory that would contain the correspondence files
535    for the specified genome.
536    
537    =over 4
538    
539    =item genome
540    
541    ID of the genome whose correspondence file directory is desired.
542    
543    =item RETURN
544    
545    Returns the name of the directory of interest.
546    
547    =back
548    
549    =cut
550    
551    sub ComputeCorrespondenceDirectory {
552        # Get the parameters.
553        my ($genome) = @_;
554        # Insure the source organism has a subdirectory in the organism cache.
555        my $retVal = "$FIG_Config::orgCache/$genome";
556        Tracer::Insure($retVal, 0777);
557        # Return it.
558      return $retVal;      return $retVal;
559  }  }
560    
561    
562    =head3 CreateGeneCorrespondenceFile
563    
564        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
565    
566    Create a new gene correspondence file in the organism cache for the specified
567    genome correspondence. The name of the new file will be returned along with
568    an indicator of whether or not it is in the correct direction.
569    
570    =over 4
571    
572    =item genome1
573    
574    Source genome for the desired correspondence.
575    
576    =item genome2
577    
578    Target genome for the desired correspondence.
579    
580    =item RETURN
581    
582    Returns a two-element list. The first element is the name of the file containing the
583    correspondence, or C<undef> if an error occurred. The second element is TRUE
584    if the correspondence would be forward or FALSE if the file needs to be flipped.
585    
586    =back
587    
588    =cut
589    
590    sub CreateGeneCorrespondenceFile {
591        # Get the parameters.
592        my ($genome1, $genome2) = @_;
593        # Declare the return variables.
594        my ($fileName, $converse);
595        # Compute the ultimate name for the correspondence file.
596        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
597        $converse = ($genome1 ne $genomeA);
598        # Generate a temporary file name in the same directory. We'll build the temporary
599        # file and then rename it when we're done.
600        my $tempFileName = "$corrFileName.$$.tmp";
601        # This will be set to FALSE if we detect an error.
602        my $fileOK = 1;
603        # The file handles will be put in here.
604        my ($ih, $oh);
605        # Protect from errors.
606        eval {
607            # Open the temporary file for output.
608            $oh = Open(undef, ">$tempFileName");
609            # Open a pipe to get the correspondence data.
610            $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
611            Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
612            # Copy the pipe date into the temporary file.
613            while (! eof $ih) {
614                my $line = <$ih>;
615                print $oh $line;
616            }
617            # Close both files. If the close fails we need to know: it means there was a pipe
618            # error.
619            $fileOK &&= close $ih;
620            $fileOK &&= close $oh;
621        };
622        if ($@) {
623            # Here a fatal error of some sort occurred. We need to force the files closed.
624            close $ih if $ih;
625            close $oh if $oh;
626        } elsif ($fileOK) {
627            # Here everything worked. Try to rename the temporary file to the real
628            # file name.
629            if (rename $tempFileName, $corrFileName) {
630                # Everything is ok, fix the permissions and return the file name.
631                chmod 0664, $corrFileName;
632                $fileName = $corrFileName;
633                Trace("Created correspondence file $fileName.") if T(Corr => 3);
634            }
635        }
636        # If the temporary file exists, delete it.
637        if (-f $tempFileName) {
638            unlink $tempFileName;
639        }
640        # Return the results.
641        return ($fileName, $converse);
642    }
643    
644    
645    =head3 MustFlipGenomeIDs
646    
647        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
648    
649    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
650    order, they are stored in the converse order in correspondence files on the server.
651    This is a simple method that allows the caller to check for the need to flip.
652    
653    =over 4
654    
655    =item genome1
656    
657    ID of the proposed source genome.
658    
659    =item genome2
660    
661    ID of the proposed target genome.
662    
663    =item RETURN
664    
665    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
666    it would be stored as a source.
667    
668    =cut
669    
670    sub MustFlipGenomeIDs {
671        # Get the parameters.
672        my ($genome1, $genome2) = @_;
673        # Return an indication.
674        return ($genome1 gt $genome2);
675    }
676    
677    
678    =head3 ReadGeneCorrespondenceFile
679    
680        my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
681    
682    Return the contents of the specified gene correspondence file in the form of
683    a list of lists, with backward correspondences filtered out. If the file is
684    for the converse of the desired correspondence, the columns will be reordered
685    automatically so that it looks as if the file were designed for the proper
686    direction.
687    
688    =over 4
689    
690    =item fileName
691    
692    The name of the gene correspondence file to read.
693    
694    =item converse (optional)
695    
696    TRUE if the file is for the converse of the desired correspondence, else FALSE.
697    If TRUE, the file columns will be reorderd automatically. The default is FALSE,
698    meaning we want to use the file as it appears on disk.
699    
700    =item all (optional)
701    
702    TRUE if backward unidirectional correspondences should be included in the output.
703    The default is FALSE, in which case only forward and bidirectional correspondences
704    are included.
705    
706    =item RETURN
707    
708    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
709    If the file's contents are invalid or an error occurs, an undefined value will be
710    returned.
711    
712    =back
713    
714    =cut
715    
716    sub ReadGeneCorrespondenceFile {
717        # Get the parameters.
718        my ($fileName, $converse, $all) = @_;
719        # Declare the return variable. We will only put something in here if we are
720        # completely successful.
721        my $retVal;
722        # This value will be set to 1 if an error is detected.
723        my $error = 0;
724        # Try to open the file.
725        my $ih;
726        Trace("Reading correspondence file $fileName.") if T(3);
727        if (! open $ih, "<$fileName") {
728            # Here the open failed, so we have an error.
729            Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
730            $error = 1;
731        }
732        # The gene correspondence list will be built in here.
733        my @corrList;
734        # This variable will be set to TRUE if we find a reverse correspondence somewhere
735        # in the file. Not finding one is an error.
736        my $reverseFound = 0;
737        # Loop until we hit the end of the file or an error occurs. We must check the error
738        # first in case the file handle failed to open.
739        while (! $error && ! eof $ih) {
740            # Get the current line.
741            my @row = Tracer::GetLine($ih);
742            # Get the correspondence direction and check for a reverse arrow.
743            $reverseFound = 1 if ($row[8] eq '<-');
744            # If we're in converse mode, reformat the line.
745            if ($converse) {
746                ReverseGeneCorrespondenceRow(\@row);
747            }
748            # Validate the row.
749            if (ValidateGeneCorrespondenceRow(\@row)) {
750                Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
751                $error = 1;
752            }
753            # If this row is in the correct direction, keep it.
754            if ($all || $row[8] ne '<-') {
755                push @corrList, \@row;
756            }
757        }
758        # Close the input file.
759        close $ih;
760        # If we have no errors and we found a reverse arrow, keep the result.
761        if (! $error) {
762            if ($reverseFound) {
763                $retVal = \@corrList;
764            } else {
765                Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);
766            }
767        }
768        # Return the result (if any).
769        return $retVal;
770    }
771    
772    =head3 ReverseGeneCorrespondenceRow
773    
774        ServerThing::ReverseGeneCorrespondenceRow($row)
775    
776    Convert a gene correspondence row to represent the converse correspondence. The
777    elements in the row will be reordered to represent a correspondence from the
778    target genome to the source genome.
779    
780    =over 4
781    
782    =item row
783    
784    Reference to a list containing a single row from a L</Gene Correspondence List>.
785    
786    =back
787    
788    =cut
789    
790    sub ReverseGeneCorrespondenceRow {
791        # Get the parameters.
792        my ($row) = @_;
793        # Flip the row in place.
794        ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
795         $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
796         $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
797        # Flip the arrow.
798        $row->[8] = ARROW_FLIP->{$row->[8]};
799        # Flip the pairs.
800        my @elements = split /,/, $row->[3];
801        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
802    }
803    
804    =head3 ValidateGeneCorrespondenceRow
805    
806        my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);
807    
808    Validate a gene correspondence row. The numeric fields are checked to insure they
809    are numeric and the source and target gene IDs are validated. The return value will
810    indicate the number of errors found.
811    
812    =over 4
813    
814    =item row
815    
816    Reference to a list containing a single row from a L</Gene Correspondence List>.
817    
818    =item RETURN
819    
820    Returns the number of errors found in the row. A return of C<0> indicates the row
821    is valid.
822    
823    =back
824    
825    =cut
826    
827    sub ValidateGeneCorrespondenceRow {
828        # Get the parameters.
829        my ($row, $genome1, $genome2) = @_;
830        # Denote no errors have been found so far.
831        my $retVal = 0;
832        # Check for non-numeric values in the number columns.
833        for my $col (@{NUM_COLS()}) {
834            unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
835                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
836                $retVal++;
837            }
838        }
839        # Check the gene IDs.
840        for my $col (0, 1) {
841            unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
842                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
843                $retVal++;
844            }
845        }
846        # Verify the arrow.
847        unless (exists ARROW_FLIP->{$row->[8]}) {
848            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
849            $retVal++;
850        }
851        # Return the error count.
852        return $retVal;
853    }
854    
855    
856    =head2 Internal Utility Methods
857    
858    The methods in this section are used internally by this package.
859    
860    =head3 RunRequest
861    
862        ServerThing::RunRequest($cgi, $serverName);
863    
864    Run a request from the specified server using the incoming CGI parameter
865    object for the parameters.
866    
867    =over 4
868    
869    =item cgi
870    
871    CGI query object containing the parameters from the web service request.
872    
873    =item serverThing
874    
875    Server object against which to run the request.
876    
877    =back
878    
879    =cut
880    
881    sub RunRequest {
882        # Get the parameters.
883        my ($cgi, $serverThing, $docURL) = @_;
884        # Determine the request type.
885        if ($cgi->param('pod')) {
886            # Here we have a documentation request. In this case, we produce POD HTML.
887            ProducePod($cgi->param('pod'));
888        } elsif ($cgi->param('code')) {
889            # Here the user wants to see the code for one of our scripts.
890            LineNumberize($cgi->param('code'));
891        } elsif ($cgi->param('file')) {
892            # Here we have a file request. Process according to the type.
893            my $type = $cgi->param('file');
894            if ($type eq 'open') {
895                OpenFile($cgi->param('name'));
896            } elsif ($type eq 'create') {
897                CreateFile();
898            } elsif ($type eq 'read') {
899                ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
900            } elsif ($type eq 'write') {
901                WriteChunk($cgi->param('name'), $cgi->param('data'));
902            } else {
903                Die("Invalid file function \"$type\".");
904            }
905        } else {
906            # The default is a function request. Get the function name.
907            my $function = $cgi->param('function') || "";
908            Trace("Server function for task $$ is $function.") if T(3);
909            # Insure the function name is valid.
910            Die("Invalid function name.")
911                if $function =~ /\W/;
912            # The parameter structure will go in here.
913            my $args;
914            # Start the timer.
915            my $start = time();
916            # The output document goes in here.
917            my $document;
918            # The sapling database goes in here.
919            my $sapling;
920            # Protect from errors.
921            eval {
922                # Parse the arguments.
923                $args = YAML::Load($cgi->param('args'));
924            };
925            # Check to make sure we got everything.
926            if ($@) {
927                SendError($@, "Error formatting parameters.");
928            } elsif (! $function) {
929                SendError("No function specified.", "No function specified.");
930            } else {
931                $document = eval { $serverThing->$function($args) };
932                # If we have an error, create an error document.
933                if ($@) {
934                    SendError($@, "Error detected by service.");
935                    Trace("Error encountered by service: $@") if T(0);
936                } else {
937                    # No error, so we output the result.
938                    print $cgi->header(-type => 'text/plain');
939                    my $string = YAML::Dump($document);
940                    print $string;
941                    MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
942                }
943            }
944            # Stop the timer.
945            my $duration = int(time() - $start + 0.5);
946            Trace("Function $function executed in $duration seconds by task $$.") if T(2);
947        }
948    }
949    
950    =head3 CreateFile
951    
952        ServerThing::CreateFile();
953    
954    Create a new, empty temporary file and send its name back to the client.
955    
956    =cut
957    
958    sub CreateFile {
959        ##TODO: Code
960    }
961    
962    =head3 OpenFile
963    
964        ServerThing::OpenFile($name);
965    
966    Send the length of the named file back to the client.
967    
968    =over 4
969    
970    =item name
971    
972    ##TODO: name description
973    
974    =back
975    
976    =cut
977    
978    sub OpenFile {
979        # Get the parameters.
980        my ($name) = @_;
981        ##TODO: Code
982    }
983    
984    =head3 ReadChunk
985    
986        ServerThing::ReadChunk($name, $location, $size);
987    
988    Read the indicated number of bytes from the specified location of the
989    named file and send them back to the client.
990    
991    =over 4
992    
993    =item name
994    
995    ##TODO: name description
996    
997    =item location
998    
999    ##TODO: location description
1000    
1001    =item size
1002    
1003    ##TODO: size description
1004    
1005    =back
1006    
1007    =cut
1008    
1009    sub ReadChunk {
1010        # Get the parameters.
1011        my ($name, $location, $size) = @_;
1012        ##TODO: Code
1013    }
1014    
1015    =head3 WriteChunk
1016    
1017        ServerThing::WriteChunk($name, $data);
1018    
1019    Write the specified data to the named file.
1020    
1021    =over 4
1022    
1023    =item name
1024    
1025    ##TODO: name description
1026    
1027    =item data
1028    
1029    ##TODO: data description
1030    
1031    =back
1032    
1033    =cut
1034    
1035    sub WriteChunk {
1036        # Get the parameters.
1037        my ($name, $data) = @_;
1038        ##TODO: Code
1039    }
1040    
1041    
1042    =head3 LineNumberize
1043    
1044        ServerThing::LineNumberize($module);
1045    
1046    Output the module line by line with line numbers
1047    
1048    =over 4
1049    
1050    =item module
1051    
1052    Name of the module to line numberized
1053    
1054    =back
1055    
1056    =cut
1057    
1058    sub LineNumberize {
1059        # Get the parameters.
1060        my ($module) = @_;
1061        my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
1062        # Start the output page.
1063        print CGI::header();
1064        print CGI::start_html(-title => 'Documentation Page',
1065                              -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1066        # Protect from errors.
1067        eval {
1068            if (-e $fks_path) {
1069                print "<pre>\n";
1070                my $i = 1;
1071                foreach my $line (`cat $fks_path`) {
1072                    print "$i.\t$line";
1073                    $i++;
1074                }
1075                print "</pre>\n";
1076            } else {
1077                print "File $fks_path not found";
1078            }
1079        };
1080        # Process any error.
1081        if ($@) {
1082            print CGI::blockquote({ class => 'error' }, $@);
1083        }
1084        # Close off the page.
1085        print CGI::end_html();
1086    
1087    }
1088    
1089    =head3 ProducePod
1090    
1091        ServerThing::ProducePod($module);
1092    
1093    Output the POD documentation for the specified module.
1094    
1095    =over 4
1096    
1097    =item module
1098    
1099    Name of the module whose POD document is to be displayed.
1100    
1101    =back
1102    
1103    =cut
1104    
1105    sub ProducePod {
1106        # Get the parameters.
1107        my ($module) = @_;
1108        # Start the output page.
1109        print CGI::header();
1110        print CGI::start_html(-title => "$module Documentation Page",
1111                              -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1112        # Protect from errors.
1113        eval {
1114            # We'll format the HTML text in here.
1115            require DocUtils;
1116            my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
1117            # Output the POD HTML.
1118            print $html;
1119        };
1120        # Process any error.
1121        if ($@) {
1122            print CGI::blockquote({ class => 'error' }, $@);
1123        }
1124        # Close off the page.
1125        print CGI::end_html();
1126    
1127    }
1128    
1129    =head3 TraceErrorLog
1130    
1131        ServerThing::TraceErrorLog($name, $errorLog);
1132    
1133    Trace the specified error log file. This is a very dinky routine that
1134    performs a task required by L</RunTool> in multiple places.
1135    
1136    =over 4
1137    
1138    =item name
1139    
1140    Name of the tool relevant to the log file.
1141    
1142    =item errorLog
1143    
1144    Name of the log file.
1145    
1146    =back
1147    
1148    =cut
1149    
1150    sub TraceErrorLog {
1151        my ($name, $errorLog) = @_;
1152        my $errorData = Tracer::GetFile($errorLog);
1153        Trace("$name error log:\n$errorData");
1154    }
1155    
1156    =head3 SendError
1157    
1158        ServerThing::SendError($message, $status);
1159    
1160    Fail an HTTP request with the specified error message and the specified
1161    status message.
1162    
1163    =over 4
1164    
1165    =item message
1166    
1167    Detailed error message. This is sent as the page content.
1168    
1169    =item status
1170    
1171    Status message. This is sent as part of the status code.
1172    
1173    =back
1174    
1175    =cut
1176    
1177    sub SendError {
1178        # Get the parameters.
1179        my ($message, $status) = @_;
1180        Trace("Error \"$status\" $message") if T(2);
1181        # Check for a DBserver error. These can be retried and get a special status
1182        # code.
1183        my $realStatus;
1184        if ($message =~ /DBServer Error:\s+/) {
1185            $realStatus = "503 $status";
1186        } else {
1187            $realStatus = "500 $status";
1188        }
1189        # Print the header and the status message.
1190        print CGI::header(-type => 'text/plain',
1191                          -status => $realStatus);
1192        # Print the detailed message.
1193        print $message;
1194    }
1195    
1196    
1197  1;  1;

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.47

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3