[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.72, Thu Mar 17 21:32:30 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.
66                  if ($ENV{REQUEST_METHOD} eq '') {                  if ($ENV{REQUEST_METHOD} eq '') {
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);                      # warn "Starting fast CGI loop.\n"; ##HACK 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                        open(SERVER_STDERR, ">&", *STDERR);
74                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
75                             ($cgi = new CGI::Fast())) {                             ($cgi = new CGI::Fast())) {
76                            #
77                            # Remap STDERR. Inside here, our STDERR is a tie to a FCGI::Stream
78                            # so we need to save it to keep FCGI happy.
79                            #
80                            *SAVED_STDERR = *STDERR;
81                            *STDERR = *SERVER_STDERR;
82                            my $function = $cgi->param('function') || "<non-functional>"; # (useful if we do tracing in here)
83                            # warn "Function request is $function in task $$.\n"; ##HACK
84                          RunRequest($cgi, $serverThing);                          RunRequest($cgi, $serverThing);
85                          Trace("Request $requests complete in task $$.") if T(3);                          # warn "$requests requests complete in fast CGI task $$.\n"; ##HACK Trace("Request $requests complete in task $$.") if T(3);
86                            *STDERR = *SAVED_STDERR;
87                      }                      }
88                      Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);                      # warn "Terminating FastCGI task $$ after $requests requests.\n"; ##HACK Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
89                        close(SERVER_STDERR);
90                  } else {                  } else {
91                      # Here we have a normal web service (non-Fast).                      # Here we have a normal web service (non-Fast).
92                      my $cgi = CGI->new();                      my $cgi = CGI->new();
# Line 97  Line 115 
115    
116  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
117    
118      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
119    
120  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
121  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
122  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
123  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
124  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
125    
126  =over 4  =over 4
127    
# Line 117  Line 135 
135  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
136  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
137    
138    =item roles
139    
140    If TRUE, role filtering will be applied. In this case, the default action
141    is to exclude auxiliary roles unless C<-aux> is TRUE.
142    
143  =back  =back
144    
145  =cut  =cut
# Line 127  Line 150 
150    
151  sub AddSubsystemFilter {  sub AddSubsystemFilter {
152      # Get the parameters.      # Get the parameters.
153      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
154      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
155      my @newFilters;      my @newFilters;
156      # 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 174 
174              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
175          }          }
176      }      }
177        # Check for role filtering.
178        if ($roles) {
179            # Here, we filter out auxiliary roles unless the user requests
180            # them.
181            if (! $args->{-aux}) {
182                push @newFilters, "Includes(auxiliary) = 0"
183            }
184        }
185      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
186      if (@newFilters) {      if (@newFilters) {
187          # 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 322 
322      }      }
323  }  }
324    
325  =head3 FindGeneCorrespondenceFile  =head3 ReadCountVector
326    
327        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
328    
329    Extract a count vector from a query. The query can contain zero or more results,
330    and the vectors in the specified result field of the query must be concatenated
331    together in order. This method is optimized for the case (expected to be most
332    common) where there is only one result.
333    
334    =over 4
335    
336    =item qh
337    
338    Handle for the query from which results are to be extracted.
339    
340    =item field
341    
342    Name of the field containing the count vectors.
343    
344    =item rawFlag
345    
346    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
347    as reference to a list of numbers.
348    
349    =item RETURN
350    
351    Returns the desired vector, either encoded as a string or as a reference to a list
352    of numbers.
353    
354    =back
355    
356    =cut
357    
358    sub ReadCountVector {
359        # Get the parameters.
360        my ($qh, $field, $rawFlag) = @_;
361        # Declare the return variable.
362        my $retVal;
363        # Loop through the query results.
364        while (my $resultRow = $qh->Fetch()) {
365            # Get this vector.
366            my ($levelVector) = $resultRow->Value($field, $rawFlag);
367            # Is this the first result?
368            if (! defined $retVal) {
369                # Yes. Assign the result directly.
370                $retVal = $levelVector;
371            } elsif ($rawFlag) {
372                # This is a second result and the vectors are coded as strings.
373                $retVal .= $levelVector;
374            } else {
375                # This is a second result and the vectors are coded as array references.
376                push @$retVal, @$levelVector;
377            }
378        }
379        # Return the result.
380        return $retVal;
381    }
382    
383    =head3 ChangeDB
384    
385        ServerThing::ChangeDB($thing, $newDbName);
386    
387    Change the sapling database used by this server. The old database will be closed and a
388    new one attached.
389    
390    =over 4
391    
392    =item newDbName
393    
394    Name of the new Sapling database on which this server should operate. If omitted, the
395    default database will be used.
396    
397    =back
398    
399    =cut
400    
401    sub ChangeDB {
402        # Get the parameters.
403        my ($thing, $newDbName) = @_;
404        # Default the db-name if it's not specified.
405        if (! defined $newDbName) {
406            $newDbName = $FIG_Config::saplingDB;
407        }
408        # Check to see if we really need to change.
409        my $oldDB = $thing->{db};
410        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
411            # We need a new sapling.
412            require Sapling;
413            my $newDB = Sapling->new(dbName => $newDbName);
414            $thing->{db} = $newDB;
415        }
416    }
417    
418    
419    =head2 Gene Correspondence File Methods
420    
421    These methods relate to gene correspondence files, which are generated by the
422    L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
423    organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
424    copied into the organism directories themselves. At that point, the code below
425    will be modified to check the organism directories first and use the cache
426    directory if no file is found there.
427    
428    A gene correspondence file contains correspondences from a source genome to a
429    target genome. Most such correspondences are bidirectional best hits. A unidirectional
430    best hit may exist from the source genome to the target genome or in the reverse
431    direction from the targtet genome to the source genome. The cache directory itself
432    is divided into subdirectories by organism. The subdirectory has the source genome
433    name and the files themselves are named by the target genome.
434    
435    Some of the files are invalid and will be erased when they are found. A file is
436    considered invalid if it has a non-numeric value in a numeric column or if it
437    does not have any unidirectional hits from the target genome to the source
438    genome.
439    
440    The process of managing the correspondence files is tricky and dangerous because
441    of the possibility of race conditions. It can take several minutes to generate a
442    file, and if two processes try to generate the same file at the same time we need
443    to make sure they don't step on each other.
444    
445    In stored files, the source genome ID is always lexically lower than the target
446    genome ID. If a correspondence in the reverse direction is desired, the converse
447    file is found and the contents flipped automatically as they are read. So, the
448    correspondence from B<360108.3> to B<100226.1> would be found in a file with the
449    name B<360108.3> in the directory for B<100226.1>. Since this file actually has
450    B<100226.1> as the source and B<360108.3> as the target, the columns are
451    re-ordered and the arrows reversed before the file contents are passed to the
452    caller.
453    
454    =head4 Gene Correspondence List
455    
456    A gene correspondence file contains 18 columns. These are usually packaged as
457    a reference to list of lists. Each sub-list has the following format.
458    
459    =over 4
460    
461    =item 0
462    
463    The ID of a PEG in genome 1.
464    
465    =item 1
466    
467    The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".
468    
469    =item 2
470    
471    Count of the number of pairs of matching genes were found in the context.
472    
473    =item 3
474    
475    Pairs of corresponding genes from the contexts.
476    
477    =item 4
478    
479    The function of the gene in genome 1.
480    
481    =item 5
482    
483    The function of the gene in genome 2.
484    
485    =item 6
486    
487    Comma-separated list of aliases for the gene in genome 1 (any protein with an
488    identical sequence is considered an alias, whether or not it is actually the
489    name of the same gene in the same genome).
490    
491    =item 7
492    
493    Comma-separated list of aliases for the gene in genome 2 (any protein with an
494    identical sequence is considered an alias, whether or not it is actually the
495    name of the same gene in the same genome).
496    
497    =item 8
498    
499    Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.
500    
501    =item 9
502    
503    Percent identity over the region of the detected match.
504    
505    =item 10
506    
507    The P-score for the detected match.
508    
509    =item 11
510    
511    Beginning match coordinate in the protein encoded by the gene in genome 1.
512    
513    =item 12
514    
515    Ending match coordinate in the protein encoded by the gene in genome 1.
516    
517    =item 13
518    
519    Length of the protein encoded by the gene in genome 1.
520    
521    =item 14
522    
523    Beginning match coordinate in the protein encoded by the gene in genome 2.
524    
525    =item 15
526    
527    Ending match coordinate in the protein encoded by the gene in genome 2.
528    
529    =item 16
530    
531    Length of the protein encoded by the gene in genome 2.
532    
533    =item 17
534    
535    Bit score for the match. Divide by the length of the longer PEG to get
536    what we often refer to as a "normalized bit score".
537    
538    =item 18 (optional)
539    
540    Clear-correspondence indicator. If present, will be C<1> if the correspondence is a
541    clear bidirectional best hit (no similar candidates) and C<0> otherwise.
542    
543    =back
544    
545    In the actual files, there will also be reverse correspondences indicated by a
546    back-arrow ("<-") in item (8). The output returned by the servers, however,
547    is filtered so that only forward correspondences occur. If a converse file
548    is used, the columns are re-ordered and the arrows reversed so that it looks
549    correct.
550    
551    =cut
552    
553    # hash for reversing the arrows
554    use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
555    # list of columns that contain numeric values that need to be validated
556    use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];
557    
558    =head3 CheckForGeneCorrespondenceFile
559    
560        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
561    
562    Try to find a gene correspondence file for the specified genome pairing. If the
563    file exists, its name and an indication of whether or not it is in the correct
564    direction will be returned.
565    
566    =over 4
567    
568    =item genome1
569    
570    Source genome for the desired correspondence.
571    
572    =item genome2
573    
574    Target genome for the desired correspondence.
575    
576    =item RETURN
577    
578    Returns a two-element list. The first element is the name of the file containing the
579    correspondence, or C<undef> if the file does not exist. The second element is TRUE
580    if the correspondence would be forward or FALSE if the file needs to be flipped.
581    
582    =back
583    
584    =cut
585    
586    sub CheckForGeneCorrespondenceFile {
587        # Get the parameters.
588        my ($genome1, $genome2) = @_;
589        # Declare the return variables.
590        my ($fileName, $converse);
591        # Determine the ordering of the genome IDs.
592        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
593        $converse = ($genomeA ne $genome1);
594        # Look for a file containing the desired correspondence. (The code to check for a
595        # pre-computed file in the organism directories is currently turned off, because
596        # these files are all currently invalid.)
597        my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
598        if (0 && -f $testFileName) {
599            # Use the pre-computed file.
600            Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
601            $fileName = $testFileName;
602        } elsif (-f $corrFileName) {
603            $fileName = $corrFileName;
604            Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
605        }
606        # Return the result.
607        return ($fileName, $converse);
608    }
609    
610    
611    =head3 ComputeCorrespondenceFileName
612    
613        my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);
614    
615    Compute the name to be given to a genome correspondence file in the organism cache
616    and return the source and target genomes that would be in it.
617    
618    =over 4
619    
620    =item genome1
621    
622    Source genome for the desired correspondence.
623    
624    =item genome2
625    
626    Target genome for the desired correspondence.
627    
628    =item RETURN
629    
630    Returns a three-element list. The first element is the name of the file to contain the
631    correspondence, the second element is the name of the genome that would act as the
632    source genome in the file, and the third element is the name of the genome that would
633    act as the target genome in the file.
634    
635    =back
636    
637    =cut
638    
639    sub ComputeCorrespondenceFileName {
640        # Get the parameters.
641        my ($genome1, $genome2) = @_;
642        # Declare the return variables.
643        my ($fileName, $genomeA, $genomeB);
644        # Determine the ordering of the genome IDs.
645        if (MustFlipGenomeIDs($genome1, $genome2)) {
646            ($genomeA, $genomeB) = ($genome2, $genome1);
647        } else {
648            ($genomeA, $genomeB) = ($genome1, $genome2);
649        }
650        # Insure the source organism has a subdirectory in the organism cache.
651        my $orgDir = ComputeCorrespondenceDirectory($genomeA);
652        # Compute the name of the correspondence file for the appropriate target genome.
653        $fileName = "$orgDir/$genomeB";
654        # Return the results.
655        return ($fileName, $genomeA, $genomeB);
656    }
657    
658    
659    =head3 ComputeCorresopndenceDirectory
660    
661        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
662    
663    Return the name of the directory that would contain the correspondence files
664    for the specified genome.
665    
666    =over 4
667    
668    =item genome
669    
670    ID of the genome whose correspondence file directory is desired.
671    
672    =item RETURN
673    
674    Returns the name of the directory of interest.
675    
676    =back
677    
678    =cut
679    
680    sub ComputeCorrespondenceDirectory {
681        # Get the parameters.
682        my ($genome) = @_;
683        # Insure the source organism has a subdirectory in the organism cache.
684        my $retVal = "$FIG_Config::orgCache/$genome";
685        Tracer::Insure($retVal, 0777);
686        # Return it.
687        return $retVal;
688    }
689    
690    
691    =head3 CreateGeneCorrespondenceFile
692    
693      my $ih = ServerThing::FindGeneCorrespondenceFile($genome1, $genome2);      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
694    
695  Return an open input handle for a file that maps the genes in the first genome  Create a new gene correspondence file in the organism cache for the specified
696  to corresponding genes in the second genome. These files can be found for some  genome correspondence. The name of the new file will be returned along with
697  genomes in the organism directories. Additional files are available in the  an indicator of whether or not it is in the correct direction.
698  organism cache directory (I<$FIG_Config::orgCache>). If the desired file does  
699  not exist, one will be created in the organism cache directory, presumably to be  =over 4
700  moved to a permanent location at a later time.  
701    =item genome1
702    
703    Source genome for the desired correspondence.
704    
705    =item genome2
706    
707    Target genome for the desired correspondence.
708    
709    =item RETURN
710    
711    Returns a two-element list. The first element is the name of the file containing the
712    correspondence, or C<undef> if an error occurred. The second element is TRUE
713    if the correspondence would be forward or FALSE if the file needs to be flipped.
714    
715    =back
716    
717    =cut
718    
719    sub CreateGeneCorrespondenceFile {
720        # Get the parameters.
721        my ($genome1, $genome2) = @_;
722        # Declare the return variables.
723        my ($fileName, $converse);
724        # Compute the ultimate name for the correspondence file.
725        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
726        $converse = ($genome1 ne $genomeA);
727        # Generate a temporary file name in the same directory. We'll build the temporary
728        # file and then rename it when we're done.
729        my $tempFileName = "$corrFileName.$$.tmp";
730        # This will be set to FALSE if we detect an error.
731        my $fileOK = 1;
732        # The file handles will be put in here.
733        my ($ih, $oh);
734        # Protect from errors.
735        eval {
736            # Open the temporary file for output.
737            $oh = Open(undef, ">$tempFileName");
738            # Open a pipe to get the correspondence data.
739            $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
740            Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
741            # Copy the pipe date into the temporary file.
742            while (! eof $ih) {
743                my $line = <$ih>;
744                print $oh $line;
745            }
746            # Close both files. If the close fails we need to know: it means there was a pipe
747            # error.
748            $fileOK &&= close $ih;
749            $fileOK &&= close $oh;
750        };
751        if ($@) {
752            # Here a fatal error of some sort occurred. We need to force the files closed.
753            close $ih if $ih;
754            close $oh if $oh;
755        } elsif ($fileOK) {
756            # Here everything worked. Try to rename the temporary file to the real
757            # file name.
758            if (rename $tempFileName, $corrFileName) {
759                # Everything is ok, fix the permissions and return the file name.
760                chmod 0664, $corrFileName;
761                $fileName = $corrFileName;
762                Trace("Created correspondence file $fileName.") if T(Corr => 3);
763            }
764        }
765        # If the temporary file exists, delete it.
766        if (-f $tempFileName) {
767            unlink $tempFileName;
768        }
769        # Return the results.
770        return ($fileName, $converse);
771    }
772    
773    
774    =head3 MustFlipGenomeIDs
775    
776        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
777    
778    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
779    order, they are stored in the converse order in correspondence files on the server.
780    This is a simple method that allows the caller to check for the need to flip.
781    
782    =over 4
783    
784    =item genome1
785    
786    ID of the proposed source genome.
787    
788    =item genome2
789    
790    ID of the proposed target genome.
791    
792    =item RETURN
793    
794    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
795    it would be stored as a source.
796    
797    =back
798    
799    =cut
800    
801    sub MustFlipGenomeIDs {
802        # Get the parameters.
803        my ($genome1, $genome2) = @_;
804        # Return an indication.
805        return ($genome1 gt $genome2);
806    }
807    
808    
809    =head3 ReadGeneCorrespondenceFile
810    
811        my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
812    
813    Return the contents of the specified gene correspondence file in the form of
814    a list of lists, with backward correspondences filtered out. If the file is
815    for the converse of the desired correspondence, the columns will be reordered
816    automatically so that it looks as if the file were designed for the proper
817    direction.
818    
819    =over 4
820    
821    =item fileName
822    
823    The name of the gene correspondence file to read.
824    
825    =item converse (optional)
826    
827    TRUE if the file is for the converse of the desired correspondence, else FALSE.
828    If TRUE, the file columns will be reorderd automatically. The default is FALSE,
829    meaning we want to use the file as it appears on disk.
830    
831    =item all (optional)
832    
833    TRUE if backward unidirectional correspondences should be included in the output.
834    The default is FALSE, in which case only forward and bidirectional correspondences
835    are included.
836    
837    =item RETURN
838    
839    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
840    If the file's contents are invalid or an error occurs, an undefined value will be
841    returned.
842    
843    =back
844    
845    =cut
846    
847    sub ReadGeneCorrespondenceFile {
848        # Get the parameters.
849        my ($fileName, $converse, $all) = @_;
850        # Declare the return variable. We will only put something in here if we are
851        # completely successful.
852        my $retVal;
853        # This value will be set to 1 if an error is detected.
854        my $error = 0;
855        # Try to open the file.
856        my $ih;
857        Trace("Reading correspondence file $fileName.") if T(3);
858        if (! open $ih, "<$fileName") {
859            # Here the open failed, so we have an error.
860            Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
861            $error = 1;
862        }
863        # The gene correspondence list will be built in here.
864        my @corrList;
865        # This variable will be set to TRUE if we find a reverse correspondence somewhere
866        # in the file. Not finding one is an error.
867        my $reverseFound = 0;
868        # Loop until we hit the end of the file or an error occurs. We must check the error
869        # first in case the file handle failed to open.
870        while (! $error && ! eof $ih) {
871            # Get the current line.
872            my @row = Tracer::GetLine($ih);
873            # Get the correspondence direction and check for a reverse arrow.
874            $reverseFound = 1 if ($row[8] eq '<-');
875            # If we're in converse mode, reformat the line.
876            if ($converse) {
877                ReverseGeneCorrespondenceRow(\@row);
878            }
879            # Validate the row.
880            if (ValidateGeneCorrespondenceRow(\@row)) {
881                Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
882                $error = 1;
883            }
884            # If this row is in the correct direction, keep it.
885            if ($all || $row[8] ne '<-') {
886                push @corrList, \@row;
887            }
888        }
889        # Close the input file.
890        close $ih;
891        # If we have no errors, keep the result.
892        if (! $error) {
893            $retVal = \@corrList;
894        }
895        # Return the result (if any).
896        return $retVal;
897    }
898    
899    =head3 ReverseGeneCorrespondenceRow
900    
901        ServerThing::ReverseGeneCorrespondenceRow($row)
902    
903    Convert a gene correspondence row to represent the converse correspondence. The
904    elements in the row will be reordered to represent a correspondence from the
905    target genome to the source genome.
906    
907    =over 4
908    
909    =item row
910    
911    Reference to a list containing a single row from a L</Gene Correspondence List>.
912    
913    =back
914    
915    =cut
916    
917    sub ReverseGeneCorrespondenceRow {
918        # Get the parameters.
919        my ($row) = @_;
920        # Flip the row in place.
921        ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
922         $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
923         $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
924        # Flip the arrow.
925        $row->[8] = ARROW_FLIP->{$row->[8]};
926        # Flip the pairs.
927        my @elements = split /,/, $row->[3];
928        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
929    }
930    
931    =head3 ValidateGeneCorrespondenceRow
932    
933        my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);
934    
935    Validate a gene correspondence row. The numeric fields are checked to insure they
936    are numeric and the source and target gene IDs are validated. The return value will
937    indicate the number of errors found.
938    
939    =over 4
940    
941    =item row
942    
943    Reference to a list containing a single row from a L</Gene Correspondence List>.
944    
945    =item RETURN
946    
947    Returns the number of errors found in the row. A return of C<0> indicates the row
948    is valid.
949    
950    =back
951    
952    =cut
953    
954    sub ValidateGeneCorrespondenceRow {
955        # Get the parameters.
956        my ($row, $genome1, $genome2) = @_;
957        # Denote no errors have been found so far.
958        my $retVal = 0;
959        # Check for non-numeric values in the number columns.
960        for my $col (@{NUM_COLS()}) {
961            unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
962                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
963                $retVal++;
964            }
965        }
966        # Check the gene IDs.
967        for my $col (0, 1) {
968            unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
969                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
970                $retVal++;
971            }
972        }
973        # Verify the arrow.
974        unless (exists ARROW_FLIP->{$row->[8]}) {
975            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
976            $retVal++;
977        }
978        # Return the error count.
979        return $retVal;
980    }
981    
982    =head3 GetCorrespondenceData
983    
984        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
985    
986    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
987    list is in a file, it will be read. If the file does not exist, it may be created.
988    
989  =over 4  =over 4
990    
# Line 312  Line 996 
996    
997  ID of the target genome.  ID of the target genome.
998    
999    =item passive
1000    
1001    If TRUE, then the correspondence file will not be created if it does not exist.
1002    
1003    =item full
1004    
1005    If TRUE, then both directions of the correspondence will be represented; otherwise, only
1006    correspondences from the source to the target (including bidirectional corresopndences)
1007    will be included.
1008    
1009  =item RETURN  =item RETURN
1010    
1011  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
1012  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.  
1013    
1014  =back  =back
1015    
1016  =cut  =cut
1017    
1018  sub FindGeneCorrespondenceFile {  sub GetCorrespondenceData {
1019      # Get the parameters.      # Get the parameters.
1020      my ($genome1, $genome2) = @_;      my ($genome1, $genome2, $passive, $full) = @_;
1021      # Declare the return variable.      # Declare the return variable.
1022      my $retVal;      my $retVal;
1023      # Look for a pre-computed file in the organism directories.      # Check for a gene correspondence file.
1024      my $fileName = "$FIG_Config::organisms/$genome1/CorrToReferenceGenomes/$genome2";      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1025      if (-f $fileName) {      if ($fileName) {
1026          # Use the pre-computed file.          # Here we found one, so read it in.
1027          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");  
1028              }              }
1029        # Were we successful?
1030        if (! defined $retVal) {
1031            # Here we either don't have a correspondence file, or the one that's there is
1032            # invalid. If we are NOT in passive mode, then this means we need to create
1033            # the file.
1034            if (! $passive) {
1035                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1036                # Now try reading the new file.
1037                if (defined $fileName) {
1038                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1039          }          }
1040      }      }
1041      # Return the desired file handle.      }
1042        # Return the result.
1043      return $retVal;      return $retVal;
1044    
1045  }  }
1046    
1047    
# Line 376  Line 1051 
1051    
1052  =head3 RunRequest  =head3 RunRequest
1053    
1054      ServerThing::RunRequest($cgi, $serverName);      ServerThing::RunRequest($cgi, $serverThing, $docURL);
1055    
1056  Run a request from the specified server using the incoming CGI parameter  Run a request from the specified server using the incoming CGI parameter
1057  object for the parameters.  object for the parameters.
# Line 385  Line 1060 
1060    
1061  =item cgi  =item cgi
1062    
1063  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
1064    significant parameters are as follows.
1065    
1066    =over 8
1067    
1068    =item function
1069    
1070    Name of the function to run.
1071    
1072    =item args
1073    
1074    Parameters for the function.
1075    
1076    =item encoding
1077    
1078    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1079    by the Java interface).
1080    
1081    =back
1082    
1083    Certain unusual requests can come in outside of the standard function interface.
1084    These are indicated by special parameters that override all the others.
1085    
1086    =over 8
1087    
1088    =item pod
1089    
1090    Display a POD documentation module.
1091    
1092    =item code
1093    
1094    Display an example code file.
1095    
1096    =item file
1097    
1098    Transfer a file (not implemented).
1099    
1100    =back
1101    
1102  =item serverThing  =item serverThing
1103    
1104  Server object against which to run the request.  Server object against which to run the request.
1105    
1106    =item docURL
1107    
1108    URL to use for POD documentation requests.
1109    
1110  =back  =back
1111    
1112  =cut  =cut
# Line 398  Line 1114 
1114  sub RunRequest {  sub RunRequest {
1115      # Get the parameters.      # Get the parameters.
1116      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1117        # Make the CGI object available to the server.
1118        $serverThing->{cgi} = $cgi;
1119      # Determine the request type.      # Determine the request type.
1120      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1121          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1122            # Here we have a documentation request.
1123            if ($module eq 'ServerScripts') {
1124                # Here we list the server scripts.
1125                require ListServerScripts;
1126                ListServerScripts::main();
1127            } else {
1128                # In this case, we produce POD HTML.
1129          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1130            }
1131      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1132          # 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.
1133          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 424  Line 1150 
1150          my $function = $cgi->param('function') || "";          my $function = $cgi->param('function') || "";
1151          Trace("Server function for task $$ is $function.") if T(3);          Trace("Server function for task $$ is $function.") if T(3);
1152          # Insure the function name is valid.          # Insure the function name is valid.
1153          Die("Invalid function name.")          if ($function ne "methods" && exists $serverThing->{methods} && ! $serverThing->{methods}{$function}) {
1154              if $function =~ /\W/;              SendError("Invalid function name.", "$function not found.")
1155            } else {
1156                # Determing the encoding scheme. The default is YAML.
1157                my $encoding = $cgi->param('encoding') || 'yaml';
1158                # Optional callback for json encoded documents
1159                my $callback = $cgi->param('callback');
1160          # The parameter structure will go in here.          # The parameter structure will go in here.
1161          my $args;              my $args = {};
1162          # Start the timer.          # Start the timer.
1163          my $start = time();          my $start = time();
1164          # The output document goes in here.          # The output document goes in here.
1165          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1166          # Protect from errors.          # Protect from errors.
1167          eval {          eval {
1168              # Parse the arguments.                  # Here we parse the arguments. This is affected by the encoding parameter.
1169              $args = YAML::Load($cgi->param('args'));                  # Get the argument string.
1170                    my $argString = $cgi->param('args');
1171                    # Only proceed if we found one.
1172                    if ($argString) {
1173                        if ($encoding eq 'yaml') {
1174                            # Parse the arguments using YAML.
1175                            $args = YAML::Load($argString);
1176                        } elsif ($encoding eq 'json') {
1177                            # Parse the arguments using JSON.
1178                            Trace("Incoming string is:\n$argString") if T(3);
1179                            $args = JSON::Any->jsonToObj($argString);
1180                        } else {
1181                            Die("Invalid encoding type $encoding.");
1182                        }
1183                    }
1184          };          };
1185          # Check to make sure we got everything.          # Check to make sure we got everything.
1186          if ($@) {          if ($@) {
# Line 445  Line 1188 
1188          } elsif (! $function) {          } elsif (! $function) {
1189              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1190          } else {          } else {
1191                    # Insure we're connected to the correct database.
1192                    my $dbName = $cgi->param('dbName');
1193                    if ($dbName && exists $serverThing->{db}) {
1194                        ChangeDB($serverThing, $dbName);
1195                    }
1196                    # Run the request.
1197              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1198              # If we have an error, create an error document.              # If we have an error, create an error document.
1199              if ($@) {              if ($@) {
1200                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1201                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1202              } else {              } else {
1203                  # No error, so we output the result.                      # No error, so we output the result. Start with an HTML header.
1204                        if ($encoding eq 'yaml') {
1205                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1206                  my $string = YAML::Dump($document);                      } else {
1207                            print $cgi->header(-type => 'text/javascript');
1208                        }
1209                        # The nature of the output depends on the encoding type.
1210                        eval {
1211                            my $string;
1212                            if ($encoding eq 'yaml') {
1213                                $string = YAML::Dump($document);
1214                            } elsif(defined($callback)) {
1215                                $string = $callback . "(".JSON::Any->objToJson($document).")";
1216                            } else {
1217                                $string = JSON::Any->objToJson($document);
1218                            }
1219                  print $string;                  print $string;
1220                  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);
1221                        };
1222                        if ($@) {
1223                            SendError($@, "Error encoding result.");
1224                            Trace("Error encoding result: $@") if T(0);
1225                        }
1226              }              }
1227          }          }
1228          # Stop the timer.          # Stop the timer.
# Line 463  Line 1230 
1230          Trace("Function $function executed in $duration seconds by task $$.") if T(2);          Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1231      }      }
1232  }  }
1233    }
1234    
1235  =head3 CreateFile  =head3 CreateFile
1236    
# Line 624  Line 1392 
1392      my ($module) = @_;      my ($module) = @_;
1393      # Start the output page.      # Start the output page.
1394      print CGI::header();      print CGI::header();
1395      print CGI::start_html(-title => 'Documentation Page',      print CGI::start_html(-title => "$module Documentation Page",
1396                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1397      # Protect from errors.      # Protect from errors.
1398      eval {      eval {
# Line 711  Line 1479 
1479  }  }
1480    
1481    
1482    =head3 Log
1483    
1484        Log($msg);
1485    
1486    Write a message to the log. This is a temporary hack until we can figure out how to get
1487    normal tracing and error logging working.
1488    
1489    =over 4
1490    
1491    =item msg
1492    
1493    Message to write. It will be appended to the C<servers.log> file in the FIG temporary directory.
1494    
1495    =back
1496    
1497    =cut
1498    
1499    sub Log {
1500        # Get the parameters.
1501        my ($msg) = @_;
1502        # Open the log file for appending.
1503        open(my $oh, ">>$FIG_Config::temp/servers.log") || Confess("Log error: $!");
1504        print $oh "$msg\n";
1505        close $oh;
1506    }
1507    
1508  1;  1;

Legend:
Removed from v.1.36  
changed lines
  Added in v.1.72

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3