[Bio] / FigKernelPackages / ServerThing.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.71 - (view) (download) (as text)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3