[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.36, Thu Feb 25 20:30:10 2010 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 => 5000;      use constant MAX_REQUESTS => 50;
19    
20  =head1 General Server Helper  =head1 General Server Helper
21    
# Line 39  Line 40 
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 52  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.
# Line 97  Line 104 
104    
105  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
106    
107      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
108    
109  Add subsystem filtering information to the specified query filter clause  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  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, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
112  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
113  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
114    
115  =over 4  =over 4
116    
# Line 117  Line 124 
124  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
125  be examined for the C<-usable> and C<-exclude> parameters.  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  =back
133    
134  =cut  =cut
# Line 127  Line 139 
139    
140  sub AddSubsystemFilter {  sub AddSubsystemFilter {
141      # Get the parameters.      # Get the parameters.
142      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
143      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
144      my @newFilters;      my @newFilters;
145      # 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 163 
163              push @newFilters, "Subsystem($exclusion) = 0";              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?      # Do we need to update the incoming filter?
175      if (@newFilters) {      if (@newFilters) {
176          # 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 291  Line 311 
311      }      }
312  }  }
313    
314  =head3 FindGeneCorrespondenceFile  =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      my $ih = ServerThing::FindGeneCorrespondenceFile($genome1, $genome2);  =head3 MustFlipGenomeIDs
759    
760  Return an open input handle for a file that maps the genes in the first genome      my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
761  to corresponding genes in the second genome. These files can be found for some  
762  genomes in the organism directories. Additional files are available in the  Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
763  organism cache directory (I<$FIG_Config::orgCache>). If the desired file does  order, they are stored in the converse order in correspondence files on the server.
764  not exist, one will be created in the organism cache directory, presumably to be  This is a simple method that allows the caller to check for the need to flip.
765  moved to a permanent location at a later time.  
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  =over 4
974    
# Line 312  Line 980 
980    
981  ID of the target genome.  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  =item RETURN
994    
995  Returns the name of a tab-delimited file. The first column in the file contains IDs  Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
996  of genes in the source genome; the second column contains IDs of genes in the  undefined value if an error occurs or no file exists and passive mode was specified.
 target genone. The remaining columns contain additional data about the correspondence.  
997    
998  =back  =back
999    
1000  =cut  =cut
1001    
1002  sub FindGeneCorrespondenceFile {  sub GetCorrespondenceData {
1003      # Get the parameters.      # Get the parameters.
1004      my ($genome1, $genome2) = @_;      my ($genome1, $genome2, $passive, $full) = @_;
1005      # Declare the return variable.      # Declare the return variable.
1006      my $retVal;      my $retVal;
1007      # Look for a pre-computed file in the organism directories.      # Check for a gene correspondence file.
1008      my $fileName = "$FIG_Config::organisms/$genome1/CorrToReferenceGenomes/$genome2";      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1009      if (-f $fileName) {      if ($fileName) {
1010          # Use the pre-computed file.          # Here we found one, so read it in.
1011          Trace("Using pre-computed file $fileName for genome correspondence.") if T(3);          $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
         $retVal = Open(undef, "<$fileName");  
     } else {  
         # Check for an organism cache.  
         if (! $FIG_Config::orgCache) {  
             # No cache, so simply open a pipe.  
             Trace("No organism cache found: using pipe to compute $genome1 vs. $genome2.") if T(3);  
             $retVal = Open(undef, "$FIG_Config::bin/svr_corresponding_genes $genome1 $genome2 |");  
         } else {  
             # Insure the source organism has a subdirectory in the cache.  
             my $orgDir = "$FIG_Config::orgCache/$genome1";  
             Tracer::Insure($orgDir, 0777);  
             # Check for a correspondence file that matches the target genome.  
             $fileName = "$orgDir/$genome2";  
             if (-f $fileName) {  
                 # We found one, so try to open it.  
                 my $ok = open $retVal, "<$fileName";  
                 # If the open failed, then the file is being built by another process, so  
                 # use a pipe.  
                 if (! $ok) {  
                     Trace("Failed to open $fileName. Using pipe to compute correspondence.") if T(3);  
                     $retVal = Open(undef, "$FIG_Config::bin/svr_corresponding_genes $genome1 $genome2 |");  
                 } else {  
                     Trace("Using cached file $fileName for genome correspondence.") if T(3);  
                 }  
             } else {  
                 # Here we need to create the file.  
                 Trace("Creating genome correspondence file $fileName.") if T(3);  
                 system "svr_corresponding_genes $genome1 $genome2 >$fileName";  
                 Trace("Using created file for genome correspondence.") if T(3);  
                 $retVal = Open(undef, "<$fileName");  
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      # Return the desired file handle.      }
1026        # Return the result.
1027      return $retVal;      return $retVal;
1028    
1029  }  }
1030    
1031    
# Line 376  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 385  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 398  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')) {      } elsif ($cgi->param('code')) {
1116          # Here the user wants to see the code for one of our scripts.          # Here the user wants to see the code for one of our scripts.
1117          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 424  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 445  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                    # 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) };              $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(0);                  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                  my $string = 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;                  print $string;
1203                  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);
1204              }              }
# Line 463  Line 1208 
1208          Trace("Function $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    
1213  =head3 CreateFile  =head3 CreateFile
1214    
# Line 624  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 {
# Line 711  Line 1457 
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.36  
changed lines
  Added in v.1.65

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3