[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.63, Tue Feb 22 19:19:22 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.
# Line 97  Line 104 
104    
105  =head3 AddSubsystemFilter  =head3 AddSubsystemFilter
106    
107      ServerThing::AddSubsystemFilter(\$filter, $args);      ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
108    
109  Add subsystem filtering information to the specified query filter clause  Add subsystem filtering information to the specified query filter clause
110  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
111  the C<-usable> parameter, which includes or excludes unusuable subsystems, and  the C<-usable> parameter, which includes or excludes unusuable subsystems,
112  the C<-exclude> parameter, which lists types of subsystems that should be  the C<-exclude> parameter, which lists types of subsystems that should be
113  excluded.  excluded, and the C<-aux> parameter, which filters on auxiliary roles.
114    
115  =over 4  =over 4
116    
# Line 117  Line 124 
124  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
125  be examined for the C<-usable> and C<-exclude> parameters.  be examined for the C<-usable> and C<-exclude> parameters.
126    
127    =item roles
128    
129    If TRUE, role filtering will be applied. In this case, the default action
130    is to exclude auxiliary roles unless C<-aux> is TRUE.
131    
132  =back  =back
133    
134  =cut  =cut
# Line 127  Line 139 
139    
140  sub AddSubsystemFilter {  sub AddSubsystemFilter {
141      # Get the parameters.      # Get the parameters.
142      my ($filter, $args) = @_;      my ($filter, $args, $roles) = @_;
143      # We'll put the new filter stuff in here.      # We'll put the new filter stuff in here.
144      my @newFilters;      my @newFilters;
145      # 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 163 
163              push @newFilters, "Subsystem($exclusion) = 0";              push @newFilters, "Subsystem($exclusion) = 0";
164          }          }
165      }      }
166        # Check for role filtering.
167        if ($roles) {
168            # Here, we filter out auxiliary roles unless the user requests
169            # them.
170            if (! $args->{-aux}) {
171                push @newFilters, "Includes(auxiliary) = 0"
172            }
173        }
174      # Do we need to update the incoming filter?      # Do we need to update the incoming filter?
175      if (@newFilters) {      if (@newFilters) {
176          # 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 311 
311      }      }
312  }  }
313    
314    =head3 ReadCountVector
315    
316        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
317    
318    Extract a count vector from a query. The query can contain zero or more results,
319    and the vectors in the specified result field of the query must be concatenated
320    together in order. This method is optimized for the case (expected to be most
321    common) where there is only one result.
322    
323    =over 4
324    
325    =item qh
326    
327    Handle for the query from which results are to be extracted.
328    
329    =item field
330    
331    Name of the field containing the count vectors.
332    
333    =item rawFlag
334    
335    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
336    as reference to a list of numbers.
337    
338    =item RETURN
339    
340    Returns the desired vector, either encoded as a string or as a reference to a list
341    of numbers.
342    
343    =back
344    
345    =cut
346    
347    sub ReadCountVector {
348        # Get the parameters.
349        my ($qh, $field, $rawFlag) = @_;
350        # Declare the return variable.
351        my $retVal;
352        # Loop through the query results.
353        while (my $resultRow = $qh->Fetch()) {
354            # Get this vector.
355            my ($levelVector) = $resultRow->Value($field, $rawFlag);
356            # Is this the first result?
357            if (! defined $retVal) {
358                # Yes. Assign the result directly.
359                $retVal = $levelVector;
360            } elsif ($rawFlag) {
361                # This is a second result and the vectors are coded as strings.
362                $retVal .= $levelVector;
363            } else {
364                # This is a second result and the vectors are coded as array references.
365                push @$retVal, @$levelVector;
366            }
367        }
368        # Return the result.
369        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 468  Line 581 
581      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";      my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
582      if (0 && -f $testFileName) {      if (0 && -f $testFileName) {
583          # Use the pre-computed file.          # Use the pre-computed file.
584          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);
585          $fileName = $testFileName;          $fileName = $testFileName;
586      } elsif (-f $corrFileName) {      } elsif (-f $corrFileName) {
587          $fileName = $corrFileName;          $fileName = $corrFileName;
588          Trace("Using cached file $fileName for genome correspondence.") if T(3);          Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
589      }      }
590      # Return the result.      # Return the result.
591      return ($fileName, $converse);      return ($fileName, $converse);
# Line 513  Line 626 
626      # Declare the return variables.      # Declare the return variables.
627      my ($fileName, $genomeA, $genomeB);      my ($fileName, $genomeA, $genomeB);
628      # Determine the ordering of the genome IDs.      # Determine the ordering of the genome IDs.
629      if ($genome1 lt $genome2) {      if (MustFlipGenomeIDs($genome1, $genome2)) {
         ($genomeA, $genomeB) = ($genome1, $genome2);  
     } else {  
630          ($genomeA, $genomeB) = ($genome2, $genome1);          ($genomeA, $genomeB) = ($genome2, $genome1);
631        } else {
632            ($genomeA, $genomeB) = ($genome1, $genome2);
633      }      }
634      # Insure the source organism has a subdirectory in the organism cache.      # Insure the source organism has a subdirectory in the organism cache.
635      my $orgDir = "$FIG_Config::orgCache/$genomeA";      my $orgDir = ComputeCorrespondenceDirectory($genomeA);
     Tracer::Insure($orgDir, 0777);  
636      # Compute the name of the correspondence file for the appropriate target genome.      # Compute the name of the correspondence file for the appropriate target genome.
637      $fileName = "$orgDir/$genomeB";      $fileName = "$orgDir/$genomeB";
638      # Return the results.      # Return the results.
# Line 528  Line 640 
640  }  }
641    
642    
643    =head3 ComputeCorresopndenceDirectory
644    
645        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
646    
647    Return the name of the directory that would contain the correspondence files
648    for the specified genome.
649    
650    =over 4
651    
652    =item genome
653    
654    ID of the genome whose correspondence file directory is desired.
655    
656    =item RETURN
657    
658    Returns the name of the directory of interest.
659    
660    =back
661    
662    =cut
663    
664    sub ComputeCorrespondenceDirectory {
665        # Get the parameters.
666        my ($genome) = @_;
667        # Insure the source organism has a subdirectory in the organism cache.
668        my $retVal = "$FIG_Config::orgCache/$genome";
669        Tracer::Insure($retVal, 0777);
670        # Return it.
671        return $retVal;
672    }
673    
674    
675  =head3 CreateGeneCorrespondenceFile  =head3 CreateGeneCorrespondenceFile
676    
677      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);      my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
# Line 599  Line 743 
743              # Everything is ok, fix the permissions and return the file name.              # Everything is ok, fix the permissions and return the file name.
744              chmod 0664, $corrFileName;              chmod 0664, $corrFileName;
745              $fileName = $corrFileName;              $fileName = $corrFileName;
746              Trace("Created correspondence file $fileName.") if T(3);              Trace("Created correspondence file $fileName.") if T(Corr => 3);
747          }          }
748      }      }
749      # If the temporary file exists, delete it.      # If the temporary file exists, delete it.
# Line 611  Line 755 
755  }  }
756    
757    
758    =head3 MustFlipGenomeIDs
759    
760        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
761    
762    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
763    order, they are stored in the converse order in correspondence files on the server.
764    This is a simple method that allows the caller to check for the need to flip.
765    
766    =over 4
767    
768    =item genome1
769    
770    ID of the proposed source genome.
771    
772    =item genome2
773    
774    ID of the proposed target genome.
775    
776    =item RETURN
777    
778    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
779    it would be stored as a source.
780    
781    =back
782    
783    =cut
784    
785    sub MustFlipGenomeIDs {
786        # Get the parameters.
787        my ($genome1, $genome2) = @_;
788        # Return an indication.
789        return ($genome1 gt $genome2);
790    }
791    
792    
793  =head3 ReadGeneCorrespondenceFile  =head3 ReadGeneCorrespondenceFile
794    
795      my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);      my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
# Line 662  Line 841 
841      Trace("Reading correspondence file $fileName.") if T(3);      Trace("Reading correspondence file $fileName.") if T(3);
842      if (! open $ih, "<$fileName") {      if (! open $ih, "<$fileName") {
843          # Here the open failed, so we have an error.          # Here the open failed, so we have an error.
844          Trace("Failed to open gene correspondence file $fileName: $!") if T(3);          Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
845          $error = 1;          $error = 1;
846      }      }
847      # The gene correspondence list will be built in here.      # The gene correspondence list will be built in here.
# Line 683  Line 862 
862          }          }
863          # Validate the row.          # Validate the row.
864          if (ValidateGeneCorrespondenceRow(\@row)) {          if (ValidateGeneCorrespondenceRow(\@row)) {
865              Trace("Invalid row $. found in correspondence file $fileName.") if T(3);              Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
866              $error = 1;              $error = 1;
867          }          }
868          # If this row is in the correct direction, keep it.          # If this row is in the correct direction, keep it.
# Line 693  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(3);  
         }  
878      }      }
879      # Return the result (if any).      # Return the result (if any).
880      return $retVal;      return $retVal;
# Line 728  Line 903 
903      my ($row) = @_;      my ($row) = @_;
904      # Flip the row in place.      # Flip the row in place.
905      ($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],
906       $row->[6], ARROW_FLIP->{$row->[8]}, $row->[9], $row->[10], $row->[14],       $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
907       $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;
908        # Flip the arrow.
909        $row->[8] = ARROW_FLIP->{$row->[8]};
910        # Flip the pairs.
911        my @elements = split /,/, $row->[3];
912        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
913  }  }
914    
915  =head3 ValidateGeneCorrespondenceRow  =head3 ValidateGeneCorrespondenceRow
# Line 763  Line 943 
943      # Check for non-numeric values in the number columns.      # Check for non-numeric values in the number columns.
944      for my $col (@{NUM_COLS()}) {      for my $col (@{NUM_COLS()}) {
945          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {          unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
946                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
947              $retVal++;              $retVal++;
948          }          }
949      }      }
950      # Check the gene IDs.      # Check the gene IDs.
951      for my $col (0, 1) {      for my $col (0, 1) {
952          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {          unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
953                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
954              $retVal++;              $retVal++;
955          }          }
956      }      }
957      # Verify the arrow.      # Verify the arrow.
958      unless (exists ARROW_FLIP->{$row->[8]}) {      unless (exists ARROW_FLIP->{$row->[8]}) {
959            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
960          $retVal++;          $retVal++;
961      }      }
962      # Return the error count.      # Return the error count.
963      return $retVal;      return $retVal;
964  }  }
965    
966    =head3 GetCorrespondenceData
967    
968        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
969    
970    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
971    list is in a file, it will be read. If the file does not exist, it may be created.
972    
973    =over 4
974    
975    =item genome1
976    
977    ID of the source genome.
978    
979    =item genome2
980    
981    ID of the target genome.
982    
983    =item passive
984    
985    If TRUE, then the correspondence file will not be created if it does not exist.
986    
987    =item full
988    
989    If TRUE, then both directions of the correspondence will be represented; otherwise, only
990    correspondences from the source to the target (including bidirectional corresopndences)
991    will be included.
992    
993    =item RETURN
994    
995    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
996    undefined value if an error occurs or no file exists and passive mode was specified.
997    
998    =back
999    
1000    =cut
1001    
1002    sub GetCorrespondenceData {
1003        # Get the parameters.
1004        my ($genome1, $genome2, $passive, $full) = @_;
1005        # Declare the return variable.
1006        my $retVal;
1007        # Check for a gene correspondence file.
1008        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1009        if ($fileName) {
1010            # Here we found one, so read it in.
1011            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1012        }
1013        # Were we successful?
1014        if (! defined $retVal) {
1015            # Here we either don't have a correspondence file, or the one that's there is
1016            # invalid. If we are NOT in passive mode, then this means we need to create
1017            # the file.
1018            if (! $passive) {
1019                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1020                # Now try reading the new file.
1021                if (defined $fileName) {
1022                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1023                }
1024            }
1025        }
1026        # Return the result.
1027        return $retVal;
1028    
1029    }
1030    
1031    
1032  =head2 Internal Utility Methods  =head2 Internal Utility Methods
1033    
# Line 787  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 796  Line 1044 
1044    
1045  =item cgi  =item cgi
1046    
1047  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
1048    significant parameters are as follows.
1049    
1050    =over 8
1051    
1052    =item function
1053    
1054    Name of the function to run.
1055    
1056    =item args
1057    
1058    Parameters for the function.
1059    
1060    =item encoding
1061    
1062    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1063    by the Java interface).
1064    
1065    =back
1066    
1067    Certain unusual requests can come in outside of the standard function interface.
1068    These are indicated by special parameters that override all the others.
1069    
1070    =over 8
1071    
1072    =item pod
1073    
1074    Display a POD documentation module.
1075    
1076    =item code
1077    
1078    Display an example code file.
1079    
1080    =item file
1081    
1082    Transfer a file (not implemented).
1083    
1084    =back
1085    
1086  =item serverThing  =item serverThing
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 809  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      if ($cgi->param('pod')) {      my $module = $cgi->param('pod');
1105          # Here we have a documentation request. In this case, we produce POD HTML.      if ($module) {
1106            # Here we have a documentation request.
1107            if ($module eq 'ServerScripts') {
1108                # Here we list the server scripts.
1109                require ListServerScripts;
1110                ListServerScripts::main();
1111            } else {
1112                # In this case, we produce POD HTML.
1113          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
1114            }
1115      } elsif ($cgi->param('code')) {      } elsif ($cgi->param('code')) {
1116          # 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.
1117          LineNumberize($cgi->param('code'));          LineNumberize($cgi->param('code'));
# Line 835  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" && ! $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.
1141                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              # Parse the arguments.                  # Here we parse the arguments. This is affected by the encoding parameter.
1153              $args = YAML::Load($cgi->param('args'));                  # Get the argument string.
1154                    my $argString = $cgi->param('args');
1155                    # Only proceed if we found one.
1156                    if ($argString) {
1157                        if ($encoding eq 'yaml') {
1158                            # Parse the arguments using YAML.
1159                            $args = YAML::Load($argString);
1160                        } elsif ($encoding eq 'json') {
1161                            # Parse the arguments using JSON.
1162                            Trace("Incoming string is:\n$argString") if T(3);
1163                            $args = JSON::Any->jsonToObj($argString);
1164                        } else {
1165                            Die("Invalid encoding type $encoding.");
1166                        }
1167                    }
1168          };          };
1169          # Check to make sure we got everything.          # Check to make sure we got everything.
1170          if ($@) {          if ($@) {
# Line 856  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 ($@) {
1184                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
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.                      # 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                  my $string = YAML::Dump($document);                      } else {
1191                            print $cgi->header(-type => 'text/javascript');
1192                        }
1193                        # The nature of the output depends on the encoding type.
1194                        my $string;
1195                        if ($encoding eq 'yaml') {
1196                            $string = YAML::Dump($document);
1197                        } elsif(defined($callback)) {
1198                            $string = $callback . "(".JSON::Any->objToJson($document).")";
1199                        } else {
1200                            $string = JSON::Any->objToJson($document);
1201                        }
1202                  print $string;                  print $string;
1203                  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);
1204              }              }
# Line 874  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 1035  Line 1370 
1370      my ($module) = @_;      my ($module) = @_;
1371      # Start the output page.      # Start the output page.
1372      print CGI::header();      print CGI::header();
1373      print CGI::start_html(-title => 'Documentation Page',      print CGI::start_html(-title => "$module Documentation Page",
1374                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1375      # Protect from errors.      # Protect from errors.
1376      eval {      eval {

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3