[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.51, Wed Apr 28 15:46:38 2010 UTC revision 1.62, Wed Feb 9 17:56:09 2011 UTC
# Line 40  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 98  Line 100 
100    
101  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
102    
103      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
104    
105  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
106  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
107  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
108  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
109  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
110    
111  =over 4  =over 4
112    
# Line 118  Line 120 
120  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
121  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
122    
123    =item roles
124    
125    If TRUE, role filtering will be applied. In this case, the default action
126    is to exclude auxiliary roles unless C<-aux> is TRUE.
127    
128  =back  =back
129    
130  =cut  =cut
# Line 128  Line 135 
135    
136  sub AddSubsystemFilter {  sub AddSubsystemFilter {
137      # Get the parameters.      # Get the parameters.
138      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
139      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
140      my @newFilters;      my @newFilters;
141      # 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 152  Line 159 
159              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
160          }          }
161      }      }
162        # Check for role filtering.
163        if ($roles) {
164            # Here, we filter out auxiliary roles unless the user requests
165            # them.
166            if (! $args->{-aux}) {
167                push @newFilters, "Includes(auxiliary) = 0"
168            }
169        }
170      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
171      if (@newFilters) {      if (@newFilters) {
172          # 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 292  Line 307 
307      }      }
308  }  }
309    
310    =head3 ReadCountVector
311    
312        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
313    
314    Extract a count vector from a query. The query can contain zero or more results,
315    and the vectors in the specified result field of the query must be concatenated
316    together in order. This method is optimized for the case (expected to be most
317    common) where there is only one result.
318    
319    =over 4
320    
321    =item qh
322    
323    Handle for the query from which results are to be extracted.
324    
325    =item field
326    
327    Name of the field containing the count vectors.
328    
329    =item rawFlag
330    
331    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
332    as reference to a list of numbers.
333    
334    =item RETURN
335    
336    Returns the desired vector, either encoded as a string or as a reference to a list
337    of numbers.
338    
339    =back
340    
341    =cut
342    
343    sub ReadCountVector {
344        # Get the parameters.
345        my ($qh, $field, $rawFlag) = @_;
346        # Declare the return variable.
347        my $retVal;
348        # Loop through the query results.
349        while (my $resultRow = $qh->Fetch()) {
350            # Get this vector.
351            my ($levelVector) = $resultRow->Value($field, $rawFlag);
352            # Is this the first result?
353            if (! defined $retVal) {
354                # Yes. Assign the result directly.
355                $retVal = $levelVector;
356            } elsif ($rawFlag) {
357                # This is a second result and the vectors are coded as strings.
358                $retVal .= $levelVector;
359            } else {
360                # This is a second result and the vectors are coded as array references.
361                push @$retVal, @$levelVector;
362            }
363        }
364        # Return the result.
365        return $retVal;
366    }
367    
368    =head3 ChangeDB
369    
370        ServerThing::ChangeDB($thing, $newDbName);
371    
372    Change the sapling database used by this server. The old database will be closed and a
373    new one attached.
374    
375    =over 4
376    
377    =item newDbName
378    
379    Name of the new Sapling database on which this server should operate. If omitted, the
380    default database will be used.
381    
382    =back
383    
384    =cut
385    
386    sub ChangeDB {
387        # Get the parameters.
388        my ($thing, $newDbName) = @_;
389        # Default the db-name if it's not specified.
390        if (! defined $newDbName) {
391            $newDbName = $FIG_Config::saplingDB;
392        }
393        # Check to see if we really need to change.
394        my $oldDB = $thing->{db};
395        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
396            # We need a new sapling.
397            require Sapling;
398            my $newDB = Sapling->new(dbName => $newDbName);
399            $thing->{db} = $newDB;
400        }
401    }
402    
403    
404  =head2 Gene Correspondence File Methods  =head2 Gene Correspondence File Methods
405    
# Line 666  Line 774 
774  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
775  it would be stored as a source.  it would be stored as a source.
776    
777    =back
778    
779  =cut  =cut
780    
781  sub MustFlipGenomeIDs {  sub MustFlipGenomeIDs {
# Line 758  Line 868 
868      }      }
869      # Close the input file.      # Close the input file.
870      close $ih;      close $ih;
871      # If we have no errors and we found a reverse arrow, keep the result.      # If we have no errors, keep the result.
872      if (! $error) {      if (! $error) {
         if ($reverseFound) {  
873              $retVal = \@corrList;              $retVal = \@corrList;
         } else {  
             Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);  
         }  
874      }      }
875      # Return the result (if any).      # Return the result (if any).
876      return $retVal;      return $retVal;
# Line 853  Line 959 
959      return $retVal;      return $retVal;
960  }  }
961    
962    =head3 GetCorrespondenceData
963    
964        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
965    
966    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
967    list is in a file, it will be read. If the file does not exist, it may be created.
968    
969    =over 4
970    
971    =item genome1
972    
973    ID of the source genome.
974    
975    =item genome2
976    
977    ID of the target genome.
978    
979    =item passive
980    
981    If TRUE, then the correspondence file will not be created if it does not exist.
982    
983    =item full
984    
985    If TRUE, then both directions of the correspondence will be represented; otherwise, only
986    correspondences from the source to the target (including bidirectional corresopndences)
987    will be included.
988    
989    =item RETURN
990    
991    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
992    undefined value if an error occurs or no file exists and passive mode was specified.
993    
994    =back
995    
996    =cut
997    
998    sub GetCorrespondenceData {
999        # Get the parameters.
1000        my ($genome1, $genome2, $passive, $full) = @_;
1001        # Declare the return variable.
1002        my $retVal;
1003        # Check for a gene correspondence file.
1004        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1005        if ($fileName) {
1006            # Here we found one, so read it in.
1007            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1008        }
1009        # Were we successful?
1010        if (! defined $retVal) {
1011            # Here we either don't have a correspondence file, or the one that's there is
1012            # invalid. If we are NOT in passive mode, then this means we need to create
1013            # the file.
1014            if (! $passive) {
1015                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1016                # Now try reading the new file.
1017                if (defined $fileName) {
1018                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1019                }
1020            }
1021        }
1022        # Return the result.
1023        return $retVal;
1024    
1025    }
1026    
1027    
1028  =head2 Internal Utility Methods  =head2 Internal Utility Methods
1029    
# Line 860  Line 1031 
1031    
1032  =head3 RunRequest  =head3 RunRequest
1033    
1034      ServerThing::RunRequest($cgi, $serverName);      ServerThing::RunRequest($cgi, $serverThing, $docURL);
1035    
1036  Run a request from the specified server using the incoming CGI parameter  Run a request from the specified server using the incoming CGI parameter
1037  object for the parameters.  object for the parameters.
# Line 912  Line 1083 
1083    
1084  Server object against which to run the request.  Server object against which to run the request.
1085    
1086    =item docURL
1087    
1088    URL to use for POD documentation requests.
1089    
1090  =back  =back
1091    
1092  =cut  =cut
# Line 919  Line 1094 
1094  sub RunRequest {  sub RunRequest {
1095      # Get the parameters.      # Get the parameters.
1096      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1097        # Make the CGI object available to the server.
1098        $serverThing->{cgi} = $cgi;
1099      # Determine the request type.      # Determine the request type.
1100      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1101          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1102            # Here we have a documentation request.
1103            if ($module eq 'ServerScripts') {
1104                # Here we list the server scripts.
1105                require ListServerScripts;
1106                ListServerScripts::main();
1107            } else {
1108                # In this case, we produce POD HTML.
1109          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1110            }
1111      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1112          # 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.
1113          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 949  Line 1134 
1134              if $function =~ /\W/;              if $function =~ /\W/;
1135          # Determing the encoding scheme. The default is YAML.          # Determing the encoding scheme. The default is YAML.
1136          my $encoding = $cgi->param('encoding') || 'yaml';          my $encoding = $cgi->param('encoding') || 'yaml';
1137            # Optional callback for json encoded documents
1138            my $callback = $cgi->param('callback');
1139          # The parameter structure will go in here.          # The parameter structure will go in here.
1140          my $args;          my $args = {};
1141          # Start the timer.          # Start the timer.
1142          my $start = time();          my $start = time();
1143          # The output document goes in here.          # The output document goes in here.
1144          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1145          # Protect from errors.          # Protect from errors.
1146          eval {          eval {
1147              # Here we parse the arguments. This is affected by the encoding parameter.              # Here we parse the arguments. This is affected by the encoding parameter.
1148              # Get the argument string.              # Get the argument string.
1149              my $argString = $cgi->param('args');              my $argString = $cgi->param('args');
1150                # Only proceed if we found one.
1151                if ($argString) {
1152              if ($encoding eq 'yaml') {              if ($encoding eq 'yaml') {
1153                  # Parse the arguments using YAML.                  # Parse the arguments using YAML.
1154                  $args = YAML::Load($argString);                  $args = YAML::Load($argString);
# Line 972  Line 1159 
1159              } else {              } else {
1160                  Die("Invalid encoding type $encoding.");                  Die("Invalid encoding type $encoding.");
1161              }              }
1162                }
1163          };          };
1164          # Check to make sure we got everything.          # Check to make sure we got everything.
1165          if ($@) {          if ($@) {
# Line 979  Line 1167 
1167          } elsif (! $function) {          } elsif (! $function) {
1168              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1169          } else {          } else {
1170                # Insure we're connected to the correct database.
1171                my $dbName = $cgi->param('dbName');
1172                if ($dbName && exists $serverThing->{db}) {
1173                    ChangeDB($serverThing, $dbName);
1174                }
1175                # Run the request.
1176              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1177              # If we have an error, create an error document.              # If we have an error, create an error document.
1178              if ($@) {              if ($@) {
# Line 986  Line 1180 
1180                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1181              } else {              } else {
1182                  # No error, so we output the result. Start with an HTML header.                  # No error, so we output the result. Start with an HTML header.
1183                    if ($encoding eq 'yaml') {
1184                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1185                    } else {
1186                        print $cgi->header(-type => 'text/javascript');
1187                    }
1188                  # The nature of the output depends on the encoding type.                  # The nature of the output depends on the encoding type.
1189                  my $string;                  my $string;
1190                  if ($encoding eq 'yaml') {                  if ($encoding eq 'yaml') {
1191                      $string = YAML::Dump($document);                      $string = YAML::Dump($document);
1192                    } elsif(defined($callback)) {
1193                        $string = $callback . "(".JSON::Any->objToJson($document).")";
1194                  } else {                  } else {
1195                      $string = JSON::Any->objToJson($document);                      $string = JSON::Any->objToJson($document);
1196                  }                  }

Legend:
Removed from v.1.51  
changed lines
  Added in v.1.62

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3