[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.49, Wed Apr 28 14:02:11 2010 UTC revision 1.60, Tue Jan 25 22:44:43 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 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            my $output = $serverName;
44            $output =~ s/::/\//;
45          require "$serverName.pm";          require "$serverName.pm";
46      };      };
47      # If we have an error, create an error document.      # If we have an error, create an error document.
# Line 97  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 117  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 127  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 151  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 291  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 665  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 757  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 852  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 919  Line 1091 
1091      # Get the parameters.      # Get the parameters.
1092      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1093      # Determine the request type.      # Determine the request type.
1094      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1095          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1096            # Here we have a documentation request.
1097            if ($module eq 'ServerScripts') {
1098                # Here we list the server scripts.
1099                require ListServerScripts;
1100                ListServerScripts::main();
1101            } else {
1102                # In this case, we produce POD HTML.
1103          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1104            }
1105      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1106          # 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.
1107          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 946  Line 1126 
1126          # Insure the function name is valid.          # Insure the function name is valid.
1127          Die("Invalid function name.")          Die("Invalid function name.")
1128              if $function =~ /\W/;              if $function =~ /\W/;
1129            # Determing the encoding scheme. The default is YAML.
1130            my $encoding = $cgi->param('encoding') || 'yaml';
1131            # Optional callback for json encoded documents
1132            my $callback = $cgi->param('callback');
1133          # The parameter structure will go in here.          # The parameter structure will go in here.
1134          my $args;          my $args = {};
1135          # Start the timer.          # Start the timer.
1136          my $start = time();          my $start = time();
1137          # The output document goes in here.          # The output document goes in here.
1138          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1139          # Protect from errors.          # Protect from errors.
1140          eval {          eval {
1141              # Here we parse the arguments. This is affected by the encoding parameter.              # Here we parse the arguments. This is affected by the encoding parameter.
             # The default is YAML.  
             my $encoding = $cgi->param('encoding') || 'yaml';  
1142              # Get the argument string.              # Get the argument string.
1143              my $argString = $cgi->param('args');              my $argString = $cgi->param('args');
1144                # Only proceed if we found one.
1145                if ($argString) {
1146              if ($encoding eq 'yaml') {              if ($encoding eq 'yaml') {
1147                  # Parse the arguments using YAML.                  # Parse the arguments using YAML.
1148                  $args = YAML::Load($argString);                  $args = YAML::Load($argString);
1149              } elsif ($encoding eq 'json') {              } elsif ($encoding eq 'json') {
1150                  # Parse the arguments using JSON.                  # Parse the arguments using JSON.
1151                  require JSON::Any;                      Trace("Incoming string is:\n$argString") if T(3);
1152                  $args = JSON::Any->jsonToObj($argString);                  $args = JSON::Any->jsonToObj($argString);
1153              } else {              } else {
1154                  Die("Invalid encoding type $encoding.");                  Die("Invalid encoding type $encoding.");
1155              }              }
1156                }
1157          };          };
1158          # Check to make sure we got everything.          # Check to make sure we got everything.
1159          if ($@) {          if ($@) {
# Line 978  Line 1161 
1161          } elsif (! $function) {          } elsif (! $function) {
1162              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1163          } else {          } else {
1164                # Insure we're connected to the correct database.
1165                my $dbName = $cgi->param('dbName');
1166                if ($dbName && exists $serverThing->{db}) {
1167                    ChangeDB($serverThing, $dbName);
1168                }
1169                # Run the request.
1170              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1171              # If we have an error, create an error document.              # If we have an error, create an error document.
1172              if ($@) {              if ($@) {
1173                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1174                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1175              } else {              } else {
1176                  # No error, so we output the result.                  # No error, so we output the result. Start with an HTML header.
1177                    if ($encoding eq 'yaml') {
1178                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1179                  my $string = YAML::Dump($document);                  } else {
1180                        print $cgi->header(-type => 'text/javascript');
1181                    }
1182                    # The nature of the output depends on the encoding type.
1183                    my $string;
1184                    if ($encoding eq 'yaml') {
1185                        $string = YAML::Dump($document);
1186                    } elsif(defined($callback)) {
1187                        $string = $callback . "(".JSON::Any->objToJson($document).")";
1188                    } else {
1189                        $string = JSON::Any->objToJson($document);
1190                    }
1191                  print $string;                  print $string;
1192                  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);
1193              }              }

Legend:
Removed from v.1.49  
changed lines
  Added in v.1.60

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3