[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.6, Thu Aug 27 19:44:45 2009 UTC revision 1.72, Thu Mar 17 21:32:30 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;
     use DocUtils;  
11      use Time::HiRes;      use Time::HiRes;
12      use ErrorDocument;      use File::Temp;
13        use ErrorMessage;
14      use CGI;      use CGI;
15        no warnings qw(once);
16    
17        # Maximum number of requests to run per invocation.
18        use constant MAX_REQUESTS => 50;
19    
20  =head1 General Server Helper  =head1 General Server Helper
21    
22  This package provides a method-- I<RunServer>-- that can be called from a CGI  This package provides a method-- I<RunServer>-- that can be called from a CGI
23  script to perform the duties of a FIG server. RunServer is called with three  script to perform the duties of a FIG server. RunServer is called with two
24  parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>),  parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>) and
25  the first command-line parameter, and the URL prefix to use for the documentation.  the first command-line parameter. The command-line parameter (if defined) will
26  The command-line parameter (if defined) will be used as the tracing key, and is  be used as the tracing key, and also indicates that the script is being invoked
27  used to indicate that the script is being invoked from the command line rather  from the command line rather than over the web.
 than over the web.  
28    
29  =cut  =cut
30    
31  sub RunServer {  sub RunServer {
32      # Get the parameters.      # Get the parameters.
33      my ($serverName, $key, $docURL) = @_;      my ($serverName, $key) = @_;
34      # Get the CGI parameters.      # Set up tracing. We never do CGI tracing here; the only question is whether
35        # or not the caller passed in a tracing key. If he didn't, we use the server
36        # name.
37        ETracing($key || $serverName, destType => 'APPEND', level => '0 ServerThing');
38        # Turn off YAML compression, which causes problems with some of our hash keys.
39        $YAML::CompressSeries = 0;
40        # Create the server object.
41        Trace("Requiring $serverName for task $$.") if T(3);
42        eval {
43            my $output = $serverName;
44            $output =~ s/::/\//;
45            require "$output.pm";
46        };
47        # If we have an error, create an error document.
48        if ($@) {
49            SendError($@, "Could not load server module.");
50        } else {
51            # Having successfully loaded the server code, we create the object.
52            my $serverThing = eval("$serverName" . '->new()');
53            Trace("$serverName object created for task $$.") if T(2);
54            # If we have an error, create an error document.
55            if ($@) {
56                SendError($@, "Could not start server.");
57            } else {
58                # 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              # Here we're doing Fast CGI. In this case, the tracing key is the                      # Count the number of requests.
68              # server name.                      my $requests = 0;
69              ETracing($serverName);                      # warn "Starting fast CGI loop.\n"; ##HACK Trace("Starting Fast CGI loop.") if T(3);
70              # Loop through the fast CGI requests.                      # Loop through the fast CGI requests. If we have request throttling,
71                        # we exit after a maximum number of requests has been exceeded.
72              require CGI::Fast;              require CGI::Fast;
73              while ($cgi = new CGI::Fast()) {                      open(SERVER_STDERR, ">&", *STDERR);
74                  RunRequest($cgi, $serverName, $docURL);                      while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
75                               ($cgi = new CGI::Fast())) {
76                            #
77                            # Remap STDERR. Inside here, our STDERR is a tie to a FCGI::Stream
78                            # so we need to save it to keep FCGI happy.
79                            #
80                            *SAVED_STDERR = *STDERR;
81                            *STDERR = *SERVER_STDERR;
82                            my $function = $cgi->param('function') || "<non-functional>"; # (useful if we do tracing in here)
83                            # warn "Function request is $function in task $$.\n"; ##HACK
84                            RunRequest($cgi, $serverThing);
85                            # warn "$requests requests complete in fast CGI task $$.\n"; ##HACK Trace("Request $requests complete in task $$.") if T(3);
86                            *STDERR = *SAVED_STDERR;
87              }              }
88                        # warn "Terminating FastCGI task $$ after $requests requests.\n"; ##HACK Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
89                        close(SERVER_STDERR);
90          } else {          } else {
91              # Here we have a normal web service (non-Fast).              # Here we have a normal web service (non-Fast).
92              my $cgi = CGI->new();              my $cgi = CGI->new();
93              # Check for a source parameter. This gets used as the tracing key.              # Check for a source parameter. This gets used as the tracing key.
94              $key = $cgi->param('source');              $key = $cgi->param('source');
             if (! $key) {  
                 # No source parameter, so do normal setup. Note we turn off  
                 # CGI parameter tracing.  
                 ETracing($cgi, 'noParms');  
             } else {  
                 # Set up tracing using the specified key.  
                 ETracing($key);  
             }  
95              # Run this request.              # Run this request.
96              RunRequest($cgi, $serverName, $docURL);                      RunRequest($cgi, $serverThing);
97          }          }
98      } else {      } else {
99          # We're being invoked from the command line. Use the tracing          # We're being invoked from the command line. Use the tracing
100          # key to find the parm file and create the CGI object from that.          # key to find the parm file and create the CGI object from that.
101          my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");          my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
102          $cgi = CGI->new($ih);          $cgi = CGI->new($ih);
         # Set up tracing using the specified key.  
         ETracing($key);  
103          # Run this request.          # Run this request.
104          RunRequest($cgi, $serverName, $docURL);                  RunRequest($cgi, $serverThing);
105                }
106            }
107      }      }
108  }  }
109    
110    
111  =head3 RunRequest  =head2 Server Utility Methods
112    
113      ServerThing::RunRequest($cgi, $serverName, $docURL);  The methods in this section are utilities of general use to the various
114    server modules.
115    
116  Run a request from the specified server using the incoming CGI parameter  =head3 AddSubsystemFilter
117  object for the parameters.  
118        ServerThing::AddSubsystemFilter(\$filter, $args, $roles);
119    
120    Add subsystem filtering information to the specified query filter clause
121    based on data in the argument hash. The argument hash will be checked for
122    the C<-usable> parameter, which includes or excludes unusuable subsystems,
123    the C<-exclude> parameter, which lists types of subsystems that should be
124    excluded, and the C<-aux> parameter, which filters on auxiliary roles.
125    
126  =over 4  =over 4
127    
128  =item cgi  =item filter
129    
130  CGI query object containing the parameters from the web service request.  Reference to the current filter string. If additional filtering is required,
131    this string will be updated.
132    
133  =item serverName  =item args
134    
135  Name of the server to be used for running the request.  Reference to the parameter hash for the current server call. This hash will
136    be examined for the C<-usable> and C<-exclude> parameters.
137    
138  =item docURL  =item roles
139    
140  URL to be used for a documentation request.  If TRUE, role filtering will be applied. In this case, the default action
141    is to exclude auxiliary roles unless C<-aux> is TRUE.
142    
143  =back  =back
144    
145  =cut  =cut
146    
147  sub RunRequest {  use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
148                                             experimental   => 1,
149                                             private        => 1 };
150    
151    sub AddSubsystemFilter {
152      # Get the parameters.      # Get the parameters.
153      my ($cgi, $serverName, $docURL) = @_;      my ($filter, $args, $roles) = @_;
154      Trace("Running $serverName server request.") if T(3);      # We'll put the new filter stuff in here.
155      # Is this a documentation request?      my @newFilters;
156      my $module = $cgi->param('pod');      # Unless unusable subsystems are desired, we must add a clause to the filter.
157      if ($module) {      # The default is that only usable subsystems are included.
158          # Here we have a documentation request. In this case, we produce POD HTML.      my $usable = 1;
159          # Start the output page.      # This default can be overridden by the "-usable" parameter.
160          print CGI::header();      if (exists $args->{-usable}) {
161          print CGI::start_html(-title => 'Documentation Page',          $usable = $args->{-usable};
                               -style => { src => "$FIG_Config::cgi_url/Html/css/ERDB.css" });  
         # Protect from errors.  
         eval {  
             # We'll format the HTML text in here.  
             my $html = DocUtils::ShowPod($module, $docURL);  
             # Output the POD HTML.  
             print $html;  
         };  
         # Process any error.  
         if ($@) {  
             print CGI::blockquote({ class => 'error' }, $@);  
162          }          }
163          # Close off the page.      # If we're restricting to usable subsystems, add a filter to that effect.
164          print CGI::end_html();      if ($usable) {
165      } else {          push @newFilters, "Subsystem(usable) = 1";
166          # Here we have a function request. Get the function name.      }
167          my $function = $cgi->param('function') || "";      # Check for exclusion filters.
168          Trace("Server function is $function.") if T(3);      my $exclusions = ServerThing::GetIdList(-exclude => $args, 1);
169          # Insure the function name is valid.      for my $exclusion (@$exclusions) {
170          Die("Invalid function name.")          if (! SS_TYPE_EXCLUDE_ITEMS->{$exclusion}) {
171              if $function =~ /\W/;              Confess("Invalid exclusion type \"$exclusion\".");
         # The parameter structure will go in here.  
         my $args;  
         # Start the timer.  
         my $start = time();  
         # The output document goes in here.  
         my $document;  
         # The sapling database goes in here.  
         my $sapling;  
         # Protect from errors.  
         eval {  
             # Parse the arguments.  
             $args = YAML::Load($cgi->param('args'));  
         };  
         # Check to make sure we got everything.  
         if ($@) {  
             $document = ErrorDocument->new('<initialization>', $@);  
         } elsif (! $function) {  
             $document = ErrorDocument->new('<missing>', "No function specified.");  
         } else {  
             # We're okay, so load the server function object.  
             Trace("Requiring $serverName") if T(3);  
             eval {  
                 require "$serverName.pm";  
             };  
             # If we have an error, create an error document.  
             if ($@) {  
                 $document = ErrorDocument->new($function, $@);  
                 Trace("Error loading server module: $@") if T(2);  
             } else {  
                 # Having successfully loaded the server code, we create the object.  
                 my $serverThing = eval("$serverName" . '->new()');  
                 # If we have an error, create an error document.  
                 if ($@) {  
                     $document = ErrorDocument->new($function, $@);  
                     Trace("Error creating server function object: $@") if T(2);  
172                  } else {                  } else {
173                      # No error, so execute the server method.              # Here we have to exclude subsystems of the specified type.
174                      Trace("Executing $function.") if T(2);              push @newFilters, "Subsystem($exclusion) = 0";
                     $document = eval("\$serverThing->$function(\$args)");  
                     # If we have an error, create an error document.  
                     if ($@) {  
                         $document = ErrorDocument->new($function, $@);  
                         Trace("Error encountered by service: $@") if T(2);  
175                      }                      }
176                  }                  }
177        # Check for role filtering.
178        if ($roles) {
179            # Here, we filter out auxiliary roles unless the user requests
180            # them.
181            if (! $args->{-aux}) {
182                push @newFilters, "Includes(auxiliary) = 0"
183              }              }
184          }          }
185          # Stop the timer.      # Do we need to update the incoming filter?
186          my $duration = int(time() - $start + 0.5);      if (@newFilters) {
187          Trace("Function executed in $duration seconds.") if T(2);          # Yes. If the incoming filter is nonempty, push it onto the list
188          # Output the YAML.          # so it gets included in the result.
189          print $cgi->header(-type => 'text/plain');          if ($$filter) {
190          print YAML::Dump($document);              push @newFilters, $$filter;
191            }
192            # Put all the filters together to form the new filter.
193            $$filter = join(" AND ", @newFilters);
194            Trace("Subsystem filter is $$filter.") if T(ServerUtilities => 3);
195      }      }
196  }  }
197    
198    
 =head2 Utility Methods  
   
 The methods in this section are utilities of general use to the various  
 server modules.  
199    
200  =head3 GetIdList  =head3 GetIdList
201    
202      my $ids = ServerThing::GetIdList($name => $args);      my $ids = ServerThing::GetIdList($name => $args, $optional);
203    
204  Get a named list of IDs from an argument structure. If the IDs are  Get a named list of IDs from an argument structure. If the IDs are
205  missing, or are not a list, an error will occur.  missing, or are not a list, an error will occur.
# Line 205  Line 214 
214    
215  Argument structure from which the ID list is to be extracted.  Argument structure from which the ID list is to be extracted.
216    
217    =item optional (optional)
218    
219    If TRUE, then a missing value will not generate an error. Instead, an empty list
220    will be returned. The default is FALSE.
221    
222  =item RETURN  =item RETURN
223    
224  Returns a reference to a list of IDs taken from the argument structure.  Returns a reference to a list of IDs taken from the argument structure.
# Line 215  Line 229 
229    
230  sub GetIdList {  sub GetIdList {
231      # Get the parameters.      # Get the parameters.
232      my ($name, $args) = @_;      my ($name, $args, $optional) = @_;
233      # Try to get the IDs from the argument structure.      # Declare the return variable.
234      my $retVal = $args->{$name};      my $retVal;
235      # Throw an error if no member was found.      # Check the argument format.
236      Confess("No '$name' parameter found.") if ! defined $retVal;      if (! defined $args && $optional) {
237      # Get the parameter type. We was a list reference. If it's a scalar, we'll          # Here there are no parameters, but the arguments are optional so it's
238      # convert it to a singleton list. If it's anything else, it's an error.          # okay.
239            $retVal = [];
240        } elsif (ref $args ne 'HASH') {
241            # Here we have an invalid parameter structure.
242            Confess("No '$name' parameter present.");
243        } else {
244            # Here we have a hash with potential parameters in it. Try to get the
245            # IDs from the argument structure.
246            $retVal = $args->{$name};
247            # Was a member found?
248            if (! defined $retVal) {
249                # No. If we're optional, return an empty list; otherwise throw an error.
250                if ($optional) {
251                    $retVal = [];
252                } else {
253                    Confess("No '$name' parameter found.");
254                }
255            } else {
256                # Here we found something. Get the parameter type. We want a list reference.
257                # If it's a scalar, we'll convert it to a singleton list. If it's anything
258                # else, it's an error.
259      my $type = ref $retVal;      my $type = ref $retVal;
260      if (! $type) {      if (! $type) {
261          $retVal = [$retVal];          $retVal = [$retVal];
262      } elsif ($type ne 'ARRAY') {      } elsif ($type ne 'ARRAY') {
263          Confess("The '$name' parameter must be a list.");          Confess("The '$name' parameter must be a list.");
264      }      }
265            }
266        }
267        # Return the result.
268        return $retVal;
269    }
270    
271    
272    =head3 RunTool
273    
274        ServerThing::RunTool($name => $cmd);
275    
276    Run a command-line tool. A non-zero return value from the tool will cause
277    a fatal error, and the tool's error log will be traced.
278    
279    =over 4
280    
281    =item name
282    
283    Name to give to the tool in the error output.
284    
285    =item cmd
286    
287    Command to use for running the tool. This should be the complete command line.
288    The command should not contain any fancy piping, though it may redirect the
289    standard input and output. The command will be modified by this method to
290    redirect the error output to a temporary file.
291    
292    =back
293    
294    =cut
295    
296    sub RunTool {
297        # Get the parameters.
298        my ($name, $cmd) = @_;
299        # Compute the log file name.
300        my $errorLog = "$FIG_Config::temp/errors$$.log";
301        # Execute the command.
302        Trace("Executing command: $cmd") if T(ServerUtilities => 3);
303        my $res = system("$cmd 2> $errorLog");
304        Trace("Return from $name tool is $res.") if T(ServerUtilities => 3);
305        # Check the result code.
306        if ($res != 0) {
307            # We have an error. If tracing is on, trace it.
308            if (T(ServerUtilities => 1)) {
309                TraceErrorLog($name, $errorLog);
310            }
311            # Delete the error log.
312            unlink $errorLog;
313            # Confess the error.
314            Confess("$name command failed with error code $res.");
315        } else {
316            # Everything worked. Trace the error log if necessary.
317            if (T(ServerUtilities => 3) && -s $errorLog) {
318                TraceErrorLog($name, $errorLog);
319            }
320            # Delete the error log if there is one.
321            unlink $errorLog;
322        }
323    }
324    
325    =head3 ReadCountVector
326    
327        my $vector = ServerThing::ReadCountVector($qh, $field, $rawFlag);
328    
329    Extract a count vector from a query. The query can contain zero or more results,
330    and the vectors in the specified result field of the query must be concatenated
331    together in order. This method is optimized for the case (expected to be most
332    common) where there is only one result.
333    
334    =over 4
335    
336    =item qh
337    
338    Handle for the query from which results are to be extracted.
339    
340    =item field
341    
342    Name of the field containing the count vectors.
343    
344    =item rawFlag
345    
346    TRUE if the vector is to be returned as a raw string, FALSE if it is to be returned
347    as reference to a list of numbers.
348    
349    =item RETURN
350    
351    Returns the desired vector, either encoded as a string or as a reference to a list
352    of numbers.
353    
354    =back
355    
356    =cut
357    
358    sub ReadCountVector {
359        # Get the parameters.
360        my ($qh, $field, $rawFlag) = @_;
361        # Declare the return variable.
362        my $retVal;
363        # Loop through the query results.
364        while (my $resultRow = $qh->Fetch()) {
365            # Get this vector.
366            my ($levelVector) = $resultRow->Value($field, $rawFlag);
367            # Is this the first result?
368            if (! defined $retVal) {
369                # Yes. Assign the result directly.
370                $retVal = $levelVector;
371            } elsif ($rawFlag) {
372                # This is a second result and the vectors are coded as strings.
373                $retVal .= $levelVector;
374            } else {
375                # This is a second result and the vectors are coded as array references.
376                push @$retVal, @$levelVector;
377            }
378        }
379      # Return the result.      # Return the result.
380      return $retVal;      return $retVal;
381  }  }
382    
383    =head3 ChangeDB
384    
385        ServerThing::ChangeDB($thing, $newDbName);
386    
387    Change the sapling database used by this server. The old database will be closed and a
388    new one attached.
389    
390    =over 4
391    
392    =item newDbName
393    
394    Name of the new Sapling database on which this server should operate. If omitted, the
395    default database will be used.
396    
397    =back
398    
399    =cut
400    
401    sub ChangeDB {
402        # Get the parameters.
403        my ($thing, $newDbName) = @_;
404        # Default the db-name if it's not specified.
405        if (! defined $newDbName) {
406            $newDbName = $FIG_Config::saplingDB;
407        }
408        # Check to see if we really need to change.
409        my $oldDB = $thing->{db};
410        if (! defined $oldDB || $oldDB->dbName() ne $newDbName) {
411            # We need a new sapling.
412            require Sapling;
413            my $newDB = Sapling->new(dbName => $newDbName);
414            $thing->{db} = $newDB;
415        }
416    }
417    
418    
419    =head2 Gene Correspondence File Methods
420    
421    These methods relate to gene correspondence files, which are generated by the
422    L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
423    organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
424    copied into the organism directories themselves. At that point, the code below
425    will be modified to check the organism directories first and use the cache
426    directory if no file is found there.
427    
428    A gene correspondence file contains correspondences from a source genome to a
429    target genome. Most such correspondences are bidirectional best hits. A unidirectional
430    best hit may exist from the source genome to the target genome or in the reverse
431    direction from the targtet genome to the source genome. The cache directory itself
432    is divided into subdirectories by organism. The subdirectory has the source genome
433    name and the files themselves are named by the target genome.
434    
435    Some of the files are invalid and will be erased when they are found. A file is
436    considered invalid if it has a non-numeric value in a numeric column or if it
437    does not have any unidirectional hits from the target genome to the source
438    genome.
439    
440    The process of managing the correspondence files is tricky and dangerous because
441    of the possibility of race conditions. It can take several minutes to generate a
442    file, and if two processes try to generate the same file at the same time we need
443    to make sure they don't step on each other.
444    
445    In stored files, the source genome ID is always lexically lower than the target
446    genome ID. If a correspondence in the reverse direction is desired, the converse
447    file is found and the contents flipped automatically as they are read. So, the
448    correspondence from B<360108.3> to B<100226.1> would be found in a file with the
449    name B<360108.3> in the directory for B<100226.1>. Since this file actually has
450    B<100226.1> as the source and B<360108.3> as the target, the columns are
451    re-ordered and the arrows reversed before the file contents are passed to the
452    caller.
453    
454    =head4 Gene Correspondence List
455    
456    A gene correspondence file contains 18 columns. These are usually packaged as
457    a reference to list of lists. Each sub-list has the following format.
458    
459    =over 4
460    
461    =item 0
462    
463    The ID of a PEG in genome 1.
464    
465    =item 1
466    
467    The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".
468    
469    =item 2
470    
471    Count of the number of pairs of matching genes were found in the context.
472    
473    =item 3
474    
475    Pairs of corresponding genes from the contexts.
476    
477    =item 4
478    
479    The function of the gene in genome 1.
480    
481    =item 5
482    
483    The function of the gene in genome 2.
484    
485    =item 6
486    
487    Comma-separated list of aliases for the gene in genome 1 (any protein with an
488    identical sequence is considered an alias, whether or not it is actually the
489    name of the same gene in the same genome).
490    
491    =item 7
492    
493    Comma-separated list of aliases for the gene in genome 2 (any protein with an
494    identical sequence is considered an alias, whether or not it is actually the
495    name of the same gene in the same genome).
496    
497    =item 8
498    
499    Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.
500    
501    =item 9
502    
503    Percent identity over the region of the detected match.
504    
505    =item 10
506    
507    The P-score for the detected match.
508    
509    =item 11
510    
511    Beginning match coordinate in the protein encoded by the gene in genome 1.
512    
513    =item 12
514    
515    Ending match coordinate in the protein encoded by the gene in genome 1.
516    
517    =item 13
518    
519    Length of the protein encoded by the gene in genome 1.
520    
521    =item 14
522    
523    Beginning match coordinate in the protein encoded by the gene in genome 2.
524    
525    =item 15
526    
527    Ending match coordinate in the protein encoded by the gene in genome 2.
528    
529    =item 16
530    
531    Length of the protein encoded by the gene in genome 2.
532    
533    =item 17
534    
535    Bit score for the match. Divide by the length of the longer PEG to get
536    what we often refer to as a "normalized bit score".
537    
538    =item 18 (optional)
539    
540    Clear-correspondence indicator. If present, will be C<1> if the correspondence is a
541    clear bidirectional best hit (no similar candidates) and C<0> otherwise.
542    
543    =back
544    
545    In the actual files, there will also be reverse correspondences indicated by a
546    back-arrow ("<-") in item (8). The output returned by the servers, however,
547    is filtered so that only forward correspondences occur. If a converse file
548    is used, the columns are re-ordered and the arrows reversed so that it looks
549    correct.
550    
551    =cut
552    
553    # hash for reversing the arrows
554    use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
555    # list of columns that contain numeric values that need to be validated
556    use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];
557    
558    =head3 CheckForGeneCorrespondenceFile
559    
560        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
561    
562    Try to find a gene correspondence file for the specified genome pairing. If the
563    file exists, its name and an indication of whether or not it is in the correct
564    direction will be returned.
565    
566    =over 4
567    
568    =item genome1
569    
570    Source genome for the desired correspondence.
571    
572    =item genome2
573    
574    Target genome for the desired correspondence.
575    
576    =item RETURN
577    
578    Returns a two-element list. The first element is the name of the file containing the
579    correspondence, or C<undef> if the file does not exist. The second element is TRUE
580    if the correspondence would be forward or FALSE if the file needs to be flipped.
581    
582    =back
583    
584    =cut
585    
586    sub CheckForGeneCorrespondenceFile {
587        # Get the parameters.
588        my ($genome1, $genome2) = @_;
589        # Declare the return variables.
590        my ($fileName, $converse);
591        # Determine the ordering of the genome IDs.
592        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
593        $converse = ($genomeA ne $genome1);
594        # Look for a file containing the desired correspondence. (The code to check for a
595        # pre-computed file in the organism directories is currently turned off, because
596        # these files are all currently invalid.)
597        my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
598        if (0 && -f $testFileName) {
599            # Use the pre-computed file.
600            Trace("Using pre-computed file $fileName for genome correspondence.") if T(Corr => 3);
601            $fileName = $testFileName;
602        } elsif (-f $corrFileName) {
603            $fileName = $corrFileName;
604            Trace("Using cached file $fileName for genome correspondence.") if T(Corr => 3);
605        }
606        # Return the result.
607        return ($fileName, $converse);
608    }
609    
610    
611    =head3 ComputeCorrespondenceFileName
612    
613        my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);
614    
615    Compute the name to be given to a genome correspondence file in the organism cache
616    and return the source and target genomes that would be in it.
617    
618    =over 4
619    
620    =item genome1
621    
622    Source genome for the desired correspondence.
623    
624    =item genome2
625    
626    Target genome for the desired correspondence.
627    
628    =item RETURN
629    
630    Returns a three-element list. The first element is the name of the file to contain the
631    correspondence, the second element is the name of the genome that would act as the
632    source genome in the file, and the third element is the name of the genome that would
633    act as the target genome in the file.
634    
635    =back
636    
637    =cut
638    
639    sub ComputeCorrespondenceFileName {
640        # Get the parameters.
641        my ($genome1, $genome2) = @_;
642        # Declare the return variables.
643        my ($fileName, $genomeA, $genomeB);
644        # Determine the ordering of the genome IDs.
645        if (MustFlipGenomeIDs($genome1, $genome2)) {
646            ($genomeA, $genomeB) = ($genome2, $genome1);
647        } else {
648            ($genomeA, $genomeB) = ($genome1, $genome2);
649        }
650        # Insure the source organism has a subdirectory in the organism cache.
651        my $orgDir = ComputeCorrespondenceDirectory($genomeA);
652        # Compute the name of the correspondence file for the appropriate target genome.
653        $fileName = "$orgDir/$genomeB";
654        # Return the results.
655        return ($fileName, $genomeA, $genomeB);
656    }
657    
658    
659    =head3 ComputeCorresopndenceDirectory
660    
661        my $dirName = ServerThing::ComputeCorrespondenceDirectory($genome);
662    
663    Return the name of the directory that would contain the correspondence files
664    for the specified genome.
665    
666    =over 4
667    
668    =item genome
669    
670    ID of the genome whose correspondence file directory is desired.
671    
672    =item RETURN
673    
674    Returns the name of the directory of interest.
675    
676    =back
677    
678    =cut
679    
680    sub ComputeCorrespondenceDirectory {
681        # Get the parameters.
682        my ($genome) = @_;
683        # Insure the source organism has a subdirectory in the organism cache.
684        my $retVal = "$FIG_Config::orgCache/$genome";
685        Tracer::Insure($retVal, 0777);
686        # Return it.
687        return $retVal;
688    }
689    
690    
691    =head3 CreateGeneCorrespondenceFile
692    
693        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
694    
695    Create a new gene correspondence file in the organism cache for the specified
696    genome correspondence. The name of the new file will be returned along with
697    an indicator of whether or not it is in the correct direction.
698    
699    =over 4
700    
701    =item genome1
702    
703    Source genome for the desired correspondence.
704    
705    =item genome2
706    
707    Target genome for the desired correspondence.
708    
709    =item RETURN
710    
711    Returns a two-element list. The first element is the name of the file containing the
712    correspondence, or C<undef> if an error occurred. The second element is TRUE
713    if the correspondence would be forward or FALSE if the file needs to be flipped.
714    
715    =back
716    
717    =cut
718    
719    sub CreateGeneCorrespondenceFile {
720        # Get the parameters.
721        my ($genome1, $genome2) = @_;
722        # Declare the return variables.
723        my ($fileName, $converse);
724        # Compute the ultimate name for the correspondence file.
725        my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
726        $converse = ($genome1 ne $genomeA);
727        # Generate a temporary file name in the same directory. We'll build the temporary
728        # file and then rename it when we're done.
729        my $tempFileName = "$corrFileName.$$.tmp";
730        # This will be set to FALSE if we detect an error.
731        my $fileOK = 1;
732        # The file handles will be put in here.
733        my ($ih, $oh);
734        # Protect from errors.
735        eval {
736            # Open the temporary file for output.
737            $oh = Open(undef, ">$tempFileName");
738            # Open a pipe to get the correspondence data.
739            $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
740            Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
741            # Copy the pipe date into the temporary file.
742            while (! eof $ih) {
743                my $line = <$ih>;
744                print $oh $line;
745            }
746            # Close both files. If the close fails we need to know: it means there was a pipe
747            # error.
748            $fileOK &&= close $ih;
749            $fileOK &&= close $oh;
750        };
751        if ($@) {
752            # Here a fatal error of some sort occurred. We need to force the files closed.
753            close $ih if $ih;
754            close $oh if $oh;
755        } elsif ($fileOK) {
756            # Here everything worked. Try to rename the temporary file to the real
757            # file name.
758            if (rename $tempFileName, $corrFileName) {
759                # Everything is ok, fix the permissions and return the file name.
760                chmod 0664, $corrFileName;
761                $fileName = $corrFileName;
762                Trace("Created correspondence file $fileName.") if T(Corr => 3);
763            }
764        }
765        # If the temporary file exists, delete it.
766        if (-f $tempFileName) {
767            unlink $tempFileName;
768        }
769        # Return the results.
770        return ($fileName, $converse);
771    }
772    
773    
774    =head3 MustFlipGenomeIDs
775    
776        my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
777    
778    Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
779    order, they are stored in the converse order in correspondence files on the server.
780    This is a simple method that allows the caller to check for the need to flip.
781    
782    =over 4
783    
784    =item genome1
785    
786    ID of the proposed source genome.
787    
788    =item genome2
789    
790    ID of the proposed target genome.
791    
792    =item RETURN
793    
794    Returns TRUE if the first genome would be stored on the server as a target, FALSE if
795    it would be stored as a source.
796    
797    =back
798    
799    =cut
800    
801    sub MustFlipGenomeIDs {
802        # Get the parameters.
803        my ($genome1, $genome2) = @_;
804        # Return an indication.
805        return ($genome1 gt $genome2);
806    }
807    
808    
809    =head3 ReadGeneCorrespondenceFile
810    
811        my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
812    
813    Return the contents of the specified gene correspondence file in the form of
814    a list of lists, with backward correspondences filtered out. If the file is
815    for the converse of the desired correspondence, the columns will be reordered
816    automatically so that it looks as if the file were designed for the proper
817    direction.
818    
819    =over 4
820    
821    =item fileName
822    
823    The name of the gene correspondence file to read.
824    
825    =item converse (optional)
826    
827    TRUE if the file is for the converse of the desired correspondence, else FALSE.
828    If TRUE, the file columns will be reorderd automatically. The default is FALSE,
829    meaning we want to use the file as it appears on disk.
830    
831    =item all (optional)
832    
833    TRUE if backward unidirectional correspondences should be included in the output.
834    The default is FALSE, in which case only forward and bidirectional correspondences
835    are included.
836    
837    =item RETURN
838    
839    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
840    If the file's contents are invalid or an error occurs, an undefined value will be
841    returned.
842    
843    =back
844    
845    =cut
846    
847    sub ReadGeneCorrespondenceFile {
848        # Get the parameters.
849        my ($fileName, $converse, $all) = @_;
850        # Declare the return variable. We will only put something in here if we are
851        # completely successful.
852        my $retVal;
853        # This value will be set to 1 if an error is detected.
854        my $error = 0;
855        # Try to open the file.
856        my $ih;
857        Trace("Reading correspondence file $fileName.") if T(3);
858        if (! open $ih, "<$fileName") {
859            # Here the open failed, so we have an error.
860            Trace("Failed to open gene correspondence file $fileName: $!") if T(Corr => 1);
861            $error = 1;
862        }
863        # The gene correspondence list will be built in here.
864        my @corrList;
865        # This variable will be set to TRUE if we find a reverse correspondence somewhere
866        # in the file. Not finding one is an error.
867        my $reverseFound = 0;
868        # Loop until we hit the end of the file or an error occurs. We must check the error
869        # first in case the file handle failed to open.
870        while (! $error && ! eof $ih) {
871            # Get the current line.
872            my @row = Tracer::GetLine($ih);
873            # Get the correspondence direction and check for a reverse arrow.
874            $reverseFound = 1 if ($row[8] eq '<-');
875            # If we're in converse mode, reformat the line.
876            if ($converse) {
877                ReverseGeneCorrespondenceRow(\@row);
878            }
879            # Validate the row.
880            if (ValidateGeneCorrespondenceRow(\@row)) {
881                Trace("Invalid row $. found in correspondence file $fileName.") if T(Corr => 1);
882                $error = 1;
883            }
884            # If this row is in the correct direction, keep it.
885            if ($all || $row[8] ne '<-') {
886                push @corrList, \@row;
887            }
888        }
889        # Close the input file.
890        close $ih;
891        # If we have no errors, keep the result.
892        if (! $error) {
893            $retVal = \@corrList;
894        }
895        # Return the result (if any).
896        return $retVal;
897    }
898    
899    =head3 ReverseGeneCorrespondenceRow
900    
901        ServerThing::ReverseGeneCorrespondenceRow($row)
902    
903    Convert a gene correspondence row to represent the converse correspondence. The
904    elements in the row will be reordered to represent a correspondence from the
905    target genome to the source genome.
906    
907    =over 4
908    
909    =item row
910    
911    Reference to a list containing a single row from a L</Gene Correspondence List>.
912    
913    =back
914    
915    =cut
916    
917    sub ReverseGeneCorrespondenceRow {
918        # Get the parameters.
919        my ($row) = @_;
920        # Flip the row in place.
921        ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
922         $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
923         $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
924        # Flip the arrow.
925        $row->[8] = ARROW_FLIP->{$row->[8]};
926        # Flip the pairs.
927        my @elements = split /,/, $row->[3];
928        $row->[3] = join(",", map { join(":", reverse split /:/, $_) } @elements);
929    }
930    
931    =head3 ValidateGeneCorrespondenceRow
932    
933        my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);
934    
935    Validate a gene correspondence row. The numeric fields are checked to insure they
936    are numeric and the source and target gene IDs are validated. The return value will
937    indicate the number of errors found.
938    
939    =over 4
940    
941    =item row
942    
943    Reference to a list containing a single row from a L</Gene Correspondence List>.
944    
945    =item RETURN
946    
947    Returns the number of errors found in the row. A return of C<0> indicates the row
948    is valid.
949    
950    =back
951    
952    =cut
953    
954    sub ValidateGeneCorrespondenceRow {
955        # Get the parameters.
956        my ($row, $genome1, $genome2) = @_;
957        # Denote no errors have been found so far.
958        my $retVal = 0;
959        # Check for non-numeric values in the number columns.
960        for my $col (@{NUM_COLS()}) {
961            unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
962                Trace("Gene correspondence error. \"$row->[$col]\" not numeric.") if T(Corr => 2);
963                $retVal++;
964            }
965        }
966        # Check the gene IDs.
967        for my $col (0, 1) {
968            unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
969                Trace("Gene correspondence error. \"$row->[$col]\" not a gene ID.") if T(Corr => 2);
970                $retVal++;
971            }
972        }
973        # Verify the arrow.
974        unless (exists ARROW_FLIP->{$row->[8]}) {
975            Trace("Gene correspondence error. \"$row->[8]\" not an arrow.") if T(Corr => 2);
976            $retVal++;
977        }
978        # Return the error count.
979        return $retVal;
980    }
981    
982    =head3 GetCorrespondenceData
983    
984        my $corrList = ServerThing::GetCorrespondenceData($genome1, $genome2, $passive, $full);
985    
986    Return the L</Gene Correspondence List> for the specified source and target genomes. If the
987    list is in a file, it will be read. If the file does not exist, it may be created.
988    
989    =over 4
990    
991    =item genome1
992    
993    ID of the source genome.
994    
995    =item genome2
996    
997    ID of the target genome.
998    
999    =item passive
1000    
1001    If TRUE, then the correspondence file will not be created if it does not exist.
1002    
1003    =item full
1004    
1005    If TRUE, then both directions of the correspondence will be represented; otherwise, only
1006    correspondences from the source to the target (including bidirectional corresopndences)
1007    will be included.
1008    
1009    =item RETURN
1010    
1011    Returns a L</Gene Correspondence List> in the form of a reference to a list of lists, or an
1012    undefined value if an error occurs or no file exists and passive mode was specified.
1013    
1014    =back
1015    
1016    =cut
1017    
1018    sub GetCorrespondenceData {
1019        # Get the parameters.
1020        my ($genome1, $genome2, $passive, $full) = @_;
1021        # Declare the return variable.
1022        my $retVal;
1023        # Check for a gene correspondence file.
1024        my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
1025        if ($fileName) {
1026            # Here we found one, so read it in.
1027            $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $full);
1028        }
1029        # Were we successful?
1030        if (! defined $retVal) {
1031            # Here we either don't have a correspondence file, or the one that's there is
1032            # invalid. If we are NOT in passive mode, then this means we need to create
1033            # the file.
1034            if (! $passive) {
1035                ($fileName, $converse) = ServerThing::CreateGeneCorrespondenceFile($genome1, $genome2);
1036                # Now try reading the new file.
1037                if (defined $fileName) {
1038                    $retVal = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse);
1039                }
1040            }
1041        }
1042        # Return the result.
1043        return $retVal;
1044    
1045    }
1046    
1047    
1048    =head2 Internal Utility Methods
1049    
1050    The methods in this section are used internally by this package.
1051    
1052    =head3 RunRequest
1053    
1054        ServerThing::RunRequest($cgi, $serverThing, $docURL);
1055    
1056    Run a request from the specified server using the incoming CGI parameter
1057    object for the parameters.
1058    
1059    =over 4
1060    
1061    =item cgi
1062    
1063    CGI query object containing the parameters from the web service request. The
1064    significant parameters are as follows.
1065    
1066    =over 8
1067    
1068    =item function
1069    
1070    Name of the function to run.
1071    
1072    =item args
1073    
1074    Parameters for the function.
1075    
1076    =item encoding
1077    
1078    Encoding scheme for the function parameters, either C<yaml> (the default) or C<json> (used
1079    by the Java interface).
1080    
1081    =back
1082    
1083    Certain unusual requests can come in outside of the standard function interface.
1084    These are indicated by special parameters that override all the others.
1085    
1086    =over 8
1087    
1088    =item pod
1089    
1090    Display a POD documentation module.
1091    
1092    =item code
1093    
1094    Display an example code file.
1095    
1096    =item file
1097    
1098    Transfer a file (not implemented).
1099    
1100    =back
1101    
1102    =item serverThing
1103    
1104    Server object against which to run the request.
1105    
1106    =item docURL
1107    
1108    URL to use for POD documentation requests.
1109    
1110    =back
1111    
1112    =cut
1113    
1114    sub RunRequest {
1115        # Get the parameters.
1116        my ($cgi, $serverThing, $docURL) = @_;
1117        # Make the CGI object available to the server.
1118        $serverThing->{cgi} = $cgi;
1119        # Determine the request type.
1120        my $module = $cgi->param('pod');
1121        if ($module) {
1122            # Here we have a documentation request.
1123            if ($module eq 'ServerScripts') {
1124                # Here we list the server scripts.
1125                require ListServerScripts;
1126                ListServerScripts::main();
1127            } else {
1128                # In this case, we produce POD HTML.
1129                ProducePod($cgi->param('pod'));
1130            }
1131        } elsif ($cgi->param('code')) {
1132            # Here the user wants to see the code for one of our scripts.
1133            LineNumberize($cgi->param('code'));
1134        } elsif ($cgi->param('file')) {
1135            # Here we have a file request. Process according to the type.
1136            my $type = $cgi->param('file');
1137            if ($type eq 'open') {
1138                OpenFile($cgi->param('name'));
1139            } elsif ($type eq 'create') {
1140                CreateFile();
1141            } elsif ($type eq 'read') {
1142                ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
1143            } elsif ($type eq 'write') {
1144                WriteChunk($cgi->param('name'), $cgi->param('data'));
1145            } else {
1146                Die("Invalid file function \"$type\".");
1147            }
1148        } else {
1149            # The default is a function request. Get the function name.
1150            my $function = $cgi->param('function') || "";
1151            Trace("Server function for task $$ is $function.") if T(3);
1152            # Insure the function name is valid.
1153            if ($function ne "methods" && exists $serverThing->{methods} && ! $serverThing->{methods}{$function}) {
1154                SendError("Invalid function name.", "$function not found.")
1155            } else {
1156                # Determing the encoding scheme. The default is YAML.
1157                my $encoding = $cgi->param('encoding') || 'yaml';
1158                # Optional callback for json encoded documents
1159                my $callback = $cgi->param('callback');
1160                # The parameter structure will go in here.
1161                my $args = {};
1162                # Start the timer.
1163                my $start = time();
1164                # The output document goes in here.
1165                my $document;
1166                # Protect from errors.
1167                eval {
1168                    # Here we parse the arguments. This is affected by the encoding parameter.
1169                    # Get the argument string.
1170                    my $argString = $cgi->param('args');
1171                    # Only proceed if we found one.
1172                    if ($argString) {
1173                        if ($encoding eq 'yaml') {
1174                            # Parse the arguments using YAML.
1175                            $args = YAML::Load($argString);
1176                        } elsif ($encoding eq 'json') {
1177                            # Parse the arguments using JSON.
1178                            Trace("Incoming string is:\n$argString") if T(3);
1179                            $args = JSON::Any->jsonToObj($argString);
1180                        } else {
1181                            Die("Invalid encoding type $encoding.");
1182                        }
1183                    }
1184                };
1185                # Check to make sure we got everything.
1186                if ($@) {
1187                    SendError($@, "Error formatting parameters.");
1188                } elsif (! $function) {
1189                    SendError("No function specified.", "No function specified.");
1190                } else {
1191                    # Insure we're connected to the correct database.
1192                    my $dbName = $cgi->param('dbName');
1193                    if ($dbName && exists $serverThing->{db}) {
1194                        ChangeDB($serverThing, $dbName);
1195                    }
1196                    # Run the request.
1197                    $document = eval { $serverThing->$function($args) };
1198                    # If we have an error, create an error document.
1199                    if ($@) {
1200                        SendError($@, "Error detected by service.");
1201                        Trace("Error encountered by service: $@") if T(0);
1202                    } else {
1203                        # No error, so we output the result. Start with an HTML header.
1204                        if ($encoding eq 'yaml') {
1205                            print $cgi->header(-type => 'text/plain');
1206                        } else {
1207                            print $cgi->header(-type => 'text/javascript');
1208                        }
1209                        # The nature of the output depends on the encoding type.
1210                        eval {
1211                            my $string;
1212                            if ($encoding eq 'yaml') {
1213                                $string = YAML::Dump($document);
1214                            } elsif(defined($callback)) {
1215                                $string = $callback . "(".JSON::Any->objToJson($document).")";
1216                            } else {
1217                                $string = JSON::Any->objToJson($document);
1218                            }
1219                            print $string;
1220                            MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
1221                        };
1222                        if ($@) {
1223                            SendError($@, "Error encoding result.");
1224                            Trace("Error encoding result: $@") if T(0);
1225                        }
1226                    }
1227                }
1228                # Stop the timer.
1229                my $duration = int(time() - $start + 0.5);
1230                Trace("Function $function executed in $duration seconds by task $$.") if T(2);
1231            }
1232        }
1233    }
1234    
1235    =head3 CreateFile
1236    
1237        ServerThing::CreateFile();
1238    
1239    Create a new, empty temporary file and send its name back to the client.
1240    
1241    =cut
1242    
1243    sub CreateFile {
1244        ##TODO: Code
1245    }
1246    
1247    =head3 OpenFile
1248    
1249        ServerThing::OpenFile($name);
1250    
1251    Send the length of the named file back to the client.
1252    
1253    =over 4
1254    
1255    =item name
1256    
1257    ##TODO: name description
1258    
1259    =back
1260    
1261    =cut
1262    
1263    sub OpenFile {
1264        # Get the parameters.
1265        my ($name) = @_;
1266        ##TODO: Code
1267    }
1268    
1269    =head3 ReadChunk
1270    
1271        ServerThing::ReadChunk($name, $location, $size);
1272    
1273    Read the indicated number of bytes from the specified location of the
1274    named file and send them back to the client.
1275    
1276    =over 4
1277    
1278    =item name
1279    
1280    ##TODO: name description
1281    
1282    =item location
1283    
1284    ##TODO: location description
1285    
1286    =item size
1287    
1288    ##TODO: size description
1289    
1290    =back
1291    
1292    =cut
1293    
1294    sub ReadChunk {
1295        # Get the parameters.
1296        my ($name, $location, $size) = @_;
1297        ##TODO: Code
1298    }
1299    
1300    =head3 WriteChunk
1301    
1302        ServerThing::WriteChunk($name, $data);
1303    
1304    Write the specified data to the named file.
1305    
1306    =over 4
1307    
1308    =item name
1309    
1310    ##TODO: name description
1311    
1312    =item data
1313    
1314    ##TODO: data description
1315    
1316    =back
1317    
1318    =cut
1319    
1320    sub WriteChunk {
1321        # Get the parameters.
1322        my ($name, $data) = @_;
1323        ##TODO: Code
1324    }
1325    
1326    
1327    =head3 LineNumberize
1328    
1329        ServerThing::LineNumberize($module);
1330    
1331    Output the module line by line with line numbers
1332    
1333    =over 4
1334    
1335    =item module
1336    
1337    Name of the module to line numberized
1338    
1339    =back
1340    
1341    =cut
1342    
1343    sub LineNumberize {
1344        # Get the parameters.
1345        my ($module) = @_;
1346        my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
1347        # Start the output page.
1348        print CGI::header();
1349        print CGI::start_html(-title => 'Documentation Page',
1350                              -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1351        # Protect from errors.
1352        eval {
1353            if (-e $fks_path) {
1354                print "<pre>\n";
1355                my $i = 1;
1356                foreach my $line (`cat $fks_path`) {
1357                    print "$i.\t$line";
1358                    $i++;
1359                }
1360                print "</pre>\n";
1361            } else {
1362                print "File $fks_path not found";
1363            }
1364        };
1365        # Process any error.
1366        if ($@) {
1367            print CGI::blockquote({ class => 'error' }, $@);
1368        }
1369        # Close off the page.
1370        print CGI::end_html();
1371    
1372    }
1373    
1374    =head3 ProducePod
1375    
1376        ServerThing::ProducePod($module);
1377    
1378    Output the POD documentation for the specified module.
1379    
1380    =over 4
1381    
1382    =item module
1383    
1384    Name of the module whose POD document is to be displayed.
1385    
1386    =back
1387    
1388    =cut
1389    
1390    sub ProducePod {
1391        # Get the parameters.
1392        my ($module) = @_;
1393        # Start the output page.
1394        print CGI::header();
1395        print CGI::start_html(-title => "$module Documentation Page",
1396                              -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1397        # Protect from errors.
1398        eval {
1399            # We'll format the HTML text in here.
1400            require DocUtils;
1401            my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
1402            # Output the POD HTML.
1403            print $html;
1404        };
1405        # Process any error.
1406        if ($@) {
1407            print CGI::blockquote({ class => 'error' }, $@);
1408        }
1409        # Close off the page.
1410        print CGI::end_html();
1411    
1412    }
1413    
1414    =head3 TraceErrorLog
1415    
1416        ServerThing::TraceErrorLog($name, $errorLog);
1417    
1418    Trace the specified error log file. This is a very dinky routine that
1419    performs a task required by L</RunTool> in multiple places.
1420    
1421    =over 4
1422    
1423    =item name
1424    
1425    Name of the tool relevant to the log file.
1426    
1427    =item errorLog
1428    
1429    Name of the log file.
1430    
1431    =back
1432    
1433    =cut
1434    
1435    sub TraceErrorLog {
1436        my ($name, $errorLog) = @_;
1437        my $errorData = Tracer::GetFile($errorLog);
1438        Trace("$name error log:\n$errorData");
1439    }
1440    
1441    =head3 SendError
1442    
1443        ServerThing::SendError($message, $status);
1444    
1445    Fail an HTTP request with the specified error message and the specified
1446    status message.
1447    
1448    =over 4
1449    
1450    =item message
1451    
1452    Detailed error message. This is sent as the page content.
1453    
1454    =item status
1455    
1456    Status message. This is sent as part of the status code.
1457    
1458    =back
1459    
1460    =cut
1461    
1462    sub SendError {
1463        # Get the parameters.
1464        my ($message, $status) = @_;
1465        Trace("Error \"$status\" $message") if T(2);
1466        # Check for a DBserver error. These can be retried and get a special status
1467        # code.
1468        my $realStatus;
1469        if ($message =~ /DBServer Error:\s+/) {
1470            $realStatus = "503 $status";
1471        } else {
1472            $realStatus = "500 $status";
1473        }
1474        # Print the header and the status message.
1475        print CGI::header(-type => 'text/plain',
1476                          -status => $realStatus);
1477        # Print the detailed message.
1478        print $message;
1479    }
1480    
1481    
1482    =head3 Log
1483    
1484        Log($msg);
1485    
1486    Write a message to the log. This is a temporary hack until we can figure out how to get
1487    normal tracing and error logging working.
1488    
1489    =over 4
1490    
1491    =item msg
1492    
1493    Message to write. It will be appended to the C<servers.log> file in the FIG temporary directory.
1494    
1495    =back
1496    
1497    =cut
1498    
1499    sub Log {
1500        # Get the parameters.
1501        my ($msg) = @_;
1502        # Open the log file for appending.
1503        open(my $oh, ">>$FIG_Config::temp/servers.log") || Confess("Log error: $!");
1504        print $oh "$msg\n";
1505        close $oh;
1506    }
1507    
1508  1;  1;

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.72

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3