[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.56, Thu Oct 14 17:28:49 2010 UTC revision 1.66, Mon Mar 14 21:04:25 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 53  Line 55 
55          if ($@) {          if ($@) {
56              SendError($@, "Could not start server.");              SendError($@, "Could not start server.");
57          } else {          } else {
58              # No error, so now we can process the request.              # No error, so now we can process the request. First, get the method list.
59                my $methods = $serverThing->methods();
60                # Store it in the object so we can use it to validate methods.
61                my %methodHash = map { $_ => 1 } @$methods;
62                $serverThing->{methods} = \%methodHash;
63              my $cgi;              my $cgi;
64              if (! defined $key) {              if (! defined $key) {
65                  # No tracing key, so presume we're a web service. Check for Fast CGI.                  # No tracing key, so presume we're a web service. Check for Fast CGI.
# Line 363  Line 369 
369      return $retVal;      return $retVal;
370  }  }
371    
372    =head3 ChangeDB
373    
374        ServerThing::ChangeDB($thing, $newDbName);
375    
376    Change the sapling database used by this server. The old database will be closed and a
377    new one attached.
378    
379    =over 4
380    
381    =item newDbName
382    
383    Name of the new Sapling database on which this server should operate. If omitted, the
384    default database will be used.
385    
386    =back
387    
388    =cut
389    
390    sub ChangeDB {
391        # Get the parameters.
392        my ($thing, $newDbName) = @_;
393        # Default the db-name if it's not specified.
394        if (! defined $newDbName) {
395            $newDbName = $FIG_Config::saplingDB;
396        }
397        # Check to see if we really need to change.
398        my $oldDB = $thing->{db};
399        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
400            # We need a new sapling.
401            require Sapling;
402            my $newDB = Sapling->new(dbName => $newDbName);
403            $thing->{db} = $newDB;
404        }
405    }
406    
407    
408  =head2 Gene Correspondence File Methods  =head2 Gene Correspondence File Methods
409    
# Line 831  Line 872 
872      }      }
873      # Close the input file.      # Close the input file.
874      close $ih;      close $ih;
875      # If we have no errors and we found a reverse arrow, keep the result.      # If we have no errors, keep the result.
876      if (! $error) {      if (! $error) {
         if ($reverseFound) {  
877              $retVal = \@corrList;              $retVal = \@corrList;
         } else {  
             Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);  
         }  
878      }      }
879      # Return the result (if any).      # Return the result (if any).
880      return $retVal;      return $retVal;
# Line 998  Line 1035 
1035    
1036  =head3 RunRequest  =head3 RunRequest
1037    
1038      ServerThing::RunRequest($cgi, $serverName);      ServerThing::RunRequest($cgi, $serverThing, $docURL);
1039    
1040  Run a request from the specified server using the incoming CGI parameter  Run a request from the specified server using the incoming CGI parameter
1041  object for the parameters.  object for the parameters.
# Line 1050  Line 1087 
1087    
1088  Server object against which to run the request.  Server object against which to run the request.
1089    
1090    =item docURL
1091    
1092    URL to use for POD documentation requests.
1093    
1094  =back  =back
1095    
1096  =cut  =cut
# Line 1057  Line 1098 
1098  sub RunRequest {  sub RunRequest {
1099      # Get the parameters.      # Get the parameters.
1100      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1101        # Make the CGI object available to the server.
1102        $serverThing->{cgi} = $cgi;
1103      # Determine the request type.      # Determine the request type.
1104      my $module = $cgi->param('pod');      my $module = $cgi->param('pod');
1105      if ($module) {      if ($module) {
# Line 1091  Line 1134 
1134          my $function = $cgi->param('function') || "";          my $function = $cgi->param('function') || "";
1135          Trace("Server function for task $$ is $function.") if T(3);          Trace("Server function for task $$ is $function.") if T(3);
1136          # Insure the function name is valid.          # Insure the function name is valid.
1137          Die("Invalid function name.")          if ($function ne "methods" && exists $serverThing->{methods} && ! $serverThing->{methods}{$function}) {
1138              if $function =~ /\W/;              SendError("Invalid function name.", "$function not found.")
1139            } else {
1140          # Determing the encoding scheme. The default is YAML.          # Determing the encoding scheme. The default is YAML.
1141          my $encoding = $cgi->param('encoding') || 'yaml';          my $encoding = $cgi->param('encoding') || 'yaml';
1142                # Optional callback for json encoded documents
1143                my $callback = $cgi->param('callback');
1144          # The parameter structure will go in here.          # The parameter structure will go in here.
1145          my $args = {};          my $args = {};
1146          # Start the timer.          # Start the timer.
1147          my $start = time();          my $start = time();
1148          # The output document goes in here.          # The output document goes in here.
1149          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1150          # Protect from errors.          # Protect from errors.
1151          eval {          eval {
1152              # Here we parse the arguments. This is affected by the encoding parameter.              # Here we parse the arguments. This is affected by the encoding parameter.
# Line 1128  Line 1172 
1172          } elsif (! $function) {          } elsif (! $function) {
1173              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1174          } else {          } else {
1175                    # Insure we're connected to the correct database.
1176                    my $dbName = $cgi->param('dbName');
1177                    if ($dbName && exists $serverThing->{db}) {
1178                        ChangeDB($serverThing, $dbName);
1179                    }
1180                    # Run the request.
1181              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1182              # If we have an error, create an error document.              # If we have an error, create an error document.
1183              if ($@) {              if ($@) {
# Line 1135  Line 1185 
1185                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1186              } else {              } else {
1187                  # No error, so we output the result. Start with an HTML header.                  # No error, so we output the result. Start with an HTML header.
1188                        if ($encoding eq 'yaml') {
1189                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1190                        } else {
1191                            print $cgi->header(-type => 'text/javascript');
1192                        }
1193                  # The nature of the output depends on the encoding type.                  # The nature of the output depends on the encoding type.
1194                  my $string;                  my $string;
1195                  if ($encoding eq 'yaml') {                  if ($encoding eq 'yaml') {
1196                      $string = YAML::Dump($document);                      $string = YAML::Dump($document);
1197                        } elsif(defined($callback)) {
1198                            $string = $callback . "(".JSON::Any->objToJson($document).")";
1199                  } else {                  } else {
1200                      $string = JSON::Any->objToJson($document);                      $string = JSON::Any->objToJson($document);
1201                  }                  }
# Line 1152  Line 1208 
1208          Trace("Function $function executed in $duration seconds by task $$.") if T(2);          Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1209      }      }
1210  }  }
1211    }
1212    
1213  =head3 CreateFile  =head3 CreateFile
1214    
# Line 1400  Line 1457 
1457  }  }
1458    
1459    
1460    =head3 Log
1461    
1462        Log($msg);
1463    
1464    Write a message to the log. This is a temporary hack until we can figure out how to get
1465    normal tracing and error logging working.
1466    
1467    =over 4
1468    
1469    =item msg
1470    
1471    Message to write. It will be appended to the C<servers.log> file in the FIG temporary directory.
1472    
1473    =back
1474    
1475    =cut
1476    
1477    sub Log {
1478        # Get the parameters.
1479        my ($msg) = @_;
1480        # Open the log file for appending.
1481        open(my $oh, ">>$FIG_Config::tmp/servers.log") || Confess("Log error: $!");
1482        print $oh "$msg\n";
1483        close $oh;
1484    }
1485    
1486  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3