[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.40, Tue Mar 16 20:24:05 2010 UTC revision 1.70, Thu Mar 17 18:40:41 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                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
74                             ($cgi = new CGI::Fast())) {                             ($cgi = new CGI::Fast())) {
75                            my $function = $cgi->param('function') || "<non-functional>"; #HACK
76                            # warn "Function request is $function in task $$.\n"; ##HACK
77                          RunRequest($cgi, $serverThing);                          RunRequest($cgi, $serverThing);
78                          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);
79                      }                      }
80                      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);
81                  } else {                  } else {
82                      # Here we have a normal web service (non-Fast).                      # Here we have a normal web service (non-Fast).
83                      my $cgi = CGI->new();                      my $cgi = CGI->new();
# Line 97  Line 106 
106    
107  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
108    
109      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
110    
111  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
112  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
113  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
114  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
115  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
116    
117  =over 4  =over 4
118    
# Line 117  Line 126 
126  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
127  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
128    
129    =item roles
130    
131    If TRUE, role filtering will be applied. In this case, the default action
132    is to exclude auxiliary roles unless C<-aux> is TRUE.
133    
134  =back  =back
135    
136  =cut  =cut
# Line 127  Line 141 
141    
142  sub AddSubsystemFilter {  sub AddSubsystemFilter {
143      # Get the parameters.      # Get the parameters.
144      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
145      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
146      my @newFilters;      my @newFilters;
147      # 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 165 
165              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
166          }          }
167      }      }
168        # Check for role filtering.
169        if ($roles) {
170            # Here, we filter out auxiliary roles unless the user requests
171            # them.
172            if (! $args->{-aux}) {
173                push @newFilters, "Includes(auxiliary) = 0"
174            }
175        }
176      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
177      if (@newFilters) {      if (@newFilters) {
178          # 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 313 
313      }      }
314  }  }
315    
316    =head3 ReadCountVector
317    
318        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
319    
320    Extract a count vector from a query. The query can contain zero or more results,
321    and the vectors in the specified result field of the query must be concatenated
322    together in order. This method is optimized for the case (expected to be most
323    common) where there is only one result.
324    
325    =over 4
326    
327    =item qh
328    
329    Handle for the query from which results are to be extracted.
330    
331    =item field
332    
333    Name of the field containing the count vectors.
334    
335    =item rawFlag
336    
337    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
338    as reference to a list of numbers.
339    
340    =item RETURN
341    
342    Returns the desired vector, either encoded as a string or as a reference to a list
343    of numbers.
344    
345    =back
346    
347    =cut
348    
349    sub ReadCountVector {
350        # Get the parameters.
351        my ($qh, $field, $rawFlag) = @_;
352        # Declare the return variable.
353        my $retVal;
354        # Loop through the query results.
355        while (my $resultRow = $qh->Fetch()) {
356            # Get this vector.
357            my ($levelVector) = $resultRow->Value($field, $rawFlag);
358            # Is this the first result?
359            if (! defined $retVal) {
360                # Yes. Assign the result directly.
361                $retVal = $levelVector;
362            } elsif ($rawFlag) {
363                # This is a second result and the vectors are coded as strings.
364                $retVal .= $levelVector;
365            } else {
366                # This is a second result and the vectors are coded as array references.
367                push @$retVal, @$levelVector;
368            }
369        }
370        # Return the result.
371        return $retVal;
372    }
373    
374    =head3 ChangeDB
375    
376        ServerThing::ChangeDB($thing, $newDbName);
377    
378    Change the sapling database used by this server. The old database will be closed and a
379    new one attached.
380    
381    =over 4
382    
383    =item newDbName
384    
385    Name of the new Sapling database on which this server should operate. If omitted, the
386    default database will be used.
387    
388    =back
389    
390    =cut
391    
392    sub ChangeDB {
393        # Get the parameters.
394        my ($thing, $newDbName) = @_;
395        # Default the db-name if it's not specified.
396        if (! defined $newDbName) {
397            $newDbName = $FIG_Config::saplingDB;
398        }
399        # Check to see if we really need to change.
400        my $oldDB = $thing->{db};
401        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
402            # We need a new sapling.
403            require Sapling;
404            my $newDB = Sapling->new(dbName => $newDbName);
405            $thing->{db} = $newDB;
406        }
407    }
408    
409    
410  =head2 Gene Correspondence File Methods  =head2 Gene Correspondence File Methods
411    
# Line 468  Line 583 
583      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
584      if (0 && -f $testFileName) {      if (0 && -f $testFileName) {
585          # Use the pre-computed file.          # Use the pre-computed file.
586          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);
587          $fileName = $testFileName;          $fileName = $testFileName;
588      } elsif (-f $corrFileName) {      } elsif (-f $corrFileName) {
589          $fileName = $corrFileName;          $fileName = $corrFileName;
590          Trace("Using cached file $fileName for genome correspondence.") if T(3);          Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
591      }      }
592      # Return the result.      # Return the result.
593      return ($fileName, $converse);      return ($fileName, $converse);
# Line 513  Line 628 
628      # Declare the return variables.      # Declare the return variables.
629      my ($fileName, $genomeA, $genomeB);      my ($fileName, $genomeA, $genomeB);
630      # Determine the ordering of the genome IDs.      # Determine the ordering of the genome IDs.
631      if ($genome1 lt $genome2) {      if (MustFlipGenomeIDs($genome1, $genome2)) {
         ($genomeA, $genomeB) = ($genome1, $genome2);  
     } else {  
632          ($genomeA, $genomeB) = ($genome2, $genome1);          ($genomeA, $genomeB) = ($genome2, $genome1);
633        } else {
634            ($genomeA, $genomeB) = ($genome1, $genome2);
635      }      }
636      # Insure the source organism has a subdirectory in the organism cache.      # Insure the source organism has a subdirectory in the organism cache.
637      my $orgDir = "$FIG_Config::orgCache/$genomeA";      my $orgDir = ComputeCorrespondenceDirectory($genomeA);
     Tracer::Insure($orgDir, 0777);  
638      # Compute the name of the correspondence file for the appropriate target genome.      # Compute the name of the correspondence file for the appropriate target genome.
639      $fileName = "$orgDir/$genomeB";      $fileName = "$orgDir/$genomeB";
640      # Return the results.      # Return the results.
# Line 528  Line 642 
642  }  }
643    
644    
645    =head3 ComputeCorresopndenceDirectory
646    
647        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
648    
649    Return the name of the directory that would contain the correspondence files
650    for the specified genome.
651    
652    =over 4
653    
654    =item genome
655    
656    ID of the genome whose correspondence file directory is desired.
657    
658    =item RETURN
659    
660    Returns the name of the directory of interest.
661    
662    =back
663    
664    =cut
665    
666    sub ComputeCorrespondenceDirectory {
667        # Get the parameters.
668        my ($genome) = @_;
669        # Insure the source organism has a subdirectory in the organism cache.
670        my $retVal = "$FIG_Config::orgCache/$genome";
671        Tracer::Insure($retVal, 0777);
672        # Return it.
673        return $retVal;
674    }
675    
676    
677  =head3 CreateGeneCorrespondenceFile  =head3 CreateGeneCorrespondenceFile
678    
679      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
# Line 599  Line 745 
745              # Everything is ok, fix the permissions and return the file name.              # Everything is ok, fix the permissions and return the file name.
746              chmod 0664, $corrFileName;              chmod 0664, $corrFileName;
747              $fileName = $corrFileName;              $fileName = $corrFileName;
748              Trace("Created correspondence file $fileName.") if T(3);              Trace("Created correspondence file $fileName.") if T(Corr => 3);
749          }          }
750      }      }
751      # If the temporary file exists, delete it.      # If the temporary file exists, delete it.
# Line 611  Line 757 
757  }  }
758    
759    
760    =head3 MustFlipGenomeIDs
761    
762        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
763    
764    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
765    order, they are stored in the converse order in correspondence files on the server.
766    This is a simple method that allows the caller to check for the need to flip.
767    
768    =over 4
769    
770    =item genome1
771    
772    ID of the proposed source genome.
773    
774    =item genome2
775    
776    ID of the proposed target genome.
777    
778    =item RETURN
779    
780    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
781    it would be stored as a source.
782    
783    =back
784    
785    =cut
786    
787    sub MustFlipGenomeIDs {
788        # Get the parameters.
789        my ($genome1, $genome2) = @_;
790        # Return an indication.
791        return ($genome1 gt $genome2);
792    }
793    
794    
795  =head3 ReadGeneCorrespondenceFile  =head3 ReadGeneCorrespondenceFile
796    
797      my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);      my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
# Line 662  Line 843 
843      Trace("Reading correspondence file $fileName.") if T(3);      Trace("Reading correspondence file $fileName.") if T(3);
844      if (! open $ih, "<$fileName") {      if (! open $ih, "<$fileName") {
845          # Here the open failed, so we have an error.          # Here the open failed, so we have an error.
846          Trace("Failed to open gene correspondence file $fileName: $!") if T(3);          Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
847          $error = 1;          $error = 1;
848      }      }
849      # The gene correspondence list will be built in here.      # The gene correspondence list will be built in here.
# Line 683  Line 864 
864          }          }
865          # Validate the row.          # Validate the row.
866          if (ValidateGeneCorrespondenceRow(\@row)) {          if (ValidateGeneCorrespondenceRow(\@row)) {
867              Trace("Invalid row $. found in correspondence file $fileName.") if T(3);              Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
868              $error = 1;              $error = 1;
869          }          }
870          # If this row is in the correct direction, keep it.          # If this row is in the correct direction, keep it.
# Line 693  Line 874 
874      }      }
875      # Close the input file.      # Close the input file.
876      close $ih;      close $ih;
877      # If we have no errors and we found a reverse arrow, keep the result.      # If we have no errors, keep the result.
878      if (! $error) {      if (! $error) {
         if ($reverseFound) {  
879              $retVal = \@corrList;              $retVal = \@corrList;
         } else {  
             Trace("No reverse arrow found in correspondence file $fileName.") if T(3);  
         }  
880      }      }
881      # Return the result (if any).      # Return the result (if any).
882      return $retVal;      return $retVal;
# Line 728  Line 905 
905      my ($row) = @_;      my ($row) = @_;
906      # Flip the row in place.      # Flip the row in place.
907      ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],      ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
908       $row->[6], ARROW_FLIP->{$row->[8]}, $row->[9], $row->[10], $row->[14],       $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
909       $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;       $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
910        # Flip the arrow.
911        $row->[8] = ARROW_FLIP->{$row->[8]};
912        # Flip the pairs.
913        my @elements = split /,/, $row->[3];
914        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
915  }  }
916    
917  =head3 ValidateGeneCorrespondenceRow  =head3 ValidateGeneCorrespondenceRow
# Line 763  Line 945 
945      # Check for non-numeric values in the number columns.      # Check for non-numeric values in the number columns.
946      for my $col (@{NUM_COLS()}) {      for my $col (@{NUM_COLS()}) {
947          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
948                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
949              $retVal++;              $retVal++;
950          }          }
951      }      }
952      # Check the gene IDs.      # Check the gene IDs.
953      for my $col (0, 1) {      for my $col (0, 1) {
954          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
955                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
956              $retVal++;              $retVal++;
957          }          }
958      }      }
959      # Verify the arrow.      # Verify the arrow.
960      unless (exists ARROW_FLIP->{$row->[8]}) {      unless (exists ARROW_FLIP->{$row->[8]}) {
961            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
962          $retVal++;          $retVal++;
963      }      }
964      # Return the error count.      # Return the error count.
965      return $retVal;      return $retVal;
966  }  }
967    
968    =head3 GetCorrespondenceData
969    
970        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
971    
972    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
973    list is in a file, it will be read. If the file does not exist, it may be created.
974    
975    =over 4
976    
977    =item genome1
978    
979    ID of the source genome.
980    
981    =item genome2
982    
983    ID of the target genome.
984    
985    =item passive
986    
987    If TRUE, then the correspondence file will not be created if it does not exist.
988    
989    =item full
990    
991    If TRUE, then both directions of the correspondence will be represented; otherwise, only
992    correspondences from the source to the target (including bidirectional corresopndences)
993    will be included.
994    
995    =item RETURN
996    
997    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
998    undefined value if an error occurs or no file exists and passive mode was specified.
999    
1000    =back
1001    
1002    =cut
1003    
1004    sub GetCorrespondenceData {
1005        # Get the parameters.
1006        my ($genome1, $genome2, $passive, $full) = @_;
1007        # Declare the return variable.
1008        my $retVal;
1009        # Check for a gene correspondence file.
1010        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1011        if ($fileName) {
1012            # Here we found one, so read it in.
1013            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1014        }
1015        # Were we successful?
1016        if (! defined $retVal) {
1017            # Here we either don't have a correspondence file, or the one that's there is
1018            # invalid. If we are NOT in passive mode, then this means we need to create
1019            # the file.
1020            if (! $passive) {
1021                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1022                # Now try reading the new file.
1023                if (defined $fileName) {
1024                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1025                }
1026            }
1027        }
1028        # Return the result.
1029        return $retVal;
1030    
1031    }
1032    
1033    
1034  =head2 Internal Utility Methods  =head2 Internal Utility Methods
1035    
# Line 787  Line 1037 
1037    
1038  =head3 RunRequest  =head3 RunRequest
1039    
1040      ServerThing::RunRequest($cgi, $serverName);      ServerThing::RunRequest($cgi, $serverThing, $docURL);
1041    
1042  Run a request from the specified server using the incoming CGI parameter  Run a request from the specified server using the incoming CGI parameter
1043  object for the parameters.  object for the parameters.
# Line 796  Line 1046 
1046    
1047  =item cgi  =item cgi
1048    
1049  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
1050    significant parameters are as follows.
1051    
1052    =over 8
1053    
1054    =item function
1055    
1056    Name of the function to run.
1057    
1058    =item args
1059    
1060    Parameters for the function.
1061    
1062    =item encoding
1063    
1064    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1065    by the Java interface).
1066    
1067    =back
1068    
1069    Certain unusual requests can come in outside of the standard function interface.
1070    These are indicated by special parameters that override all the others.
1071    
1072    =over 8
1073    
1074    =item pod
1075    
1076    Display a POD documentation module.
1077    
1078    =item code
1079    
1080    Display an example code file.
1081    
1082    =item file
1083    
1084    Transfer a file (not implemented).
1085    
1086    =back
1087    
1088  =item serverThing  =item serverThing
1089    
1090  Server object against which to run the request.  Server object against which to run the request.
1091    
1092    =item docURL
1093    
1094    URL to use for POD documentation requests.
1095    
1096  =back  =back
1097    
1098  =cut  =cut
# Line 809  Line 1100 
1100  sub RunRequest {  sub RunRequest {
1101      # Get the parameters.      # Get the parameters.
1102      my ($cgi, $serverThing, $docURL) = @_;      my ($cgi, $serverThing, $docURL) = @_;
1103        # Make the CGI object available to the server.
1104        $serverThing->{cgi} = $cgi;
1105      # Determine the request type.      # Determine the request type.
1106      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1107          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1108            # Here we have a documentation request.
1109            if ($module eq 'ServerScripts') {
1110                # Here we list the server scripts.
1111                require ListServerScripts;
1112                ListServerScripts::main();
1113            } else {
1114                # In this case, we produce POD HTML.
1115          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1116            }
1117      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1118          # 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.
1119          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 835  Line 1136 
1136          my $function = $cgi->param('function') || "";          my $function = $cgi->param('function') || "";
1137          Trace("Server function for task $$ is $function.") if T(3);          Trace("Server function for task $$ is $function.") if T(3);
1138          # Insure the function name is valid.          # Insure the function name is valid.
1139          Die("Invalid function name.")          if ($function ne "methods" && exists $serverThing->{methods} && ! $serverThing->{methods}{$function}) {
1140              if $function =~ /\W/;              SendError("Invalid function name.", "$function not found.")
1141            } else {
1142                # Determing the encoding scheme. The default is YAML.
1143                my $encoding = $cgi->param('encoding') || 'yaml';
1144                # Optional callback for json encoded documents
1145                my $callback = $cgi->param('callback');
1146          # The parameter structure will go in here.          # The parameter structure will go in here.
1147          my $args;              my $args = {};
1148          # Start the timer.          # Start the timer.
1149          my $start = time();          my $start = time();
1150          # The output document goes in here.          # The output document goes in here.
1151          my $document;          my $document;
         # The sapling database goes in here.  
         my $sapling;  
1152          # Protect from errors.          # Protect from errors.
1153          eval {          eval {
1154              # Parse the arguments.                  # Here we parse the arguments. This is affected by the encoding parameter.
1155              $args = YAML::Load($cgi->param('args'));                  # Get the argument string.
1156                    my $argString = $cgi->param('args');
1157                    # Only proceed if we found one.
1158                    if ($argString) {
1159                        if ($encoding eq 'yaml') {
1160                            # Parse the arguments using YAML.
1161                            $args = YAML::Load($argString);
1162                        } elsif ($encoding eq 'json') {
1163                            # Parse the arguments using JSON.
1164                            Trace("Incoming string is:\n$argString") if T(3);
1165                            $args = JSON::Any->jsonToObj($argString);
1166                        } else {
1167                            Die("Invalid encoding type $encoding.");
1168                        }
1169                    }
1170          };          };
1171          # Check to make sure we got everything.          # Check to make sure we got everything.
1172          if ($@) {          if ($@) {
# Line 856  Line 1174 
1174          } elsif (! $function) {          } elsif (! $function) {
1175              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
1176          } else {          } else {
1177                    # Insure we're connected to the correct database.
1178                    my $dbName = $cgi->param('dbName');
1179                    if ($dbName && exists $serverThing->{db}) {
1180                        ChangeDB($serverThing, $dbName);
1181                    }
1182                    # Run the request.
1183              $document = eval { $serverThing->$function($args) };              $document = eval { $serverThing->$function($args) };
1184              # If we have an error, create an error document.              # If we have an error, create an error document.
1185              if ($@) {              if ($@) {
1186                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
1187                  Trace("Error encountered by service: $@") if T(0);                  Trace("Error encountered by service: $@") if T(0);
1188              } else {              } else {
1189                  # No error, so we output the result.                      # No error, so we output the result. Start with an HTML header.
1190                        if ($encoding eq 'yaml') {
1191                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
1192                  my $string = YAML::Dump($document);                      } else {
1193                            print $cgi->header(-type => 'text/javascript');
1194                        }
1195                        # The nature of the output depends on the encoding type.
1196                        eval {
1197                            my $string;
1198                            if ($encoding eq 'yaml') {
1199                                $string = YAML::Dump($document);
1200                            } elsif(defined($callback)) {
1201                                $string = $callback . "(".JSON::Any->objToJson($document).")";
1202                            } else {
1203                                $string = JSON::Any->objToJson($document);
1204                            }
1205                  print $string;                  print $string;
1206                  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);
1207                        };
1208                        if ($@) {
1209                            SendError($@, "Error encoding result.");
1210                            Trace("Error encoding result: $@") if T(0);
1211                        }
1212              }              }
1213          }          }
1214          # Stop the timer.          # Stop the timer.
# Line 874  Line 1216 
1216          Trace("Function $function executed in $duration seconds by task $$.") if T(2);          Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1217      }      }
1218  }  }
1219    }
1220    
1221  =head3 CreateFile  =head3 CreateFile
1222    
# Line 1035  Line 1378 
1378      my ($module) = @_;      my ($module) = @_;
1379      # Start the output page.      # Start the output page.
1380      print CGI::header();      print CGI::header();
1381      print CGI::start_html(-title => 'Documentation Page',      print CGI::start_html(-title => "$module Documentation Page",
1382                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1383      # Protect from errors.      # Protect from errors.
1384      eval {      eval {
# Line 1122  Line 1465 
1465  }  }
1466    
1467    
1468    =head3 Log
1469    
1470        Log($msg);
1471    
1472    Write a message to the log. This is a temporary hack until we can figure out how to get
1473    normal tracing and error logging working.
1474    
1475    =over 4
1476    
1477    =item msg
1478    
1479    Message to write. It will be appended to the C<servers.log> file in the FIG temporary directory.
1480    
1481    =back
1482    
1483    =cut
1484    
1485    sub Log {
1486        # Get the parameters.
1487        my ($msg) = @_;
1488        # Open the log file for appending.
1489        open(my $oh, ">>$FIG_Config::temp/servers.log") || Confess("Log error: $!");
1490        print $oh "$msg\n";
1491        close $oh;
1492    }
1493    
1494  1;  1;

Legend:
Removed from v.1.40  
changed lines
  Added in v.1.70

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3