[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.43, Fri Mar 19 03:43:08 2010 UTC revision 1.56, Thu Oct 14 17:28:49 2010 UTC
# Line 5  Line 5 
5      use strict;      use strict;
6      use Tracer;      use Tracer;
7      use YAML;      use YAML;
8        use JSON::Any;
9      use ERDB;      use ERDB;
10      use TestUtils;      use TestUtils;
11      use Time::HiRes;      use Time::HiRes;
# Line 14  Line 15 
15      no warnings qw(once);      no warnings qw(once);
16    
17      # Maximum number of requests to run per invocation.      # Maximum number of requests to run per invocation.
18      use constant MAX_REQUESTS => 5000;      use constant MAX_REQUESTS => 50;
19    
20  =head1 General Server Helper  =head1 General Server Helper
21    
# Line 97  Line 98 
98    
99  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
100    
101      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
102    
103  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
104  based on data in the argument hash. The argument hash will be checked for  based on data in the argument hash. The argument hash will be checked for
105  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
106  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
107  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
108    
109  =over 4  =over 4
110    
# Line 117  Line 118 
118  Reference to the parameter hash for the current server call. This hash will  Reference to the parameter hash for the current server call. This hash will
119  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
120    
121    =item roles
122    
123    If TRUE, role filtering will be applied. In this case, the default action
124    is to exclude auxiliary roles unless C<-aux> is TRUE.
125    
126  =back  =back
127    
128  =cut  =cut
# Line 127  Line 133 
133    
134  sub AddSubsystemFilter {  sub AddSubsystemFilter {
135      # Get the parameters.      # Get the parameters.
136      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
137      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
138      my @newFilters;      my @newFilters;
139      # Unless unusable subsystems are desired, we must add a clause to the filter.      # Unless unusable subsystems are desired, we must add a clause to the filter.
# Line 151  Line 157 
157              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
158          }          }
159      }      }
160        # Check for role filtering.
161        if ($roles) {
162            # Here, we filter out auxiliary roles unless the user requests
163            # them.
164            if (! $args->{-aux}) {
165                push @newFilters, "Includes(auxiliary) = 0"
166            }
167        }
168      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
169      if (@newFilters) {      if (@newFilters) {
170          # Yes. If the incoming filter is nonempty, push it onto the list          # Yes. If the incoming filter is nonempty, push it onto the list
# Line 291  Line 305 
305      }      }
306  }  }
307    
308    =head3 ReadCountVector
309    
310        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
311    
312    Extract a count vector from a query. The query can contain zero or more results,
313    and the vectors in the specified result field of the query must be concatenated
314    together in order. This method is optimized for the case (expected to be most
315    common) where there is only one result.
316    
317    =over 4
318    
319    =item qh
320    
321    Handle for the query from which results are to be extracted.
322    
323    =item field
324    
325    Name of the field containing the count vectors.
326    
327    =item rawFlag
328    
329    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
330    as reference to a list of numbers.
331    
332    =item RETURN
333    
334    Returns the desired vector, either encoded as a string or as a reference to a list
335    of numbers.
336    
337    =back
338    
339    =cut
340    
341    sub ReadCountVector {
342        # Get the parameters.
343        my ($qh, $field, $rawFlag) = @_;
344        # Declare the return variable.
345        my $retVal;
346        # Loop through the query results.
347        while (my $resultRow = $qh->Fetch()) {
348            # Get this vector.
349            my ($levelVector) = $resultRow->Value($field, $rawFlag);
350            # Is this the first result?
351            if (! defined $retVal) {
352                # Yes. Assign the result directly.
353                $retVal = $levelVector;
354            } elsif ($rawFlag) {
355                # This is a second result and the vectors are coded as strings.
356                $retVal .= $levelVector;
357            } else {
358                # This is a second result and the vectors are coded as array references.
359                push @$retVal, @$levelVector;
360            }
361        }
362        # Return the result.
363        return $retVal;
364    }
365    
366    
367  =head2 Gene Correspondence File Methods  =head2 Gene Correspondence File Methods
368    
# Line 468  Line 540 
540      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
541      if (0 && -f $testFileName) {      if (0 && -f $testFileName) {
542          # Use the pre-computed file.          # Use the pre-computed file.
543          Trace("Using pre-computed file $fileName for genome correspondence.") if T(3);          Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
544          $fileName = $testFileName;          $fileName = $testFileName;
545      } elsif (-f $corrFileName) {      } elsif (-f $corrFileName) {
546          $fileName = $corrFileName;          $fileName = $corrFileName;
547          Trace("Using cached file $fileName for genome correspondence.") if T(3);          Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
548      }      }
549      # Return the result.      # Return the result.
550      return ($fileName, $converse);      return ($fileName, $converse);
# Line 519  Line 591 
591          ($genomeA, $genomeB) = ($genome1, $genome2);          ($genomeA, $genomeB) = ($genome1, $genome2);
592      }      }
593      # Insure the source organism has a subdirectory in the organism cache.      # Insure the source organism has a subdirectory in the organism cache.
594      my $orgDir = "$FIG_Config::orgCache/$genomeA";      my $orgDir = ComputeCorrespondenceDirectory($genomeA);
     Tracer::Insure($orgDir, 0777);  
595      # Compute the name of the correspondence file for the appropriate target genome.      # Compute the name of the correspondence file for the appropriate target genome.
596      $fileName = "$orgDir/$genomeB";      $fileName = "$orgDir/$genomeB";
597      # Return the results.      # Return the results.
# Line 528  Line 599 
599  }  }
600    
601    
602    =head3 ComputeCorresopndenceDirectory
603    
604        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
605    
606    Return the name of the directory that would contain the correspondence files
607    for the specified genome.
608    
609    =over 4
610    
611    =item genome
612    
613    ID of the genome whose correspondence file directory is desired.
614    
615    =item RETURN
616    
617    Returns the name of the directory of interest.
618    
619    =back
620    
621    =cut
622    
623    sub ComputeCorrespondenceDirectory {
624        # Get the parameters.
625        my ($genome) = @_;
626        # Insure the source organism has a subdirectory in the organism cache.
627        my $retVal = "$FIG_Config::orgCache/$genome";
628        Tracer::Insure($retVal, 0777);
629        # Return it.
630        return $retVal;
631    }
632    
633    
634  =head3 CreateGeneCorrespondenceFile  =head3 CreateGeneCorrespondenceFile
635    
636      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
# Line 599  Line 702 
702              # Everything is ok, fix the permissions and return the file name.              # Everything is ok, fix the permissions and return the file name.
703              chmod 0664, $corrFileName;              chmod 0664, $corrFileName;
704              $fileName = $corrFileName;              $fileName = $corrFileName;
705              Trace("Created correspondence file $fileName.") if T(3);              Trace("Created correspondence file $fileName.") if T(Corr => 3);
706          }          }
707      }      }
708      # If the temporary file exists, delete it.      # If the temporary file exists, delete it.
# Line 634  Line 737 
737  Returns TRUE if the first genome would be stored on the server as a target, FALSE if  Returns TRUE if the first genome would be stored on the server as a target, FALSE if
738  it would be stored as a source.  it would be stored as a source.
739    
740    =back
741    
742  =cut  =cut
743    
744  sub MustFlipGenomeIDs {  sub MustFlipGenomeIDs {
# Line 695  Line 800 
800      Trace("Reading correspondence file $fileName.") if T(3);      Trace("Reading correspondence file $fileName.") if T(3);
801      if (! open $ih, "<$fileName") {      if (! open $ih, "<$fileName") {
802          # Here the open failed, so we have an error.          # Here the open failed, so we have an error.
803          Trace("Failed to open gene correspondence file $fileName: $!") if T(3);          Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
804          $error = 1;          $error = 1;
805      }      }
806      # The gene correspondence list will be built in here.      # The gene correspondence list will be built in here.
# Line 716  Line 821 
821          }          }
822          # Validate the row.          # Validate the row.
823          if (ValidateGeneCorrespondenceRow(\@row)) {          if (ValidateGeneCorrespondenceRow(\@row)) {
824              Trace("Invalid row $. found in correspondence file $fileName.") if T(3);              Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
825              $error = 1;              $error = 1;
826          }          }
827          # If this row is in the correct direction, keep it.          # If this row is in the correct direction, keep it.
# Line 731  Line 836 
836          if ($reverseFound) {          if ($reverseFound) {
837              $retVal = \@corrList;              $retVal = \@corrList;
838          } else {          } else {
839              Trace("No reverse arrow found in correspondence file $fileName.") if T(3);              Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);
840          }          }
841      }      }
842      # Return the result (if any).      # Return the result (if any).
# Line 767  Line 872 
872      $row->[8] = ARROW_FLIP->{$row->[8]};      $row->[8] = ARROW_FLIP->{$row->[8]};
873      # Flip the pairs.      # Flip the pairs.
874      my @elements = split /,/, $row->[3];      my @elements = split /,/, $row->[3];
875      $row->[3] = join(",", map { reverse split /:/, $_ } @elements);      $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
876  }  }
877    
878  =head3 ValidateGeneCorrespondenceRow  =head3 ValidateGeneCorrespondenceRow
# Line 801  Line 906 
906      # Check for non-numeric values in the number columns.      # Check for non-numeric values in the number columns.
907      for my $col (@{NUM_COLS()}) {      for my $col (@{NUM_COLS()}) {
908          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
909                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
910              $retVal++;              $retVal++;
911          }          }
912      }      }
913      # Check the gene IDs.      # Check the gene IDs.
914      for my $col (0, 1) {      for my $col (0, 1) {
915          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
916                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
917              $retVal++;              $retVal++;
918          }          }
919      }      }
920      # Verify the arrow.      # Verify the arrow.
921      unless (exists ARROW_FLIP->{$row->[8]}) {      unless (exists ARROW_FLIP->{$row->[8]}) {
922            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
923          $retVal++;          $retVal++;
924      }      }
925      # Return the error count.      # Return the error count.
926      return $retVal;      return $retVal;
927  }  }
928    
929    =head3 GetCorrespondenceData
930    
931        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
932    
933    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
934    list is in a file, it will be read. If the file does not exist, it may be created.
935    
936    =over 4
937    
938    =item genome1
939    
940    ID of the source genome.
941    
942    =item genome2
943    
944    ID of the target genome.
945    
946    =item passive
947    
948    If TRUE, then the correspondence file will not be created if it does not exist.
949    
950    =item full
951    
952    If TRUE, then both directions of the correspondence will be represented; otherwise, only
953    correspondences from the source to the target (including bidirectional corresopndences)
954    will be included.
955    
956    =item RETURN
957    
958    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
959    undefined value if an error occurs or no file exists and passive mode was specified.
960    
961    =back
962    
963    =cut
964    
965    sub GetCorrespondenceData {
966        # Get the parameters.
967        my ($genome1, $genome2, $passive, $full) = @_;
968        # Declare the return variable.
969        my $retVal;
970        # Check for a gene correspondence file.
971        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
972        if ($fileName) {
973            # Here we found one, so read it in.
974            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
975        }
976        # Were we successful?
977        if (! defined $retVal) {
978            # Here we either don't have a correspondence file, or the one that's there is
979            # invalid. If we are NOT in passive mode, then this means we need to create
980            # the file.
981            if (! $passive) {
982                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
983                # Now try reading the new file.
984                if (defined $fileName) {
985                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
986                }
987            }
988        }
989        # Return the result.
990        return $retVal;
991    
992    }
993    
994    
995  =head2 Internal Utility Methods  =head2 Internal Utility Methods
996    
# Line 834  Line 1007 
1007    
1008  =item cgi  =item cgi
1009    
1010  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
1011    significant parameters are as follows.
1012    
1013    =over 8
1014    
1015    =item function
1016    
1017    Name of the function to run.
1018    
1019    =item args
1020    
1021    Parameters for the function.
1022    
1023    =item encoding
1024    
1025    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1026    by the Java interface).
1027    
1028    =back
1029    
1030    Certain unusual requests can come in outside of the standard function interface.
1031    These are indicated by special parameters that override all the others.
1032    
1033    =over 8
1034    
1035    =item pod
1036    
1037    Display a POD documentation module.
1038    
1039    =item code
1040    
1041    Display an example code file.
1042    
1043    =item file
1044    
1045    Transfer a file (not implemented).
1046    
1047    =back
1048    
1049  =item serverThing  =item serverThing
1050    
# Line 848  Line 1058 
1058      # Get the parameters.      # Get the parameters.
1059      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1060      # Determine the request type.      # Determine the request type.
1061      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1062          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1063            # Here we have a documentation request.
1064            if ($module eq 'ServerScripts') {
1065                # Here we list the server scripts.
1066                require ListServerScripts;
1067                ListServerScripts::main();
1068            } else {
1069                # In this case, we produce POD HTML.
1070          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1071            }
1072      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1073          # 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.
1074          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 875  Line 1093 
1093          # Insure the function name is valid.          # Insure the function name is valid.
1094          Die("Invalid function name.")          Die("Invalid function name.")
1095              if $function =~ /\W/;              if $function =~ /\W/;
1096            # Determing the encoding scheme. The default is YAML.
1097            my $encoding = $cgi->param('encoding') || 'yaml';
1098          # The parameter structure will go in here.          # The parameter structure will go in here.
1099          my $args;          my $args = {};
1100          # Start the timer.          # Start the timer.
1101          my $start = time();          my $start = time();
1102          # The output document goes in here.          # The output document goes in here.
# Line 885  Line 1105 
1105          my $sapling;          my $sapling;
1106          # Protect from errors.          # Protect from errors.
1107          eval {          eval {
1108              # Parse the arguments.              # Here we parse the arguments. This is affected by the encoding parameter.
1109              $args = YAML::Load($cgi->param('args'));              # Get the argument string.
1110                my $argString = $cgi->param('args');
1111                # Only proceed if we found one.
1112                if ($argString) {
1113                    if ($encoding eq 'yaml') {
1114                        # Parse the arguments using YAML.
1115                        $args = YAML::Load($argString);
1116                    } elsif ($encoding eq 'json') {
1117                        # Parse the arguments using JSON.
1118                        Trace("Incoming string is:\n$argString") if T(3);
1119                        $args = JSON::Any->jsonToObj($argString);
1120                    } else {
1121                        Die("Invalid encoding type $encoding.");
1122                    }
1123                }
1124          };          };
1125          # Check to make sure we got everything.          # Check to make sure we got everything.
1126          if ($@) {          if ($@) {
# Line 900  Line 1134 
1134                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1135                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1136              } else {              } else {
1137                  # No error, so we output the result.                  # No error, so we output the result. Start with an HTML header.
1138                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1139                  my $string = YAML::Dump($document);                  # The nature of the output depends on the encoding type.
1140                    my $string;
1141                    if ($encoding eq 'yaml') {
1142                        $string = YAML::Dump($document);
1143                    } else {
1144                        $string = JSON::Any->objToJson($document);
1145                    }
1146                  print $string;                  print $string;
1147                  MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);                  MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
1148              }              }
# Line 1073  Line 1313 
1313      my ($module) = @_;      my ($module) = @_;
1314      # Start the output page.      # Start the output page.
1315      print CGI::header();      print CGI::header();
1316      print CGI::start_html(-title => 'Documentation Page',      print CGI::start_html(-title => "$module Documentation Page",
1317                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1318      # Protect from errors.      # Protect from errors.
1319      eval {      eval {

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3