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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3