[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.29, Thu Dec 10 19:12:21 2009 UTC revision 1.56, Thu Oct 14 17:28:49 2010 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 => 5000;      use constant MAX_REQUESTS => 50;
19    
20  =head1 General Server Helper  =head1 General Server Helper
21    
# Line 33  Line 34 
34      # Set up tracing. We never do CGI tracing here; the only question is whether      # 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      # or not the caller passed in a tracing key. If he didn't, we use the server
36      # name.      # name.
37      ETracing($key || $serverName);      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.
# Line 97  Line 98 
98    
99  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
100    
101      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
102    
103  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
104  based on data in the argument hash. The argument hash will be checked for  based on data in the argument hash. The argument hash will be checked for
105  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
106  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
107  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
108    
109  =over 4  =over 4
110    
# Line 117  Line 118 
118  Reference to the parameter hash for the current server call. This hash will  Reference to the parameter hash for the current server call. This hash will
119  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
120    
121    =item roles
122    
123    If TRUE, role filtering will be applied. In this case, the default action
124    is to exclude auxiliary roles unless C<-aux> is TRUE.
125    
126  =back  =back
127    
128  =cut  =cut
# Line 127  Line 133 
133    
134  sub AddSubsystemFilter {  sub AddSubsystemFilter {
135      # Get the parameters.      # Get the parameters.
136      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
137      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
138      my @newFilters;      my @newFilters;
139      # Unless unusable subsystems are desired, we must add a clause to the filter.      # Unless unusable subsystems are desired, we must add a clause to the filter.
# Line 151  Line 157 
157              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
158          }          }
159      }      }
160        # Check for role filtering.
161        if ($roles) {
162            # Here, we filter out auxiliary roles unless the user requests
163            # them.
164            if (! $args->{-aux}) {
165                push @newFilters, "Includes(auxiliary) = 0"
166            }
167        }
168      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
169      if (@newFilters) {      if (@newFilters) {
170          # Yes. If the incoming filter is nonempty, push it onto the list          # Yes. If the incoming filter is nonempty, push it onto the list
# Line 199  Line 213 
213  sub GetIdList {  sub GetIdList {
214      # Get the parameters.      # Get the parameters.
215      my ($name, $args, $optional) = @_;      my ($name, $args, $optional) = @_;
216      # Try to get the IDs from the argument structure.      # Declare the return variable.
217      my $retVal = $args->{$name};      my $retVal;
218        # Check the argument format.
219        if (! defined $args && $optional) {
220            # Here there are no parameters, but the arguments are optional so it's
221            # okay.
222            $retVal = [];
223        } elsif (ref $args ne 'HASH') {
224            # Here we have an invalid parameter structure.
225            Confess("No '$name' parameter present.");
226        } else {
227            # Here we have a hash with potential parameters in it. Try to get the
228            # IDs from the argument structure.
229            $retVal = $args->{$name};
230      # Was a member found?      # Was a member found?
231      if (! defined $retVal) {      if (! defined $retVal) {
232          # No. If we're optional, return an empty list; otherwise throw an error.          # No. If we're optional, return an empty list; otherwise throw an error.
# Line 210  Line 236 
236              Confess("No '$name' parameter found.");              Confess("No '$name' parameter found.");
237          }          }
238      } else {      } else {
239          # Here we found something. Get the parameter type. We was a list reference.              # Here we found something. Get the parameter type. We want a list reference.
240          # If it's a scalar, we'll convert it to a singleton list. If it's anything          # If it's a scalar, we'll convert it to a singleton list. If it's anything
241          # else, it's an error.          # else, it's an error.
242          my $type = ref $retVal;          my $type = ref $retVal;
# Line 220  Line 246 
246              Confess("The '$name' parameter must be a list.");              Confess("The '$name' parameter must be a list.");
247          }          }
248      }      }
249        }
250      # Return the result.      # Return the result.
251      return $retVal;      return $retVal;
252  }  }
# Line 278  Line 305 
305      }      }
306  }  }
307    
308    =head3 ReadCountVector
309    
310        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
311    
312    Extract a count vector from a query. The query can contain zero or more results,
313    and the vectors in the specified result field of the query must be concatenated
314    together in order. This method is optimized for the case (expected to be most
315    common) where there is only one result.
316    
317    =over 4
318    
319    =item qh
320    
321    Handle for the query from which results are to be extracted.
322    
323    =item field
324    
325    Name of the field containing the count vectors.
326    
327    =item rawFlag
328    
329    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
330    as reference to a list of numbers.
331    
332    =item RETURN
333    
334    Returns the desired vector, either encoded as a string or as a reference to a list
335    of numbers.
336    
337    =back
338    
339    =cut
340    
341    sub ReadCountVector {
342        # Get the parameters.
343        my ($qh, $field, $rawFlag) = @_;
344        # Declare the return variable.
345        my $retVal;
346        # Loop through the query results.
347        while (my $resultRow = $qh->Fetch()) {
348            # Get this vector.
349            my ($levelVector) = $resultRow->Value($field, $rawFlag);
350            # Is this the first result?
351            if (! defined $retVal) {
352                # Yes. Assign the result directly.
353                $retVal = $levelVector;
354            } elsif ($rawFlag) {
355                # This is a second result and the vectors are coded as strings.
356                $retVal .= $levelVector;
357            } else {
358                # This is a second result and the vectors are coded as array references.
359                push @$retVal, @$levelVector;
360            }
361        }
362        # Return the result.
363        return $retVal;
364    }
365    
366    
367    =head2 Gene Correspondence File Methods
368    
369    These methods relate to gene correspondence files, which are generated by the
370    L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
371    organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
372    copied into the organism directories themselves. At that point, the code below
373    will be modified to check the organism directories first and use the cache
374    directory if no file is found there.
375    
376    A gene correspondence file contains correspondences from a source genome to a
377    target genome. Most such correspondences are bidirectional best hits. A unidirectional
378    best hit may exist from the source genome to the target genome or in the reverse
379    direction from the targtet genome to the source genome. The cache directory itself
380    is divided into subdirectories by organism. The subdirectory has the source genome
381    name and the files themselves are named by the target genome.
382    
383    Some of the files are invalid and will be erased when they are found. A file is
384    considered invalid if it has a non-numeric value in a numeric column or if it
385    does not have any unidirectional hits from the target genome to the source
386    genome.
387    
388    The process of managing the correspondence files is tricky and dangerous because
389    of the possibility of race conditions. It can take several minutes to generate a
390    file, and if two processes try to generate the same file at the same time we need
391    to make sure they don't step on each other.
392    
393    In stored files, the source genome ID is always lexically lower than the target
394    genome ID. If a correspondence in the reverse direction is desired, the converse
395    file is found and the contents flipped automatically as they are read. So, the
396    correspondence from B<360108.3> to B<100226.1> would be found in a file with the
397    name B<360108.3> in the directory for B<100226.1>. Since this file actually has
398    B<100226.1> as the source and B<360108.3> as the target, the columns are
399    re-ordered and the arrows reversed before the file contents are passed to the
400    caller.
401    
402    =head4 Gene Correspondence List
403    
404    A gene correspondence file contains 18 columns. These are usually packaged as
405    a reference to list of lists. Each sub-list has the following format.
406    
407    =over 4
408    
409    =item 0
410    
411    The ID of a PEG in genome 1.
412    
413    =item 1
414    
415    The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".
416    
417    =item 2
418    
419    Count of the number of pairs of matching genes were found in the context.
420    
421    =item 3
422    
423    Pairs of corresponding genes from the contexts.
424    
425    =item 4
426    
427    The function of the gene in genome 1.
428    
429    =item 5
430    
431    The function of the gene in genome 2.
432    
433    =item 6
434    
435    Comma-separated list of aliases for the gene in genome 1 (any protein with an
436    identical sequence is considered an alias, whether or not it is actually the
437    name of the same gene in the same genome).
438    
439    =item 7
440    
441    Comma-separated list of aliases for the gene in genome 2 (any protein with an
442    identical sequence is considered an alias, whether or not it is actually the
443    name of the same gene in the same genome).
444    
445    =item 8
446    
447    Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.
448    
449    =item 9
450    
451    Percent identity over the region of the detected match.
452    
453    =item 10
454    
455    The P-score for the detected match.
456    
457    =item 11
458    
459    Beginning match coordinate in the protein encoded by the gene in genome 1.
460    
461    =item 12
462    
463    Ending match coordinate in the protein encoded by the gene in genome 1.
464    
465    =item 13
466    
467    Length of the protein encoded by the gene in genome 1.
468    
469    =item 14
470    
471    Beginning match coordinate in the protein encoded by the gene in genome 2.
472    
473    =item 15
474    
475    Ending match coordinate in the protein encoded by the gene in genome 2.
476    
477    =item 16
478    
479    Length of the protein encoded by the gene in genome 2.
480    
481    =item 17
482    
483    Bit score for the match. Divide by the length of the longer PEG to get
484    what we often refer to as a "normalized bit score".
485    
486    =back
487    
488    In the actual files, there will also be reverse correspondences indicated by a
489    back-arrow ("<-") in item (8). The output returned by the servers, however,
490    is filtered so that only forward correspondences occur. If a converse file
491    is used, the columns are re-ordered and the arrows reversed so that it looks
492    correct.
493    
494    =cut
495    
496    # hash for reversing the arrows
497    use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
498    # list of columns that contain numeric values that need to be validated
499    use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];
500    
501    =head3 CheckForGeneCorrespondenceFile
502    
503        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
504    
505    Try to find a gene correspondence file for the specified genome pairing. If the
506    file exists, its name and an indication of whether or not it is in the correct
507    direction will be returned.
508    
509    =over 4
510    
511    =item genome1
512    
513    Source genome for the desired correspondence.
514    
515    =item genome2
516    
517    Target genome for the desired correspondence.
518    
519    =item RETURN
520    
521    Returns a two-element list. The first element is the name of the file containing the
522    correspondence, or C<undef> if the file does not exist. The second element is TRUE
523    if the correspondence would be forward or FALSE if the file needs to be flipped.
524    
525    =back
526    
527    =cut
528    
529    sub CheckForGeneCorrespondenceFile {
530        # Get the parameters.
531        my ($genome1, $genome2) = @_;
532        # Declare the return variables.
533        my ($fileName, $converse);
534        # Determine the ordering of the genome IDs.
535        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
536        $converse = ($genomeA ne $genome1);
537        # Look for a file containing the desired correspondence. (The code to check for a
538        # pre-computed file in the organism directories is currently turned off, because
539        # these files are all currently invalid.)
540        my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
541        if (0 && -f $testFileName) {
542            # Use the pre-computed file.
543            Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
544            $fileName = $testFileName;
545        } elsif (-f $corrFileName) {
546            $fileName = $corrFileName;
547            Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
548        }
549        # Return the result.
550        return ($fileName, $converse);
551    }
552    
553    
554    =head3 ComputeCorrespondenceFileName
555    
556        my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);
557    
558    Compute the name to be given to a genome correspondence file in the organism cache
559    and return the source and target genomes that would be in it.
560    
561    =over 4
562    
563    =item genome1
564    
565    Source genome for the desired correspondence.
566    
567    =item genome2
568    
569    Target genome for the desired correspondence.
570    
571    =item RETURN
572    
573    Returns a three-element list. The first element is the name of the file to contain the
574    correspondence, the second element is the name of the genome that would act as the
575    source genome in the file, and the third element is the name of the genome that would
576    act as the target genome in the file.
577    
578    =back
579    
580    =cut
581    
582    sub ComputeCorrespondenceFileName {
583        # Get the parameters.
584        my ($genome1, $genome2) = @_;
585        # Declare the return variables.
586        my ($fileName, $genomeA, $genomeB);
587        # Determine the ordering of the genome IDs.
588        if (MustFlipGenomeIDs($genome1, $genome2)) {
589            ($genomeA, $genomeB) = ($genome2, $genome1);
590        } else {
591            ($genomeA, $genomeB) = ($genome1, $genome2);
592        }
593        # Insure the source organism has a subdirectory in the organism cache.
594        my $orgDir = ComputeCorrespondenceDirectory($genomeA);
595        # Compute the name of the correspondence file for the appropriate target genome.
596        $fileName = "$orgDir/$genomeB";
597        # Return the results.
598        return ($fileName, $genomeA, $genomeB);
599    }
600    
601    
602    =head3 ComputeCorresopndenceDirectory
603    
604        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
605    
606    Return the name of the directory that would contain the correspondence files
607    for the specified genome.
608    
609    =over 4
610    
611    =item genome
612    
613    ID of the genome whose correspondence file directory is desired.
614    
615    =item RETURN
616    
617    Returns the name of the directory of interest.
618    
619    =back
620    
621    =cut
622    
623    sub ComputeCorrespondenceDirectory {
624        # Get the parameters.
625        my ($genome) = @_;
626        # Insure the source organism has a subdirectory in the organism cache.
627        my $retVal = "$FIG_Config::orgCache/$genome";
628        Tracer::Insure($retVal, 0777);
629        # Return it.
630        return $retVal;
631    }
632    
633    
634    =head3 CreateGeneCorrespondenceFile
635    
636        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
637    
638    Create a new gene correspondence file in the organism cache for the specified
639    genome correspondence. The name of the new file will be returned along with
640    an indicator of whether or not it is in the correct direction.
641    
642    =over 4
643    
644    =item genome1
645    
646    Source genome for the desired correspondence.
647    
648    =item genome2
649    
650    Target genome for the desired correspondence.
651    
652    =item RETURN
653    
654    Returns a two-element list. The first element is the name of the file containing the
655    correspondence, or C<undef> if an error occurred. The second element is TRUE
656    if the correspondence would be forward or FALSE if the file needs to be flipped.
657    
658    =back
659    
660    =cut
661    
662    sub CreateGeneCorrespondenceFile {
663        # Get the parameters.
664        my ($genome1, $genome2) = @_;
665        # Declare the return variables.
666        my ($fileName, $converse);
667        # Compute the ultimate name for the correspondence file.
668        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
669        $converse = ($genome1 ne $genomeA);
670        # Generate a temporary file name in the same directory. We'll build the temporary
671        # file and then rename it when we're done.
672        my $tempFileName = "$corrFileName.$$.tmp";
673        # This will be set to FALSE if we detect an error.
674        my $fileOK = 1;
675        # The file handles will be put in here.
676        my ($ih, $oh);
677        # Protect from errors.
678        eval {
679            # Open the temporary file for output.
680            $oh = Open(undef, ">$tempFileName");
681            # Open a pipe to get the correspondence data.
682            $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
683            Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
684            # Copy the pipe date into the temporary file.
685            while (! eof $ih) {
686                my $line = <$ih>;
687                print $oh $line;
688            }
689            # Close both files. If the close fails we need to know: it means there was a pipe
690            # error.
691            $fileOK &&= close $ih;
692            $fileOK &&= close $oh;
693        };
694        if ($@) {
695            # Here a fatal error of some sort occurred. We need to force the files closed.
696            close $ih if $ih;
697            close $oh if $oh;
698        } elsif ($fileOK) {
699            # Here everything worked. Try to rename the temporary file to the real
700            # file name.
701            if (rename $tempFileName, $corrFileName) {
702                # Everything is ok, fix the permissions and return the file name.
703                chmod 0664, $corrFileName;
704                $fileName = $corrFileName;
705                Trace("Created correspondence file $fileName.") if T(Corr => 3);
706            }
707        }
708        # If the temporary file exists, delete it.
709        if (-f $tempFileName) {
710            unlink $tempFileName;
711        }
712        # Return the results.
713        return ($fileName, $converse);
714    }
715    
716    
717    =head3 MustFlipGenomeIDs
718    
719        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
720    
721    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
722    order, they are stored in the converse order in correspondence files on the server.
723    This is a simple method that allows the caller to check for the need to flip.
724    
725    =over 4
726    
727    =item genome1
728    
729    ID of the proposed source genome.
730    
731    =item genome2
732    
733    ID of the proposed target genome.
734    
735    =item RETURN
736    
737    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
738    it would be stored as a source.
739    
740    =back
741    
742    =cut
743    
744    sub MustFlipGenomeIDs {
745        # Get the parameters.
746        my ($genome1, $genome2) = @_;
747        # Return an indication.
748        return ($genome1 gt $genome2);
749    }
750    
751    
752    =head3 ReadGeneCorrespondenceFile
753    
754        my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
755    
756    Return the contents of the specified gene correspondence file in the form of
757    a list of lists, with backward correspondences filtered out. If the file is
758    for the converse of the desired correspondence, the columns will be reordered
759    automatically so that it looks as if the file were designed for the proper
760    direction.
761    
762    =over 4
763    
764    =item fileName
765    
766    The name of the gene correspondence file to read.
767    
768    =item converse (optional)
769    
770    TRUE if the file is for the converse of the desired correspondence, else FALSE.
771    If TRUE, the file columns will be reorderd automatically. The default is FALSE,
772    meaning we want to use the file as it appears on disk.
773    
774    =item all (optional)
775    
776    TRUE if backward unidirectional correspondences should be included in the output.
777    The default is FALSE, in which case only forward and bidirectional correspondences
778    are included.
779    
780    =item RETURN
781    
782    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
783    If the file's contents are invalid or an error occurs, an undefined value will be
784    returned.
785    
786    =back
787    
788    =cut
789    
790    sub ReadGeneCorrespondenceFile {
791        # Get the parameters.
792        my ($fileName, $converse, $all) = @_;
793        # Declare the return variable. We will only put something in here if we are
794        # completely successful.
795        my $retVal;
796        # This value will be set to 1 if an error is detected.
797        my $error = 0;
798        # Try to open the file.
799        my $ih;
800        Trace("Reading correspondence file $fileName.") if T(3);
801        if (! open $ih, "<$fileName") {
802            # Here the open failed, so we have an error.
803            Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
804            $error = 1;
805        }
806        # The gene correspondence list will be built in here.
807        my @corrList;
808        # This variable will be set to TRUE if we find a reverse correspondence somewhere
809        # in the file. Not finding one is an error.
810        my $reverseFound = 0;
811        # Loop until we hit the end of the file or an error occurs. We must check the error
812        # first in case the file handle failed to open.
813        while (! $error && ! eof $ih) {
814            # Get the current line.
815            my @row = Tracer::GetLine($ih);
816            # Get the correspondence direction and check for a reverse arrow.
817            $reverseFound = 1 if ($row[8] eq '<-');
818            # If we're in converse mode, reformat the line.
819            if ($converse) {
820                ReverseGeneCorrespondenceRow(\@row);
821            }
822            # Validate the row.
823            if (ValidateGeneCorrespondenceRow(\@row)) {
824                Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
825                $error = 1;
826            }
827            # If this row is in the correct direction, keep it.
828            if ($all || $row[8] ne '<-') {
829                push @corrList, \@row;
830            }
831        }
832        # Close the input file.
833        close $ih;
834        # If we have no errors and we found a reverse arrow, keep the result.
835        if (! $error) {
836            if ($reverseFound) {
837                $retVal = \@corrList;
838            } else {
839                Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);
840            }
841        }
842        # Return the result (if any).
843        return $retVal;
844    }
845    
846    =head3 ReverseGeneCorrespondenceRow
847    
848        ServerThing::ReverseGeneCorrespondenceRow($row)
849    
850    Convert a gene correspondence row to represent the converse correspondence. The
851    elements in the row will be reordered to represent a correspondence from the
852    target genome to the source genome.
853    
854    =over 4
855    
856    =item row
857    
858    Reference to a list containing a single row from a L</Gene Correspondence List>.
859    
860    =back
861    
862    =cut
863    
864    sub ReverseGeneCorrespondenceRow {
865        # Get the parameters.
866        my ($row) = @_;
867        # Flip the row in place.
868        ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
869         $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
870         $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
871        # Flip the arrow.
872        $row->[8] = ARROW_FLIP->{$row->[8]};
873        # Flip the pairs.
874        my @elements = split /,/, $row->[3];
875        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
876    }
877    
878    =head3 ValidateGeneCorrespondenceRow
879    
880        my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);
881    
882    Validate a gene correspondence row. The numeric fields are checked to insure they
883    are numeric and the source and target gene IDs are validated. The return value will
884    indicate the number of errors found.
885    
886    =over 4
887    
888    =item row
889    
890    Reference to a list containing a single row from a L</Gene Correspondence List>.
891    
892    =item RETURN
893    
894    Returns the number of errors found in the row. A return of C<0> indicates the row
895    is valid.
896    
897    =back
898    
899    =cut
900    
901    sub ValidateGeneCorrespondenceRow {
902        # Get the parameters.
903        my ($row, $genome1, $genome2) = @_;
904        # Denote no errors have been found so far.
905        my $retVal = 0;
906        # Check for non-numeric values in the number columns.
907        for my $col (@{NUM_COLS()}) {
908            unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
909                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
910                $retVal++;
911            }
912        }
913        # Check the gene IDs.
914        for my $col (0, 1) {
915            unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
916                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
917                $retVal++;
918            }
919        }
920        # Verify the arrow.
921        unless (exists ARROW_FLIP->{$row->[8]}) {
922            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
923            $retVal++;
924        }
925        # Return the error count.
926        return $retVal;
927    }
928    
929    =head3 GetCorrespondenceData
930    
931        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
932    
933    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
934    list is in a file, it will be read. If the file does not exist, it may be created.
935    
936    =over 4
937    
938    =item genome1
939    
940    ID of the source genome.
941    
942    =item genome2
943    
944    ID of the target genome.
945    
946    =item passive
947    
948    If TRUE, then the correspondence file will not be created if it does not exist.
949    
950    =item full
951    
952    If TRUE, then both directions of the correspondence will be represented; otherwise, only
953    correspondences from the source to the target (including bidirectional corresopndences)
954    will be included.
955    
956    =item RETURN
957    
958    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
959    undefined value if an error occurs or no file exists and passive mode was specified.
960    
961    =back
962    
963    =cut
964    
965    sub GetCorrespondenceData {
966        # Get the parameters.
967        my ($genome1, $genome2, $passive, $full) = @_;
968        # Declare the return variable.
969        my $retVal;
970        # Check for a gene correspondence file.
971        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
972        if ($fileName) {
973            # Here we found one, so read it in.
974            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
975        }
976        # Were we successful?
977        if (! defined $retVal) {
978            # Here we either don't have a correspondence file, or the one that's there is
979            # invalid. If we are NOT in passive mode, then this means we need to create
980            # the file.
981            if (! $passive) {
982                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
983                # Now try reading the new file.
984                if (defined $fileName) {
985                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
986                }
987            }
988        }
989        # Return the result.
990        return $retVal;
991    
992    }
993    
994    
995  =head2 Internal Utility Methods  =head2 Internal Utility Methods
996    
# Line 294  Line 1007 
1007    
1008  =item cgi  =item cgi
1009    
1010  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
1011    significant parameters are as follows.
1012    
1013    =over 8
1014    
1015    =item function
1016    
1017    Name of the function to run.
1018    
1019    =item args
1020    
1021    Parameters for the function.
1022    
1023    =item encoding
1024    
1025    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1026    by the Java interface).
1027    
1028    =back
1029    
1030    Certain unusual requests can come in outside of the standard function interface.
1031    These are indicated by special parameters that override all the others.
1032    
1033    =over 8
1034    
1035    =item pod
1036    
1037    Display a POD documentation module.
1038    
1039    =item code
1040    
1041    Display an example code file.
1042    
1043    =item file
1044    
1045    Transfer a file (not implemented).
1046    
1047    =back
1048    
1049  =item serverThing  =item serverThing
1050    
# Line 308  Line 1058 
1058      # Get the parameters.      # Get the parameters.
1059      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1060      # Determine the request type.      # Determine the request type.
1061      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1062          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1063            # Here we have a documentation request.
1064            if ($module eq 'ServerScripts') {
1065                # Here we list the server scripts.
1066                require ListServerScripts;
1067                ListServerScripts::main();
1068            } else {
1069                # In this case, we produce POD HTML.
1070          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1071            }
1072        } elsif ($cgi->param('code')) {
1073            # Here the user wants to see the code for one of our scripts.
1074            LineNumberize($cgi->param('code'));
1075      } elsif ($cgi->param('file')) {      } elsif ($cgi->param('file')) {
1076          # Here we have a file request. Process according to the type.          # Here we have a file request. Process according to the type.
1077          my $type = $cgi->param('file');          my $type = $cgi->param('file');
# Line 332  Line 1093 
1093          # Insure the function name is valid.          # Insure the function name is valid.
1094          Die("Invalid function name.")          Die("Invalid function name.")
1095              if $function =~ /\W/;              if $function =~ /\W/;
1096            # Determing the encoding scheme. The default is YAML.
1097            my $encoding = $cgi->param('encoding') || 'yaml';
1098          # The parameter structure will go in here.          # The parameter structure will go in here.
1099          my $args;          my $args = {};
1100          # Start the timer.          # Start the timer.
1101          my $start = time();          my $start = time();
1102          # The output document goes in here.          # The output document goes in here.
# Line 342  Line 1105 
1105          my $sapling;          my $sapling;
1106          # Protect from errors.          # Protect from errors.
1107          eval {          eval {
1108              # Parse the arguments.              # Here we parse the arguments. This is affected by the encoding parameter.
1109              $args = YAML::Load($cgi->param('args'));              # Get the argument string.
1110                my $argString = $cgi->param('args');
1111                # Only proceed if we found one.
1112                if ($argString) {
1113                    if ($encoding eq 'yaml') {
1114                        # Parse the arguments using YAML.
1115                        $args = YAML::Load($argString);
1116                    } elsif ($encoding eq 'json') {
1117                        # Parse the arguments using JSON.
1118                        Trace("Incoming string is:\n$argString") if T(3);
1119                        $args = JSON::Any->jsonToObj($argString);
1120                    } else {
1121                        Die("Invalid encoding type $encoding.");
1122                    }
1123                }
1124          };          };
1125          # Check to make sure we got everything.          # Check to make sure we got everything.
1126          if ($@) {          if ($@) {
# Line 351  Line 1128 
1128          } elsif (! $function) {          } elsif (! $function) {
1129              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1130          } else {          } else {
1131              $document = eval("\$serverThing->$function(\$args)");              $document = eval { $serverThing->$function($args) };
1132              # If we have an error, create an error document.              # If we have an error, create an error document.
1133              if ($@) {              if ($@) {
1134                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1135                  Trace("Error encountered by service: $@") if T(2);                  Trace("Error encountered by service: $@") if T(0);
1136              } else {              } else {
1137                  # No error, so we output the result.                  # No error, so we output the result. Start with an HTML header.
1138                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1139                  my $string = YAML::Dump($document);                  # The nature of the output depends on the encoding type.
1140                    my $string;
1141                    if ($encoding eq 'yaml') {
1142                        $string = YAML::Dump($document);
1143                    } else {
1144                        $string = JSON::Any->objToJson($document);
1145                    }
1146                  print $string;                  print $string;
1147                  MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);                  MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
1148              }              }
# Line 462  Line 1245 
1245  }  }
1246    
1247    
1248    =head3 LineNumberize
1249    
1250        ServerThing::LineNumberize($module);
1251    
1252    Output the module line by line with line numbers
1253    
1254    =over 4
1255    
1256    =item module
1257    
1258    Name of the module to line numberized
1259    
1260    =back
1261    
1262    =cut
1263    
1264    sub LineNumberize {
1265        # Get the parameters.
1266        my ($module) = @_;
1267        my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
1268        # Start the output page.
1269        print CGI::header();
1270        print CGI::start_html(-title => 'Documentation Page',
1271                              -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1272        # Protect from errors.
1273        eval {
1274            if (-e $fks_path) {
1275                print "<pre>\n";
1276                my $i = 1;
1277                foreach my $line (`cat $fks_path`) {
1278                    print "$i.\t$line";
1279                    $i++;
1280                }
1281                print "</pre>\n";
1282            } else {
1283                print "File $fks_path not found";
1284            }
1285        };
1286        # Process any error.
1287        if ($@) {
1288            print CGI::blockquote({ class => 'error' }, $@);
1289        }
1290        # Close off the page.
1291        print CGI::end_html();
1292    
1293    }
1294    
1295  =head3 ProducePod  =head3 ProducePod
1296    
1297      ServerThing::ProducePod($module);      ServerThing::ProducePod($module);
# Line 483  Line 1313 
1313      my ($module) = @_;      my ($module) = @_;
1314      # Start the output page.      # Start the output page.
1315      print CGI::header();      print CGI::header();
1316      print CGI::start_html(-title => 'Documentation Page',      print CGI::start_html(-title => "$module Documentation Page",
1317                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1318      # Protect from errors.      # Protect from errors.
1319      eval {      eval {
# Line 554  Line 1384 
1384      # Get the parameters.      # Get the parameters.
1385      my ($message, $status) = @_;      my ($message, $status) = @_;
1386      Trace("Error \"$status\" $message") if T(2);      Trace("Error \"$status\" $message") if T(2);
1387        # Check for a DBserver error. These can be retried and get a special status
1388        # code.
1389        my $realStatus;
1390        if ($message =~ /DBServer Error:\s+/) {
1391            $realStatus = "503 $status";
1392        } else {
1393            $realStatus = "500 $status";
1394        }
1395      # Print the header and the status message.      # Print the header and the status message.
1396      print CGI::header(-type => 'text/plain',      print CGI::header(-type => 'text/plain',
1397                        -status => "500 $status");                        -status => $realStatus);
1398      # Print the detailed message.      # Print the detailed message.
1399      print $message;      print $message;
1400  }  }

Legend:
Removed from v.1.29  
changed lines
  Added in v.1.56

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3