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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.41 - (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 :     use ERDB;
9 :     use TestUtils;
10 :     use Time::HiRes;
11 : parrello 1.9 use File::Temp;
12 : parrello 1.10 use ErrorMessage;
13 : parrello 1.1 use CGI;
14 : parrello 1.9 no warnings qw(once);
15 : parrello 1.1
16 : parrello 1.11 # Maximum number of requests to run per invocation.
17 : parrello 1.29 use constant MAX_REQUESTS => 5000;
18 : parrello 1.11
19 : parrello 1.1 =head1 General Server Helper
20 :    
21 :     This package provides a method-- I<RunServer>-- that can be called from a CGI
22 : parrello 1.9 script to perform the duties of a FIG server. RunServer is called with two
23 :     parameters: the name of the server package (e.g. C<SAP> for B<SAP.pm>) and
24 :     the first command-line parameter. The command-line parameter (if defined) will
25 :     be used as the tracing key, and also indicates that the script is being invoked
26 :     from the command line rather than over the web.
27 : parrello 1.1
28 :     =cut
29 :    
30 :     sub RunServer {
31 :     # Get the parameters.
32 : parrello 1.9 my ($serverName, $key) = @_;
33 : parrello 1.25 # Set up tracing. We never do CGI tracing here; the only question is whether
34 :     # or not the caller passed in a tracing key. If he didn't, we use the server
35 :     # name.
36 : parrello 1.32 ETracing($key || $serverName, destType => 'APPEND', level => '0 ServerThing');
37 : parrello 1.9 # Turn off YAML compression, which causes problems with some of our hash keys.
38 :     $YAML::CompressSeries = 0;
39 : parrello 1.13 # Create the server object.
40 : parrello 1.15 Trace("Requiring $serverName for task $$.") if T(3);
41 : parrello 1.13 eval {
42 :     require "$serverName.pm";
43 :     };
44 :     # If we have an error, create an error document.
45 :     if ($@) {
46 :     SendError($@, "Could not load server module.");
47 :     } else {
48 :     # Having successfully loaded the server code, we create the object.
49 :     my $serverThing = eval("$serverName" . '->new()');
50 : parrello 1.15 Trace("$serverName object created for task $$.") if T(2);
51 : parrello 1.13 # If we have an error, create an error document.
52 :     if ($@) {
53 :     SendError($@, "Could not start server.");
54 : parrello 1.3 } else {
55 : parrello 1.13 # No error, so now we can process the request.
56 :     my $cgi;
57 :     if (! defined $key) {
58 :     # No tracing key, so presume we're a web service. Check for Fast CGI.
59 :     if ($ENV{REQUEST_METHOD} eq '') {
60 :     # Count the number of requests.
61 :     my $requests = 0;
62 : parrello 1.24 Trace("Starting Fast CGI loop.") if T(3);
63 : parrello 1.13 # Loop through the fast CGI requests. If we have request throttling,
64 :     # we exit after a maximum number of requests has been exceeded.
65 :     require CGI::Fast;
66 : parrello 1.23 while ((MAX_REQUESTS == 0 || ++$requests < MAX_REQUESTS) &&
67 :     ($cgi = new CGI::Fast())) {
68 : parrello 1.13 RunRequest($cgi, $serverThing);
69 : parrello 1.16 Trace("Request $requests complete in task $$.") if T(3);
70 : parrello 1.13 }
71 : parrello 1.15 Trace("Terminating FastCGI task $$ after $requests requests.") if T(2);
72 : parrello 1.13 } else {
73 :     # Here we have a normal web service (non-Fast).
74 :     my $cgi = CGI->new();
75 :     # Check for a source parameter. This gets used as the tracing key.
76 :     $key = $cgi->param('source');
77 :     # Run this request.
78 :     RunRequest($cgi, $serverThing);
79 :     }
80 : parrello 1.6 } else {
81 : parrello 1.13 # We're being invoked from the command line. Use the tracing
82 :     # key to find the parm file and create the CGI object from that.
83 :     my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
84 :     $cgi = CGI->new($ih);
85 :     # Run this request.
86 :     RunRequest($cgi, $serverThing);
87 : parrello 1.6 }
88 : parrello 1.3 }
89 : parrello 1.1 }
90 : parrello 1.6 }
91 :    
92 :    
93 : parrello 1.9 =head2 Server Utility Methods
94 :    
95 :     The methods in this section are utilities of general use to the various
96 :     server modules.
97 :    
98 : parrello 1.21 =head3 AddSubsystemFilter
99 :    
100 :     ServerThing::AddSubsystemFilter(\$filter, $args);
101 :    
102 :     Add subsystem filtering information to the specified query filter clause
103 :     based on data in the argument hash. The argument hash will be checked for
104 : parrello 1.22 the C<-usable> parameter, which includes or excludes unusuable subsystems, and
105 :     the C<-exclude> parameter, which lists types of subsystems that should be
106 : parrello 1.21 excluded.
107 :    
108 :     =over 4
109 :    
110 :     =item filter
111 :    
112 :     Reference to the current filter string. If additional filtering is required,
113 :     this string will be updated.
114 :    
115 :     =item args
116 :    
117 :     Reference to the parameter hash for the current server call. This hash will
118 : parrello 1.22 be examined for the C<-usable> and C<-exclude> parameters.
119 : parrello 1.21
120 :     =back
121 :    
122 :     =cut
123 :    
124 :     use constant SS_TYPE_EXCLUDE_ITEMS => { 'cluster-based' => 1,
125 :     experimental => 1,
126 :     private => 1 };
127 :    
128 :     sub AddSubsystemFilter {
129 :     # Get the parameters.
130 :     my ($filter, $args) = @_;
131 :     # We'll put the new filter stuff in here.
132 :     my @newFilters;
133 :     # Unless unusable subsystems are desired, we must add a clause to the filter.
134 : parrello 1.22 # The default is that only usable subsystems are included.
135 :     my $usable = 1;
136 :     # This default can be overridden by the "-usable" parameter.
137 :     if (exists $args->{-usable}) {
138 :     $usable = $args->{-usable};
139 :     }
140 :     # If we're restricting to usable subsystems, add a filter to that effect.
141 :     if ($usable) {
142 : parrello 1.21 push @newFilters, "Subsystem(usable) = 1";
143 :     }
144 :     # Check for exclusion filters.
145 :     my $exclusions = ServerThing::GetIdList(-exclude => $args, 1);
146 :     for my $exclusion (@$exclusions) {
147 :     if (! SS_TYPE_EXCLUDE_ITEMS->{$exclusion}) {
148 :     Confess("Invalid exclusion type \"$exclusion\".");
149 :     } else {
150 :     # Here we have to exclude subsystems of the specified type.
151 :     push @newFilters, "Subsystem($exclusion) = 0";
152 :     }
153 :     }
154 :     # Do we need to update the incoming filter?
155 :     if (@newFilters) {
156 :     # Yes. If the incoming filter is nonempty, push it onto the list
157 :     # so it gets included in the result.
158 :     if ($$filter) {
159 :     push @newFilters, $$filter;
160 :     }
161 :     # Put all the filters together to form the new filter.
162 :     $$filter = join(" AND ", @newFilters);
163 : parrello 1.26 Trace("Subsystem filter is $$filter.") if T(ServerUtilities => 3);
164 : parrello 1.21 }
165 :     }
166 :    
167 :    
168 :    
169 : parrello 1.9 =head3 GetIdList
170 :    
171 : parrello 1.19 my $ids = ServerThing::GetIdList($name => $args, $optional);
172 : parrello 1.9
173 :     Get a named list of IDs from an argument structure. If the IDs are
174 :     missing, or are not a list, an error will occur.
175 :    
176 :     =over 4
177 :    
178 :     =item name
179 :    
180 :     Name of the argument structure member that should contain the ID list.
181 :    
182 :     =item args
183 :    
184 :     Argument structure from which the ID list is to be extracted.
185 :    
186 : parrello 1.19 =item optional (optional)
187 :    
188 :     If TRUE, then a missing value will not generate an error. Instead, an empty list
189 :     will be returned. The default is FALSE.
190 :    
191 : parrello 1.9 =item RETURN
192 :    
193 :     Returns a reference to a list of IDs taken from the argument structure.
194 :    
195 :     =back
196 :    
197 :     =cut
198 :    
199 :     sub GetIdList {
200 :     # Get the parameters.
201 : parrello 1.19 my ($name, $args, $optional) = @_;
202 : parrello 1.35 # Declare the return variable.
203 :     my $retVal;
204 : parrello 1.32 # Check the argument format.
205 : parrello 1.35 if (! defined $args && $optional) {
206 :     # Here there are no parameters, but the arguments are optional so it's
207 :     # okay.
208 :     $retVal = [];
209 :     } elsif (ref $args ne 'HASH') {
210 :     # Here we have an invalid parameter structure.
211 : parrello 1.32 Confess("No '$name' parameter present.");
212 : parrello 1.35 } else {
213 :     # Here we have a hash with potential parameters in it. Try to get the
214 :     # IDs from the argument structure.
215 :     $retVal = $args->{$name};
216 :     # Was a member found?
217 :     if (! defined $retVal) {
218 :     # No. If we're optional, return an empty list; otherwise throw an error.
219 :     if ($optional) {
220 :     $retVal = [];
221 :     } else {
222 :     Confess("No '$name' parameter found.");
223 :     }
224 : parrello 1.19 } else {
225 : parrello 1.35 # Here we found something. Get the parameter type. We want a list reference.
226 :     # If it's a scalar, we'll convert it to a singleton list. If it's anything
227 :     # else, it's an error.
228 :     my $type = ref $retVal;
229 :     if (! $type) {
230 :     $retVal = [$retVal];
231 :     } elsif ($type ne 'ARRAY') {
232 :     Confess("The '$name' parameter must be a list.");
233 :     }
234 : parrello 1.19 }
235 : parrello 1.9 }
236 :     # Return the result.
237 :     return $retVal;
238 :     }
239 :    
240 :    
241 :     =head3 RunTool
242 :    
243 :     ServerThing::RunTool($name => $cmd);
244 :    
245 :     Run a command-line tool. A non-zero return value from the tool will cause
246 :     a fatal error, and the tool's error log will be traced.
247 :    
248 :     =over 4
249 :    
250 :     =item name
251 :    
252 :     Name to give to the tool in the error output.
253 :    
254 :     =item cmd
255 :    
256 :     Command to use for running the tool. This should be the complete command line.
257 :     The command should not contain any fancy piping, though it may redirect the
258 :     standard input and output. The command will be modified by this method to
259 :     redirect the error output to a temporary file.
260 :    
261 :     =back
262 :    
263 :     =cut
264 :    
265 :     sub RunTool {
266 :     # Get the parameters.
267 :     my ($name, $cmd) = @_;
268 :     # Compute the log file name.
269 :     my $errorLog = "$FIG_Config::temp/errors$$.log";
270 :     # Execute the command.
271 : parrello 1.26 Trace("Executing command: $cmd") if T(ServerUtilities => 3);
272 : parrello 1.9 my $res = system("$cmd 2> $errorLog");
273 : parrello 1.26 Trace("Return from $name tool is $res.") if T(ServerUtilities => 3);
274 : parrello 1.9 # Check the result code.
275 :     if ($res != 0) {
276 :     # We have an error. If tracing is on, trace it.
277 : parrello 1.26 if (T(ServerUtilities => 1)) {
278 : parrello 1.9 TraceErrorLog($name, $errorLog);
279 :     }
280 :     # Delete the error log.
281 :     unlink $errorLog;
282 :     # Confess the error.
283 : parrello 1.10 Confess("$name command failed with error code $res.");
284 : parrello 1.9 } else {
285 :     # Everything worked. Trace the error log if necessary.
286 : parrello 1.26 if (T(ServerUtilities => 3) && -s $errorLog) {
287 : parrello 1.9 TraceErrorLog($name, $errorLog);
288 :     }
289 :     # Delete the error log if there is one.
290 :     unlink $errorLog;
291 :     }
292 :     }
293 :    
294 : parrello 1.36
295 : parrello 1.37 =head2 Gene Correspondence File Methods
296 : parrello 1.36
297 : parrello 1.37 These methods relate to gene correspondence files, which are generated by the
298 :     L<svr_corresponding_genes.pl> script. Correspondence files are cached in the
299 :     organism cache (I<$FIG_Config::orgCache>) directory. Eventually they will be
300 :     copied into the organism directories themselves. At that point, the code below
301 :     will be modified to check the organism directories first and use the cache
302 :     directory if no file is found there.
303 :    
304 :     A gene correspondence file contains correspondences from a source genome to a
305 :     target genome. Most such correspondences are bidirectional best hits. A unidirectional
306 :     best hit may exist from the source genome to the target genome or in the reverse
307 :     direction from the targtet genome to the source genome. The cache directory itself
308 :     is divided into subdirectories by organism. The subdirectory has the source genome
309 :     name and the files themselves are named by the target genome.
310 :    
311 :     Some of the files are invalid and will be erased when they are found. A file is
312 :     considered invalid if it has a non-numeric value in a numeric column or if it
313 :     does not have any unidirectional hits from the target genome to the source
314 :     genome.
315 :    
316 :     The process of managing the correspondence files is tricky and dangerous because
317 :     of the possibility of race conditions. It can take several minutes to generate a
318 :     file, and if two processes try to generate the same file at the same time we need
319 :     to make sure they don't step on each other.
320 :    
321 :     In stored files, the source genome ID is always lexically lower than the target
322 :     genome ID. If a correspondence in the reverse direction is desired, the converse
323 :     file is found and the contents flipped automatically as they are read. So, the
324 :     correspondence from B<360108.3> to B<100226.1> would be found in a file with the
325 :     name B<360108.3> in the directory for B<100226.1>. Since this file actually has
326 :     B<100226.1> as the source and B<360108.3> as the target, the columns are
327 :     re-ordered and the arrows reversed before the file contents are passed to the
328 :     caller.
329 :    
330 :     =head4 Gene Correspondence List
331 :    
332 :     A gene correspondence file contains 18 columns. These are usually packaged as
333 :     a reference to list of lists. Each sub-list has the following format.
334 :    
335 :     =over 4
336 :    
337 :     =item 0
338 :    
339 :     The ID of a PEG in genome 1.
340 :    
341 :     =item 1
342 :    
343 :     The ID of a PEG in genome 2 that is our best estimate of a "corresponding gene".
344 :    
345 :     =item 2
346 :    
347 :     Count of the number of pairs of matching genes were found in the context.
348 :    
349 :     =item 3
350 :    
351 :     Pairs of corresponding genes from the contexts.
352 :    
353 :     =item 4
354 :    
355 :     The function of the gene in genome 1.
356 :    
357 :     =item 5
358 :    
359 :     The function of the gene in genome 2.
360 :    
361 :     =item 6
362 :    
363 :     Comma-separated list of aliases for the gene in genome 1 (any protein with an
364 :     identical sequence is considered an alias, whether or not it is actually the
365 :     name of the same gene in the same genome).
366 :    
367 :     =item 7
368 :    
369 :     Comma-separated list of aliases for the gene in genome 2 (any protein with an
370 :     identical sequence is considered an alias, whether or not it is actually the
371 :     name of the same gene in the same genome).
372 :    
373 :     =item 8
374 :    
375 :     Bi-directional best hits will contain "<=>" in this column; otherwise, "->" will appear.
376 :    
377 :     =item 9
378 :    
379 :     Percent identity over the region of the detected match.
380 :    
381 :     =item 10
382 :    
383 :     The P-score for the detected match.
384 :    
385 :     =item 11
386 :    
387 :     Beginning match coordinate in the protein encoded by the gene in genome 1.
388 :    
389 :     =item 12
390 :    
391 :     Ending match coordinate in the protein encoded by the gene in genome 1.
392 :    
393 :     =item 13
394 :    
395 :     Length of the protein encoded by the gene in genome 1.
396 :    
397 :     =item 14
398 :    
399 :     Beginning match coordinate in the protein encoded by the gene in genome 2.
400 :    
401 :     =item 15
402 :    
403 :     Ending match coordinate in the protein encoded by the gene in genome 2.
404 :    
405 :     =item 16
406 :    
407 :     Length of the protein encoded by the gene in genome 2.
408 :    
409 :     =item 17
410 :    
411 :     Bit score for the match. Divide by the length of the longer PEG to get
412 :     what we often refer to as a "normalized bit score".
413 :    
414 :     =back
415 :    
416 :     In the actual files, there will also be reverse correspondences indicated by a
417 :     back-arrow ("<-") in item (8). The output returned by the servers, however,
418 :     is filtered so that only forward correspondences occur. If a converse file
419 :     is used, the columns are re-ordered and the arrows reversed so that it looks
420 :     correct.
421 :    
422 :     =cut
423 :    
424 :     # hash for reversing the arrows
425 :     use constant ARROW_FLIP => { '->' => '<-', '<=>' => '<=>', '<-' => '->' };
426 :     # list of columns that contain numeric values that need to be validated
427 :     use constant NUM_COLS => [2,9,10,11,12,13,14,15,16,17];
428 :    
429 :     =head3 CheckForGeneCorrespondenceFile
430 :    
431 :     my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
432 :    
433 :     Try to find a gene correspondence file for the specified genome pairing. If the
434 :     file exists, its name and an indication of whether or not it is in the correct
435 :     direction will be returned.
436 : parrello 1.36
437 :     =over 4
438 :    
439 :     =item genome1
440 :    
441 : parrello 1.37 Source genome for the desired correspondence.
442 : parrello 1.36
443 :     =item genome2
444 :    
445 : parrello 1.37 Target genome for the desired correspondence.
446 : parrello 1.36
447 :     =item RETURN
448 :    
449 : parrello 1.37 Returns a two-element list. The first element is the name of the file containing the
450 :     correspondence, or C<undef> if the file does not exist. The second element is TRUE
451 :     if the correspondence would be forward or FALSE if the file needs to be flipped.
452 : parrello 1.36
453 :     =back
454 :    
455 :     =cut
456 :    
457 : parrello 1.37 sub CheckForGeneCorrespondenceFile {
458 : parrello 1.36 # Get the parameters.
459 :     my ($genome1, $genome2) = @_;
460 : parrello 1.37 # Declare the return variables.
461 :     my ($fileName, $converse);
462 :     # Determine the ordering of the genome IDs.
463 :     my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
464 :     $converse = ($genomeA ne $genome1);
465 :     # Look for a file containing the desired correspondence. (The code to check for a
466 :     # pre-computed file in the organism directories is currently turned off, because
467 :     # these files are all currently invalid.)
468 :     my $testFileName = "$FIG_Config::organisms/$genomeA/CorrToReferenceGenomes/$genomeB";
469 :     if (0 && -f $testFileName) {
470 : parrello 1.36 # Use the pre-computed file.
471 :     Trace("Using pre-computed file $fileName for genome correspondence.") if T(3);
472 : parrello 1.37 $fileName = $testFileName;
473 :     } elsif (-f $corrFileName) {
474 :     $fileName = $corrFileName;
475 :     Trace("Using cached file $fileName for genome correspondence.") if T(3);
476 :     }
477 :     # Return the result.
478 :     return ($fileName, $converse);
479 :     }
480 :    
481 :    
482 :     =head3 ComputeCorrespondenceFileName
483 :    
484 :     my ($fileName, $genomeA, $genomeB) = ServerThing::ComputeCorrespondenceFileName($genome1, $genome2);
485 :    
486 :     Compute the name to be given to a genome correspondence file in the organism cache
487 :     and return the source and target genomes that would be in it.
488 :    
489 :     =over 4
490 :    
491 :     =item genome1
492 :    
493 :     Source genome for the desired correspondence.
494 :    
495 :     =item genome2
496 :    
497 :     Target genome for the desired correspondence.
498 :    
499 :     =item RETURN
500 :    
501 :     Returns a three-element list. The first element is the name of the file to contain the
502 :     correspondence, the second element is the name of the genome that would act as the
503 :     source genome in the file, and the third element is the name of the genome that would
504 :     act as the target genome in the file.
505 :    
506 :     =back
507 :    
508 :     =cut
509 :    
510 :     sub ComputeCorrespondenceFileName {
511 :     # Get the parameters.
512 :     my ($genome1, $genome2) = @_;
513 :     # Declare the return variables.
514 :     my ($fileName, $genomeA, $genomeB);
515 :     # Determine the ordering of the genome IDs.
516 : parrello 1.41 if (MustFlipGenomeIDs($genome1, $genome2)) {
517 : parrello 1.37 ($genomeA, $genomeB) = ($genome1, $genome2);
518 : parrello 1.36 } else {
519 : parrello 1.37 ($genomeA, $genomeB) = ($genome2, $genome1);
520 :     }
521 :     # Insure the source organism has a subdirectory in the organism cache.
522 :     my $orgDir = "$FIG_Config::orgCache/$genomeA";
523 :     Tracer::Insure($orgDir, 0777);
524 :     # Compute the name of the correspondence file for the appropriate target genome.
525 :     $fileName = "$orgDir/$genomeB";
526 :     # Return the results.
527 :     return ($fileName, $genomeA, $genomeB);
528 :     }
529 :    
530 :    
531 :     =head3 CreateGeneCorrespondenceFile
532 :    
533 :     my ($fileName, $converse) = ServerThing::CheckForGeneCorrespondenceFile($genome1, $genome2);
534 :    
535 :     Create a new gene correspondence file in the organism cache for the specified
536 :     genome correspondence. The name of the new file will be returned along with
537 :     an indicator of whether or not it is in the correct direction.
538 :    
539 :     =over 4
540 :    
541 :     =item genome1
542 :    
543 :     Source genome for the desired correspondence.
544 :    
545 :     =item genome2
546 :    
547 :     Target genome for the desired correspondence.
548 :    
549 :     =item RETURN
550 :    
551 :     Returns a two-element list. The first element is the name of the file containing the
552 :     correspondence, or C<undef> if an error occurred. The second element is TRUE
553 :     if the correspondence would be forward or FALSE if the file needs to be flipped.
554 :    
555 :     =back
556 :    
557 :     =cut
558 :    
559 :     sub CreateGeneCorrespondenceFile {
560 :     # Get the parameters.
561 :     my ($genome1, $genome2) = @_;
562 :     # Declare the return variables.
563 :     my ($fileName, $converse);
564 :     # Compute the ultimate name for the correspondence file.
565 :     my ($corrFileName, $genomeA, $genomeB) = ComputeCorrespondenceFileName($genome1, $genome2);
566 :     $converse = ($genome1 ne $genomeA);
567 :     # Generate a temporary file name in the same directory. We'll build the temporary
568 :     # file and then rename it when we're done.
569 :     my $tempFileName = "$corrFileName.$$.tmp";
570 :     # This will be set to FALSE if we detect an error.
571 :     my $fileOK = 1;
572 :     # The file handles will be put in here.
573 :     my ($ih, $oh);
574 :     # Protect from errors.
575 :     eval {
576 :     # Open the temporary file for output.
577 :     $oh = Open(undef, ">$tempFileName");
578 :     # Open a pipe to get the correspondence data.
579 :     $ih = Open(undef, "$FIG_Config::bin/svr_corresponding_genes -u localhost $genomeA $genomeB |");
580 :     Trace("Creating correspondence file for $genomeA to $genomeB in temporary file $tempFileName.") if T(3);
581 :     # Copy the pipe date into the temporary file.
582 :     while (! eof $ih) {
583 :     my $line = <$ih>;
584 :     print $oh $line;
585 :     }
586 :     # Close both files. If the close fails we need to know: it means there was a pipe
587 :     # error.
588 :     $fileOK &&= close $ih;
589 :     $fileOK &&= close $oh;
590 :     };
591 :     if ($@) {
592 :     # Here a fatal error of some sort occurred. We need to force the files closed.
593 :     close $ih if $ih;
594 :     close $oh if $oh;
595 :     } elsif ($fileOK) {
596 :     # Here everything worked. Try to rename the temporary file to the real
597 :     # file name.
598 :     if (rename $tempFileName, $corrFileName) {
599 :     # Everything is ok, fix the permissions and return the file name.
600 :     chmod 0664, $corrFileName;
601 :     $fileName = $corrFileName;
602 :     Trace("Created correspondence file $fileName.") if T(3);
603 :     }
604 :     }
605 :     # If the temporary file exists, delete it.
606 :     if (-f $tempFileName) {
607 :     unlink $tempFileName;
608 :     }
609 :     # Return the results.
610 :     return ($fileName, $converse);
611 :     }
612 :    
613 :    
614 : parrello 1.41 =head3 MustFlipGenomeIDs
615 :    
616 :     my $converse = ServerThing::MustFlipGenomeIDs($genome1, $genome2);
617 :    
618 :     Return TRUE if the specified genome IDs are out of order. When genome IDs are out of
619 :     order, they are stored in the converse order in correspondence files on the server.
620 :     This is a simple method that allows the caller to check for the need to flip.
621 :    
622 :     =over 4
623 :    
624 :     =item genome1
625 :    
626 :     ID of the proposed source genome.
627 :    
628 :     =item genome2
629 :    
630 :     ID of the proposed target genome.
631 :    
632 :     =item RETURN
633 :    
634 :     Returns TRUE if the first genome would be stored on the server as a target, FALSE if
635 :     it would be stored as a source.
636 :    
637 :     =cut
638 :    
639 :     sub MustFlipGenomeIDs {
640 :     # Get the parameters.
641 :     my ($genome1, $genome2) = @_;
642 :     # Return an indication.
643 :     return ($genome1 gt $genome2);
644 :     }
645 :    
646 :    
647 : parrello 1.37 =head3 ReadGeneCorrespondenceFile
648 :    
649 : parrello 1.40 my $list = ServerThing::ReadGeneCorrespondenceFile($fileName, $converse, $all);
650 : parrello 1.37
651 :     Return the contents of the specified gene correspondence file in the form of
652 :     a list of lists, with backward correspondences filtered out. If the file is
653 :     for the converse of the desired correspondence, the columns will be reordered
654 :     automatically so that it looks as if the file were designed for the proper
655 :     direction.
656 :    
657 :     =over 4
658 :    
659 :     =item fileName
660 :    
661 :     The name of the gene correspondence file to read.
662 :    
663 :     =item converse (optional)
664 :    
665 :     TRUE if the file is for the converse of the desired correspondence, else FALSE.
666 :     If TRUE, the file columns will be reorderd automatically. The default is FALSE,
667 :     meaning we want to use the file as it appears on disk.
668 :    
669 : parrello 1.40 =item all (optional)
670 :    
671 :     TRUE if backward unidirectional correspondences should be included in the output.
672 :     The default is FALSE, in which case only forward and bidirectional correspondences
673 :     are included.
674 :    
675 : parrello 1.37 =item RETURN
676 :    
677 :     Returns a L</Gene Correspondence List> in the form of a reference to a list of lists.
678 :     If the file's contents are invalid or an error occurs, an undefined value will be
679 :     returned.
680 :    
681 :     =back
682 :    
683 :     =cut
684 :    
685 :     sub ReadGeneCorrespondenceFile {
686 :     # Get the parameters.
687 : parrello 1.40 my ($fileName, $converse, $all) = @_;
688 : parrello 1.37 # Declare the return variable. We will only put something in here if we are
689 :     # completely successful.
690 :     my $retVal;
691 :     # This value will be set to 1 if an error is detected.
692 :     my $error = 0;
693 :     # Try to open the file.
694 :     my $ih;
695 :     Trace("Reading correspondence file $fileName.") if T(3);
696 :     if (! open $ih, "<$fileName") {
697 :     # Here the open failed, so we have an error.
698 :     Trace("Failed to open gene correspondence file $fileName: $!") if T(3);
699 :     $error = 1;
700 :     }
701 :     # The gene correspondence list will be built in here.
702 :     my @corrList;
703 :     # This variable will be set to TRUE if we find a reverse correspondence somewhere
704 :     # in the file. Not finding one is an error.
705 :     my $reverseFound = 0;
706 :     # Loop until we hit the end of the file or an error occurs. We must check the error
707 :     # first in case the file handle failed to open.
708 :     while (! $error && ! eof $ih) {
709 :     # Get the current line.
710 :     my @row = Tracer::GetLine($ih);
711 :     # Get the correspondence direction and check for a reverse arrow.
712 :     $reverseFound = 1 if ($row[8] eq '<-');
713 :     # If we're in converse mode, reformat the line.
714 :     if ($converse) {
715 : parrello 1.39 ReverseGeneCorrespondenceRow(\@row);
716 : parrello 1.37 }
717 :     # Validate the row.
718 :     if (ValidateGeneCorrespondenceRow(\@row)) {
719 :     Trace("Invalid row $. found in correspondence file $fileName.") if T(3);
720 :     $error = 1;
721 :     }
722 :     # If this row is in the correct direction, keep it.
723 : parrello 1.40 if ($all || $row[8] ne '<-') {
724 : parrello 1.37 push @corrList, \@row;
725 :     }
726 :     }
727 :     # Close the input file.
728 :     close $ih;
729 :     # If we have no errors and we found a reverse arrow, keep the result.
730 :     if (! $error) {
731 :     if ($reverseFound) {
732 :     $retVal = \@corrList;
733 : parrello 1.36 } else {
734 : parrello 1.37 Trace("No reverse arrow found in correspondence file $fileName.") if T(3);
735 :     }
736 :     }
737 :     # Return the result (if any).
738 :     return $retVal;
739 :     }
740 :    
741 : parrello 1.39 =head3 ReverseGeneCorrespondenceRow
742 :    
743 :     ServerThing::ReverseGeneCorrespondenceRow($row)
744 :    
745 :     Convert a gene correspondence row to represent the converse correspondence. The
746 :     elements in the row will be reordered to represent a correspondence from the
747 :     target genome to the source genome.
748 :    
749 :     =over 4
750 :    
751 :     =item row
752 :    
753 :     Reference to a list containing a single row from a L</Gene Correspondence List>.
754 :    
755 :     =back
756 :    
757 :     =cut
758 :    
759 :     sub ReverseGeneCorrespondenceRow {
760 :     # Get the parameters.
761 :     my ($row) = @_;
762 :     # Flip the row in place.
763 :     ($row->[1], $row->[0], $row->[2], $row->[3], $row->[5], $row->[4], $row->[7],
764 : parrello 1.41 $row->[6], $row->[8], $row->[9], $row->[10], $row->[14],
765 : parrello 1.39 $row->[15], $row->[16], $row->[11], $row->[12], $row->[13], $row->[17]) = @$row;
766 : parrello 1.41 # Flip the arrow.
767 :     $row->[8] = ARROW_FLIP->{$row->[8]};
768 :     # Flip the pairs.
769 :     my @elements = split /,/, @{$row->[3]};
770 :     $row->[3] = join(",", map { reverse split /:/, $_ } @elements);
771 : parrello 1.39 }
772 : parrello 1.37
773 :     =head3 ValidateGeneCorrespondenceRow
774 :    
775 :     my $errorCount = ServerThing::ValidateGeneCorrespondenceRow($row);
776 :    
777 :     Validate a gene correspondence row. The numeric fields are checked to insure they
778 :     are numeric and the source and target gene IDs are validated. The return value will
779 :     indicate the number of errors found.
780 :    
781 :     =over 4
782 :    
783 :     =item row
784 :    
785 :     Reference to a list containing a single row from a L</Gene Correspondence List>.
786 :    
787 :     =item RETURN
788 :    
789 :     Returns the number of errors found in the row. A return of C<0> indicates the row
790 :     is valid.
791 :    
792 :     =back
793 :    
794 :     =cut
795 :    
796 :     sub ValidateGeneCorrespondenceRow {
797 :     # Get the parameters.
798 :     my ($row, $genome1, $genome2) = @_;
799 :     # Denote no errors have been found so far.
800 :     my $retVal = 0;
801 :     # Check for non-numeric values in the number columns.
802 :     for my $col (@{NUM_COLS()}) {
803 :     unless ($row->[$col] =~ /^-?\d+\.?\d*(?:e[+-]?\d+)?$/) {
804 :     $retVal++;
805 :     }
806 :     }
807 :     # Check the gene IDs.
808 :     for my $col (0, 1) {
809 :     unless ($row->[$col] =~ /^fig\|\d+\.\d+\.\w+\.\d+$/) {
810 :     $retVal++;
811 : parrello 1.36 }
812 :     }
813 : parrello 1.37 # Verify the arrow.
814 :     unless (exists ARROW_FLIP->{$row->[8]}) {
815 :     $retVal++;
816 :     }
817 :     # Return the error count.
818 : parrello 1.36 return $retVal;
819 :     }
820 :    
821 : parrello 1.9
822 :     =head2 Internal Utility Methods
823 :    
824 :     The methods in this section are used internally by this package.
825 :    
826 : parrello 1.6 =head3 RunRequest
827 :    
828 : parrello 1.9 ServerThing::RunRequest($cgi, $serverName);
829 : parrello 1.6
830 :     Run a request from the specified server using the incoming CGI parameter
831 :     object for the parameters.
832 :    
833 :     =over 4
834 :    
835 :     =item cgi
836 :    
837 :     CGI query object containing the parameters from the web service request.
838 :    
839 : parrello 1.13 =item serverThing
840 : parrello 1.6
841 : parrello 1.13 Server object against which to run the request.
842 : parrello 1.6
843 :     =back
844 :    
845 :     =cut
846 :    
847 :     sub RunRequest {
848 :     # Get the parameters.
849 : parrello 1.13 my ($cgi, $serverThing, $docURL) = @_;
850 : parrello 1.9 # Determine the request type.
851 :     if ($cgi->param('pod')) {
852 : parrello 1.4 # Here we have a documentation request. In this case, we produce POD HTML.
853 : parrello 1.9 ProducePod($cgi->param('pod'));
854 : disz 1.31 } elsif ($cgi->param('code')) {
855 : parrello 1.32 # Here the user wants to see the code for one of our scripts.
856 :     LineNumberize($cgi->param('code'));
857 : parrello 1.9 } elsif ($cgi->param('file')) {
858 :     # Here we have a file request. Process according to the type.
859 :     my $type = $cgi->param('file');
860 :     if ($type eq 'open') {
861 :     OpenFile($cgi->param('name'));
862 :     } elsif ($type eq 'create') {
863 :     CreateFile();
864 :     } elsif ($type eq 'read') {
865 :     ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
866 :     } elsif ($type eq 'write') {
867 :     WriteChunk($cgi->param('name'), $cgi->param('data'));
868 :     } else {
869 :     Die("Invalid file function \"$type\".");
870 : parrello 1.4 }
871 : parrello 1.1 } else {
872 : parrello 1.9 # The default is a function request. Get the function name.
873 : parrello 1.4 my $function = $cgi->param('function') || "";
874 : parrello 1.15 Trace("Server function for task $$ is $function.") if T(3);
875 : parrello 1.4 # Insure the function name is valid.
876 :     Die("Invalid function name.")
877 :     if $function =~ /\W/;
878 :     # The parameter structure will go in here.
879 :     my $args;
880 :     # Start the timer.
881 :     my $start = time();
882 :     # The output document goes in here.
883 :     my $document;
884 :     # The sapling database goes in here.
885 :     my $sapling;
886 :     # Protect from errors.
887 : parrello 1.1 eval {
888 : parrello 1.4 # Parse the arguments.
889 :     $args = YAML::Load($cgi->param('args'));
890 : parrello 1.1 };
891 : parrello 1.4 # Check to make sure we got everything.
892 : parrello 1.1 if ($@) {
893 : parrello 1.10 SendError($@, "Error formatting parameters.");
894 : parrello 1.4 } elsif (! $function) {
895 : parrello 1.10 SendError("No function specified.", "No function specified.");
896 : parrello 1.1 } else {
897 : parrello 1.30 $document = eval { $serverThing->$function($args) };
898 : parrello 1.1 # If we have an error, create an error document.
899 :     if ($@) {
900 : parrello 1.13 SendError($@, "Error detected by service.");
901 : parrello 1.32 Trace("Error encountered by service: $@") if T(0);
902 : parrello 1.1 } else {
903 : parrello 1.13 # No error, so we output the result.
904 :     print $cgi->header(-type => 'text/plain');
905 : parrello 1.18 my $string = YAML::Dump($document);
906 :     print $string;
907 :     MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
908 : parrello 1.1 }
909 :     }
910 : parrello 1.4 # Stop the timer.
911 :     my $duration = int(time() - $start + 0.5);
912 : parrello 1.29 Trace("Function $function executed in $duration seconds by task $$.") if T(2);
913 : parrello 1.1 }
914 :     }
915 :    
916 : parrello 1.9 =head3 CreateFile
917 :    
918 :     ServerThing::CreateFile();
919 :    
920 :     Create a new, empty temporary file and send its name back to the client.
921 :    
922 :     =cut
923 :    
924 :     sub CreateFile {
925 :     ##TODO: Code
926 :     }
927 :    
928 :     =head3 OpenFile
929 : parrello 1.6
930 : parrello 1.9 ServerThing::OpenFile($name);
931 : parrello 1.1
932 : parrello 1.9 Send the length of the named file back to the client.
933 :    
934 :     =over 4
935 :    
936 :     =item name
937 :    
938 :     ##TODO: name description
939 :    
940 :     =back
941 :    
942 :     =cut
943 :    
944 :     sub OpenFile {
945 :     # Get the parameters.
946 :     my ($name) = @_;
947 :     ##TODO: Code
948 :     }
949 : parrello 1.1
950 : parrello 1.9 =head3 ReadChunk
951 : parrello 1.1
952 : parrello 1.9 ServerThing::ReadChunk($name, $location, $size);
953 : parrello 1.1
954 : parrello 1.9 Read the indicated number of bytes from the specified location of the
955 :     named file and send them back to the client.
956 : parrello 1.1
957 :     =over 4
958 :    
959 :     =item name
960 :    
961 : parrello 1.9 ##TODO: name description
962 : parrello 1.1
963 : parrello 1.9 =item location
964 : parrello 1.1
965 : parrello 1.9 ##TODO: location description
966 : parrello 1.1
967 : parrello 1.9 =item size
968 : parrello 1.1
969 : parrello 1.9 ##TODO: size description
970 : parrello 1.1
971 :     =back
972 :    
973 :     =cut
974 :    
975 : parrello 1.9 sub ReadChunk {
976 : parrello 1.1 # Get the parameters.
977 : parrello 1.9 my ($name, $location, $size) = @_;
978 :     ##TODO: Code
979 : parrello 1.1 }
980 :    
981 : parrello 1.9 =head3 WriteChunk
982 : parrello 1.1
983 : parrello 1.9 ServerThing::WriteChunk($name, $data);
984 : parrello 1.8
985 : parrello 1.9 Write the specified data to the named file.
986 : parrello 1.8
987 :     =over 4
988 :    
989 :     =item name
990 :    
991 : parrello 1.9 ##TODO: name description
992 :    
993 :     =item data
994 :    
995 :     ##TODO: data description
996 :    
997 :     =back
998 :    
999 :     =cut
1000 :    
1001 :     sub WriteChunk {
1002 :     # Get the parameters.
1003 :     my ($name, $data) = @_;
1004 :     ##TODO: Code
1005 :     }
1006 :    
1007 :    
1008 : disz 1.31 =head3 LineNumberize
1009 :    
1010 :     ServerThing::LineNumberize($module);
1011 :    
1012 :     Output the module line by line with line numbers
1013 :    
1014 :     =over 4
1015 :    
1016 :     =item module
1017 :    
1018 :     Name of the module to line numberized
1019 :    
1020 :     =back
1021 :    
1022 :     =cut
1023 :    
1024 :     sub LineNumberize {
1025 :     # Get the parameters.
1026 :     my ($module) = @_;
1027 :     my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
1028 :     # Start the output page.
1029 :     print CGI::header();
1030 :     print CGI::start_html(-title => 'Documentation Page',
1031 :     -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1032 :     # Protect from errors.
1033 :     eval {
1034 : parrello 1.32 if (-e $fks_path) {
1035 :     print "<pre>\n";
1036 :     my $i = 1;
1037 :     foreach my $line (`cat $fks_path`) {
1038 :     print "$i.\t$line";
1039 :     $i++;
1040 :     }
1041 :     print "</pre>\n";
1042 :     } else {
1043 :     print "File $fks_path not found";
1044 :     }
1045 : disz 1.31 };
1046 :     # Process any error.
1047 :     if ($@) {
1048 :     print CGI::blockquote({ class => 'error' }, $@);
1049 :     }
1050 :     # Close off the page.
1051 :     print CGI::end_html();
1052 :    
1053 :     }
1054 :    
1055 : parrello 1.9 =head3 ProducePod
1056 :    
1057 :     ServerThing::ProducePod($module);
1058 :    
1059 :     Output the POD documentation for the specified module.
1060 :    
1061 :     =over 4
1062 : parrello 1.8
1063 : parrello 1.9 =item module
1064 : parrello 1.8
1065 : parrello 1.9 Name of the module whose POD document is to be displayed.
1066 : parrello 1.8
1067 :     =back
1068 :    
1069 :     =cut
1070 :    
1071 : parrello 1.9 sub ProducePod {
1072 : parrello 1.8 # Get the parameters.
1073 : parrello 1.9 my ($module) = @_;
1074 :     # Start the output page.
1075 :     print CGI::header();
1076 :     print CGI::start_html(-title => 'Documentation Page',
1077 :     -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
1078 :     # Protect from errors.
1079 :     eval {
1080 :     # We'll format the HTML text in here.
1081 :     require DocUtils;
1082 : parrello 1.20 my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
1083 : parrello 1.9 # Output the POD HTML.
1084 :     print $html;
1085 :     };
1086 :     # Process any error.
1087 :     if ($@) {
1088 :     print CGI::blockquote({ class => 'error' }, $@);
1089 : parrello 1.8 }
1090 : parrello 1.9 # Close off the page.
1091 :     print CGI::end_html();
1092 :    
1093 : parrello 1.8 }
1094 :    
1095 :     =head3 TraceErrorLog
1096 :    
1097 :     ServerThing::TraceErrorLog($name, $errorLog);
1098 :    
1099 :     Trace the specified error log file. This is a very dinky routine that
1100 :     performs a task required by L</RunTool> in multiple places.
1101 :    
1102 :     =over 4
1103 :    
1104 :     =item name
1105 :    
1106 :     Name of the tool relevant to the log file.
1107 :    
1108 :     =item errorLog
1109 :    
1110 :     Name of the log file.
1111 :    
1112 :     =back
1113 :    
1114 :     =cut
1115 :    
1116 :     sub TraceErrorLog {
1117 :     my ($name, $errorLog) = @_;
1118 :     my $errorData = Tracer::GetFile($errorLog);
1119 :     Trace("$name error log:\n$errorData");
1120 :     }
1121 :    
1122 : parrello 1.10 =head3 SendError
1123 :    
1124 :     ServerThing::SendError($message, $status);
1125 :    
1126 :     Fail an HTTP request with the specified error message and the specified
1127 :     status message.
1128 :    
1129 :     =over 4
1130 :    
1131 :     =item message
1132 :    
1133 :     Detailed error message. This is sent as the page content.
1134 :    
1135 :     =item status
1136 :    
1137 :     Status message. This is sent as part of the status code.
1138 :    
1139 :     =back
1140 :    
1141 :     =cut
1142 :    
1143 :     sub SendError {
1144 :     # Get the parameters.
1145 :     my ($message, $status) = @_;
1146 :     Trace("Error \"$status\" $message") if T(2);
1147 : parrello 1.30 # Check for a DBserver error. These can be retried and get a special status
1148 :     # code.
1149 :     my $realStatus;
1150 :     if ($message =~ /DBServer Error:\s+/) {
1151 :     $realStatus = "503 $status";
1152 :     } else {
1153 :     $realStatus = "500 $status";
1154 :     }
1155 : parrello 1.10 # Print the header and the status message.
1156 :     print CGI::header(-type => 'text/plain',
1157 : parrello 1.30 -status => $realStatus);
1158 : parrello 1.10 # Print the detailed message.
1159 :     print $message;
1160 :     }
1161 :    
1162 :    
1163 : disz 1.31 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3