[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.28, Thu Dec 10 17:23:23 2009 UTC revision 1.49, Wed Apr 28 14:02:11 2010 UTC
# Line 14  Line 14 
14      no warnings qw(once);      no warnings qw(once);
15    
16      # Maximum number of requests to run per invocation.      # Maximum number of requests to run per invocation.
17      use constant MAX_REQUESTS => 500;      use constant MAX_REQUESTS => 50;
18    
19  =head1 General Server Helper  =head1 General Server Helper
20    
# Line 33  Line 33 
33      # Set up tracing. We never do CGI tracing here; the only question is whether      # Set up tracing. We never do CGI tracing here; the only question is whether
34      # or not the caller passed in a tracing key. If he didn't, we use the server      # or not the caller passed in a tracing key. If he didn't, we use the server
35      # name.      # name.
36      ETracing($key || $serverName);      ETracing($key || $serverName, destType => 'APPEND', level => '0 ServerThing');
37      # Turn off YAML compression, which causes problems with some of our hash keys.      # Turn off YAML compression, which causes problems with some of our hash keys.
38      $YAML::CompressSeries = 0;      $YAML::CompressSeries = 0;
39      # Create the server object.      # Create the server object.
# Line 199  Line 199 
199  sub GetIdList {  sub GetIdList {
200      # Get the parameters.      # Get the parameters.
201      my ($name, $args, $optional) = @_;      my ($name, $args, $optional) = @_;
202      # Try to get the IDs from the argument structure.      # Declare the return variable.
203      my $retVal = $args->{$name};      my $retVal;
204        # Check the argument format.
205        if (! defined $args && $optional) {
206            # Here there are no parameters, but the arguments are optional so it's
207            # okay.
208            $retVal = [];
209        } elsif (ref $args ne 'HASH') {
210            # Here we have an invalid parameter structure.
211            Confess("No '$name' parameter present.");
212        } else {
213            # Here we have a hash with potential parameters in it. Try to get the
214            # IDs from the argument structure.
215            $retVal = $args->{$name};
216      # Was a member found?      # Was a member found?
217      if (! defined $retVal) {      if (! defined $retVal) {
218          # No. If we're optional, return an empty list; otherwise throw an error.          # No. If we're optional, return an empty list; otherwise throw an error.
# Line 210  Line 222 
222              Confess("No '$name' parameter found.");              Confess("No '$name' parameter found.");
223          }          }
224      } else {      } else {
225          # Here we found something. Get the parameter type. We was a list reference.              # Here we found something. Get the parameter type. We want a list reference.
226          # If it's a scalar, we'll convert it to a singleton list. If it's anything          # If it's a scalar, we'll convert it to a singleton list. If it's anything
227          # else, it's an error.          # else, it's an error.
228          my $type = ref $retVal;          my $type = ref $retVal;
# Line 220  Line 232 
232              Confess("The '$name' parameter must be a list.");              Confess("The '$name' parameter must be a list.");
233          }          }
234      }      }
235        }
236      # Return the result.      # Return the result.
237      return $retVal;      return $retVal;
238  }  }
# Line 279  Line 292 
292  }  }
293    
294    
295    =head2 Gene Correspondence File Methods
296    
297    These methods relate to gene correspondence files, which are generated by the
298    L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
299    organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
300    copied into the organism directories themselves. At that point, the code below
301    will be modified to check the organism directories first and use the cache
302    directory if no file is found there.
303    
304    A gene correspondence file contains correspondences from a source genome to a
305    target genome. Most such correspondences are bidirectional best hits. A unidirectional
306    best hit may exist from the source genome to the target genome or in the reverse
307    direction from the targtet genome to the source genome. The cache directory itself
308    is divided into subdirectories by organism. The subdirectory has the source genome
309    name and the files themselves are named by the target genome.
310    
311    Some of the files are invalid and will be erased when they are found. A file is
312    considered invalid if it has a non-numeric value in a numeric column or if it
313    does not have any unidirectional hits from the target genome to the source
314    genome.
315    
316    The process of managing the correspondence files is tricky and dangerous because
317    of the possibility of race conditions. It can take several minutes to generate a
318    file, and if two processes try to generate the same file at the same time we need
319    to make sure they don't step on each other.
320    
321    In stored files, the source genome ID is always lexically lower than the target
322    genome ID. If a correspondence in the reverse direction is desired, the converse
323    file is found and the contents flipped automatically as they are read. So, the
324    correspondence from B<360108.3> to B<100226.1> would be found in a file with the
325    name B<360108.3> in the directory for B<100226.1>. Since this file actually has
326    B<100226.1> as the source and B<360108.3> as the target, the columns are
327    re-ordered and the arrows reversed before the file contents are passed to the
328    caller.
329    
330    =head4 Gene Correspondence List
331    
332    A gene correspondence file contains 18 columns. These are usually packaged as
333    a reference to list of lists. Each sub-list has the following format.
334    
335    =over 4
336    
337    =item 0
338    
339    The ID of a PEG in genome 1.
340    
341    =item 1
342    
343    The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".
344    
345    =item 2
346    
347    Count of the number of pairs of matching genes were found in the context.
348    
349    =item 3
350    
351    Pairs of corresponding genes from the contexts.
352    
353    =item 4
354    
355    The function of the gene in genome 1.
356    
357    =item 5
358    
359    The function of the gene in genome 2.
360    
361    =item 6
362    
363    Comma-separated list of aliases for the gene in genome 1 (any protein with an
364    identical sequence is considered an alias, whether or not it is actually the
365    name of the same gene in the same genome).
366    
367    =item 7
368    
369    Comma-separated list of aliases for the gene in genome 2 (any protein with an
370    identical sequence is considered an alias, whether or not it is actually the
371    name of the same gene in the same genome).
372    
373    =item 8
374    
375    Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.
376    
377    =item 9
378    
379    Percent identity over the region of the detected match.
380    
381    =item 10
382    
383    The P-score for the detected match.
384    
385    =item 11
386    
387    Beginning match coordinate in the protein encoded by the gene in genome 1.
388    
389    =item 12
390    
391    Ending match coordinate in the protein encoded by the gene in genome 1.
392    
393    =item 13
394    
395    Length of the protein encoded by the gene in genome 1.
396    
397    =item 14
398    
399    Beginning match coordinate in the protein encoded by the gene in genome 2.
400    
401    =item 15
402    
403    Ending match coordinate in the protein encoded by the gene in genome 2.
404    
405    =item 16
406    
407    Length of the protein encoded by the gene in genome 2.
408    
409    =item 17
410    
411    Bit score for the match. Divide by the length of the longer PEG to get
412    what we often refer to as a "normalized bit score".
413    
414    =back
415    
416    In the actual files, there will also be reverse correspondences indicated by a
417    back-arrow ("<-") in item (8). The output returned by the servers, however,
418    is filtered so that only forward correspondences occur. If a converse file
419    is used, the columns are re-ordered and the arrows reversed so that it looks
420    correct.
421    
422    =cut
423    
424    # hash for reversing the arrows
425    use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
426    # list of columns that contain numeric values that need to be validated
427    use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];
428    
429    =head3 CheckForGeneCorrespondenceFile
430    
431        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
432    
433    Try to find a gene correspondence file for the specified genome pairing. If the
434    file exists, its name and an indication of whether or not it is in the correct
435    direction will be returned.
436    
437    =over 4
438    
439    =item genome1
440    
441    Source genome for the desired correspondence.
442    
443    =item genome2
444    
445    Target genome for the desired correspondence.
446    
447    =item RETURN
448    
449    Returns a two-element list. The first element is the name of the file containing the
450    correspondence, or C<undef> if the file does not exist. The second element is TRUE
451    if the correspondence would be forward or FALSE if the file needs to be flipped.
452    
453    =back
454    
455    =cut
456    
457    sub CheckForGeneCorrespondenceFile {
458        # Get the parameters.
459        my ($genome1, $genome2) = @_;
460        # Declare the return variables.
461        my ($fileName, $converse);
462        # Determine the ordering of the genome IDs.
463        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
464        $converse = ($genomeA ne $genome1);
465        # Look for a file containing the desired correspondence. (The code to check for a
466        # pre-computed file in the organism directories is currently turned off, because
467        # these files are all currently invalid.)
468        my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
469        if (0 && -f $testFileName) {
470            # Use the pre-computed file.
471            Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
472            $fileName = $testFileName;
473        } elsif (-f $corrFileName) {
474            $fileName = $corrFileName;
475            Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
476        }
477        # Return the result.
478        return ($fileName, $converse);
479    }
480    
481    
482    =head3 ComputeCorrespondenceFileName
483    
484        my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);
485    
486    Compute the name to be given to a genome correspondence file in the organism cache
487    and return the source and target genomes that would be in it.
488    
489    =over 4
490    
491    =item genome1
492    
493    Source genome for the desired correspondence.
494    
495    =item genome2
496    
497    Target genome for the desired correspondence.
498    
499    =item RETURN
500    
501    Returns a three-element list. The first element is the name of the file to contain the
502    correspondence, the second element is the name of the genome that would act as the
503    source genome in the file, and the third element is the name of the genome that would
504    act as the target genome in the file.
505    
506    =back
507    
508    =cut
509    
510    sub ComputeCorrespondenceFileName {
511        # Get the parameters.
512        my ($genome1, $genome2) = @_;
513        # Declare the return variables.
514        my ($fileName, $genomeA, $genomeB);
515        # Determine the ordering of the genome IDs.
516        if (MustFlipGenomeIDs($genome1, $genome2)) {
517            ($genomeA, $genomeB) = ($genome2, $genome1);
518        } else {
519            ($genomeA, $genomeB) = ($genome1, $genome2);
520        }
521        # Insure the source organism has a subdirectory in the organism cache.
522        my $orgDir = ComputeCorrespondenceDirectory($genomeA);
523        # Compute the name of the correspondence file for the appropriate target genome.
524        $fileName = "$orgDir/$genomeB";
525        # Return the results.
526        return ($fileName, $genomeA, $genomeB);
527    }
528    
529    
530    =head3 ComputeCorresopndenceDirectory
531    
532        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
533    
534    Return the name of the directory that would contain the correspondence files
535    for the specified genome.
536    
537    =over 4
538    
539    =item genome
540    
541    ID of the genome whose correspondence file directory is desired.
542    
543    =item RETURN
544    
545    Returns the name of the directory of interest.
546    
547    =back
548    
549    =cut
550    
551    sub ComputeCorrespondenceDirectory {
552        # Get the parameters.
553        my ($genome) = @_;
554        # Insure the source organism has a subdirectory in the organism cache.
555        my $retVal = "$FIG_Config::orgCache/$genome";
556        Tracer::Insure($retVal, 0777);
557        # Return it.
558        return $retVal;
559    }
560    
561    
562    =head3 CreateGeneCorrespondenceFile
563    
564        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
565    
566    Create a new gene correspondence file in the organism cache for the specified
567    genome correspondence. The name of the new file will be returned along with
568    an indicator of whether or not it is in the correct direction.
569    
570    =over 4
571    
572    =item genome1
573    
574    Source genome for the desired correspondence.
575    
576    =item genome2
577    
578    Target genome for the desired correspondence.
579    
580    =item RETURN
581    
582    Returns a two-element list. The first element is the name of the file containing the
583    correspondence, or C<undef> if an error occurred. The second element is TRUE
584    if the correspondence would be forward or FALSE if the file needs to be flipped.
585    
586    =back
587    
588    =cut
589    
590    sub CreateGeneCorrespondenceFile {
591        # Get the parameters.
592        my ($genome1, $genome2) = @_;
593        # Declare the return variables.
594        my ($fileName, $converse);
595        # Compute the ultimate name for the correspondence file.
596        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
597        $converse = ($genome1 ne $genomeA);
598        # Generate a temporary file name in the same directory. We'll build the temporary
599        # file and then rename it when we're done.
600        my $tempFileName = "$corrFileName.$$.tmp";
601        # This will be set to FALSE if we detect an error.
602        my $fileOK = 1;
603        # The file handles will be put in here.
604        my ($ih, $oh);
605        # Protect from errors.
606        eval {
607            # Open the temporary file for output.
608            $oh = Open(undef, ">$tempFileName");
609            # Open a pipe to get the correspondence data.
610            $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
611            Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
612            # Copy the pipe date into the temporary file.
613            while (! eof $ih) {
614                my $line = <$ih>;
615                print $oh $line;
616            }
617            # Close both files. If the close fails we need to know: it means there was a pipe
618            # error.
619            $fileOK &&= close $ih;
620            $fileOK &&= close $oh;
621        };
622        if ($@) {
623            # Here a fatal error of some sort occurred. We need to force the files closed.
624            close $ih if $ih;
625            close $oh if $oh;
626        } elsif ($fileOK) {
627            # Here everything worked. Try to rename the temporary file to the real
628            # file name.
629            if (rename $tempFileName, $corrFileName) {
630                # Everything is ok, fix the permissions and return the file name.
631                chmod 0664, $corrFileName;
632                $fileName = $corrFileName;
633                Trace("Created correspondence file $fileName.") if T(Corr => 3);
634            }
635        }
636        # If the temporary file exists, delete it.
637        if (-f $tempFileName) {
638            unlink $tempFileName;
639        }
640        # Return the results.
641        return ($fileName, $converse);
642    }
643    
644    
645    =head3 MustFlipGenomeIDs
646    
647        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
648    
649    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
650    order, they are stored in the converse order in correspondence files on the server.
651    This is a simple method that allows the caller to check for the need to flip.
652    
653    =over 4
654    
655    =item genome1
656    
657    ID of the proposed source genome.
658    
659    =item genome2
660    
661    ID of the proposed target genome.
662    
663    =item RETURN
664    
665    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
666    it would be stored as a source.
667    
668    =cut
669    
670    sub MustFlipGenomeIDs {
671        # Get the parameters.
672        my ($genome1, $genome2) = @_;
673        # Return an indication.
674        return ($genome1 gt $genome2);
675    }
676    
677    
678    =head3 ReadGeneCorrespondenceFile
679    
680        my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
681    
682    Return the contents of the specified gene correspondence file in the form of
683    a list of lists, with backward correspondences filtered out. If the file is
684    for the converse of the desired correspondence, the columns will be reordered
685    automatically so that it looks as if the file were designed for the proper
686    direction.
687    
688    =over 4
689    
690    =item fileName
691    
692    The name of the gene correspondence file to read.
693    
694    =item converse (optional)
695    
696    TRUE if the file is for the converse of the desired correspondence, else FALSE.
697    If TRUE, the file columns will be reorderd automatically. The default is FALSE,
698    meaning we want to use the file as it appears on disk.
699    
700    =item all (optional)
701    
702    TRUE if backward unidirectional correspondences should be included in the output.
703    The default is FALSE, in which case only forward and bidirectional correspondences
704    are included.
705    
706    =item RETURN
707    
708    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
709    If the file's contents are invalid or an error occurs, an undefined value will be
710    returned.
711    
712    =back
713    
714    =cut
715    
716    sub ReadGeneCorrespondenceFile {
717        # Get the parameters.
718        my ($fileName, $converse, $all) = @_;
719        # Declare the return variable. We will only put something in here if we are
720        # completely successful.
721        my $retVal;
722        # This value will be set to 1 if an error is detected.
723        my $error = 0;
724        # Try to open the file.
725        my $ih;
726        Trace("Reading correspondence file $fileName.") if T(3);
727        if (! open $ih, "<$fileName") {
728            # Here the open failed, so we have an error.
729            Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
730            $error = 1;
731        }
732        # The gene correspondence list will be built in here.
733        my @corrList;
734        # This variable will be set to TRUE if we find a reverse correspondence somewhere
735        # in the file. Not finding one is an error.
736        my $reverseFound = 0;
737        # Loop until we hit the end of the file or an error occurs. We must check the error
738        # first in case the file handle failed to open.
739        while (! $error && ! eof $ih) {
740            # Get the current line.
741            my @row = Tracer::GetLine($ih);
742            # Get the correspondence direction and check for a reverse arrow.
743            $reverseFound = 1 if ($row[8] eq '<-');
744            # If we're in converse mode, reformat the line.
745            if ($converse) {
746                ReverseGeneCorrespondenceRow(\@row);
747            }
748            # Validate the row.
749            if (ValidateGeneCorrespondenceRow(\@row)) {
750                Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
751                $error = 1;
752            }
753            # If this row is in the correct direction, keep it.
754            if ($all || $row[8] ne '<-') {
755                push @corrList, \@row;
756            }
757        }
758        # Close the input file.
759        close $ih;
760        # If we have no errors and we found a reverse arrow, keep the result.
761        if (! $error) {
762            if ($reverseFound) {
763                $retVal = \@corrList;
764            } else {
765                Trace("No reverse arrow found in correspondence file $fileName.") if T(Corr => 1);
766            }
767        }
768        # Return the result (if any).
769        return $retVal;
770    }
771    
772    =head3 ReverseGeneCorrespondenceRow
773    
774        ServerThing::ReverseGeneCorrespondenceRow($row)
775    
776    Convert a gene correspondence row to represent the converse correspondence. The
777    elements in the row will be reordered to represent a correspondence from the
778    target genome to the source genome.
779    
780    =over 4
781    
782    =item row
783    
784    Reference to a list containing a single row from a L</Gene Correspondence List>.
785    
786    =back
787    
788    =cut
789    
790    sub ReverseGeneCorrespondenceRow {
791        # Get the parameters.
792        my ($row) = @_;
793        # Flip the row in place.
794        ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
795         $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
796         $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
797        # Flip the arrow.
798        $row->[8] = ARROW_FLIP->{$row->[8]};
799        # Flip the pairs.
800        my @elements = split /,/, $row->[3];
801        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
802    }
803    
804    =head3 ValidateGeneCorrespondenceRow
805    
806        my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);
807    
808    Validate a gene correspondence row. The numeric fields are checked to insure they
809    are numeric and the source and target gene IDs are validated. The return value will
810    indicate the number of errors found.
811    
812    =over 4
813    
814    =item row
815    
816    Reference to a list containing a single row from a L</Gene Correspondence List>.
817    
818    =item RETURN
819    
820    Returns the number of errors found in the row. A return of C<0> indicates the row
821    is valid.
822    
823    =back
824    
825    =cut
826    
827    sub ValidateGeneCorrespondenceRow {
828        # Get the parameters.
829        my ($row, $genome1, $genome2) = @_;
830        # Denote no errors have been found so far.
831        my $retVal = 0;
832        # Check for non-numeric values in the number columns.
833        for my $col (@{NUM_COLS()}) {
834            unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
835                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
836                $retVal++;
837            }
838        }
839        # Check the gene IDs.
840        for my $col (0, 1) {
841            unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
842                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
843                $retVal++;
844            }
845        }
846        # Verify the arrow.
847        unless (exists ARROW_FLIP->{$row->[8]}) {
848            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
849            $retVal++;
850        }
851        # Return the error count.
852        return $retVal;
853    }
854    
855    
856  =head2 Internal Utility Methods  =head2 Internal Utility Methods
857    
858  The methods in this section are used internally by this package.  The methods in this section are used internally by this package.
# Line 294  Line 868 
868    
869  =item cgi  =item cgi
870    
871  CGI query object containing the parameters from the web service request.  CGI query object containing the parameters from the web service request. The
872    significant parameters are as follows.
873    
874    =over 8
875    
876    =item function
877    
878    Name of the function to run.
879    
880    =item args
881    
882    Parameters for the function.
883    
884    =item encoding
885    
886    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
887    by the Java interface).
888    
889    =back
890    
891    Certain unusual requests can come in outside of the standard function interface.
892    These are indicated by special parameters that override all the others.
893    
894    =over 8
895    
896    =item pod
897    
898    Display a POD documentation module.
899    
900    =item code
901    
902    Display an example code file.
903    
904    =item file
905    
906    Transfer a file (not implemented).
907    
908    =back
909    
910  =item serverThing  =item serverThing
911    
# Line 311  Line 922 
922      if ($cgi->param('pod')) {      if ($cgi->param('pod')) {
923          # Here we have a documentation request. In this case, we produce POD HTML.          # Here we have a documentation request. In this case, we produce POD HTML.
924          ProducePod($cgi->param('pod'));          ProducePod($cgi->param('pod'));
925        } elsif ($cgi->param('code')) {
926            # Here the user wants to see the code for one of our scripts.
927            LineNumberize($cgi->param('code'));
928      } elsif ($cgi->param('file')) {      } elsif ($cgi->param('file')) {
929          # Here we have a file request. Process according to the type.          # Here we have a file request. Process according to the type.
930          my $type = $cgi->param('file');          my $type = $cgi->param('file');
# Line 342  Line 956 
956          my $sapling;          my $sapling;
957          # Protect from errors.          # Protect from errors.
958          eval {          eval {
959              # Parse the arguments.              # Here we parse the arguments. This is affected by the encoding parameter.
960              $args = YAML::Load($cgi->param('args'));              # The default is YAML.
961                my $encoding = $cgi->param('encoding') || 'yaml';
962                # Get the argument string.
963                my $argString = $cgi->param('args');
964                if ($encoding eq 'yaml') {
965                    # Parse the arguments using YAML.
966                    $args = YAML::Load($argString);
967                } elsif ($encoding eq 'json') {
968                    # Parse the arguments using JSON.
969                    require JSON::Any;
970                    $args = JSON::Any->jsonToObj($argString);
971                } else {
972                    Die("Invalid encoding type $encoding.");
973                }
974          };          };
975          # Check to make sure we got everything.          # Check to make sure we got everything.
976          if ($@) {          if ($@) {
# Line 351  Line 978 
978          } elsif (! $function) {          } elsif (! $function) {
979              SendError("No function specified.", "No function specified.");              SendError("No function specified.", "No function specified.");
980          } else {          } else {
981              $document = eval("\$serverThing->$function(\$args)");              $document = eval { $serverThing->$function($args) };
982              # If we have an error, create an error document.              # If we have an error, create an error document.
983              if ($@) {              if ($@) {
984                  SendError($@, "Error detected by service.");                  SendError($@, "Error detected by service.");
985                  Trace("Error encountered by service: $@") if T(2);                  Trace("Error encountered by service: $@") if T(0);
986              } else {              } else {
987                  # No error, so we output the result.                  # No error, so we output the result.
988                  print $cgi->header(-type => 'text/plain');                  print $cgi->header(-type => 'text/plain');
# Line 366  Line 993 
993          }          }
994          # Stop the timer.          # Stop the timer.
995          my $duration = int(time() - $start + 0.5);          my $duration = int(time() - $start + 0.5);
996          Trace("Function executed in $duration seconds by task $$.") if T(2);          Trace("Function $function executed in $duration seconds by task $$.") if T(2);
997      }      }
998  }  }
999    
# Line 462  Line 1089 
1089  }  }
1090    
1091    
1092    =head3 LineNumberize
1093    
1094        ServerThing::LineNumberize($module);
1095    
1096    Output the module line by line with line numbers
1097    
1098    =over 4
1099    
1100    =item module
1101    
1102    Name of the module to line numberized
1103    
1104    =back
1105    
1106    =cut
1107    
1108    sub LineNumberize {
1109        # Get the parameters.
1110        my ($module) = @_;
1111        my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
1112        # Start the output page.
1113        print CGI::header();
1114        print CGI::start_html(-title => 'Documentation Page',
1115                              -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1116        # Protect from errors.
1117        eval {
1118            if (-e $fks_path) {
1119                print "<pre>\n";
1120                my $i = 1;
1121                foreach my $line (`cat $fks_path`) {
1122                    print "$i.\t$line";
1123                    $i++;
1124                }
1125                print "</pre>\n";
1126            } else {
1127                print "File $fks_path not found";
1128            }
1129        };
1130        # Process any error.
1131        if ($@) {
1132            print CGI::blockquote({ class => 'error' }, $@);
1133        }
1134        # Close off the page.
1135        print CGI::end_html();
1136    
1137    }
1138    
1139  =head3 ProducePod  =head3 ProducePod
1140    
1141      ServerThing::ProducePod($module);      ServerThing::ProducePod($module);
# Line 483  Line 1157 
1157      my ($module) = @_;      my ($module) = @_;
1158      # Start the output page.      # Start the output page.
1159      print CGI::header();      print CGI::header();
1160      print CGI::start_html(-title => 'Documentation Page',      print CGI::start_html(-title => "$module Documentation Page",
1161                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });                            -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1162      # Protect from errors.      # Protect from errors.
1163      eval {      eval {
# Line 554  Line 1228 
1228      # Get the parameters.      # Get the parameters.
1229      my ($message, $status) = @_;      my ($message, $status) = @_;
1230      Trace("Error \"$status\" $message") if T(2);      Trace("Error \"$status\" $message") if T(2);
1231        # Check for a DBserver error. These can be retried and get a special status
1232        # code.
1233        my $realStatus;
1234        if ($message =~ /DBServer Error:\s+/) {
1235            $realStatus = "503 $status";
1236        } else {
1237            $realStatus = "500 $status";
1238        }
1239      # Print the header and the status message.      # Print the header and the status message.
1240      print CGI::header(-type => 'text/plain',      print CGI::header(-type => 'text/plain',
1241                        -status => "500 $status");                        -status => $realStatus);
1242      # Print the detailed message.      # Print the detailed message.
1243      print $message;      print $message;
1244  }  }

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3