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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.36 - (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 =head3 FindGeneCorrespondenceFile
295 :    
296 :     my $ih = ServerThing::FindGeneCorrespondenceFile($genome1, $genome2);
297 :    
298 :     Return an open input handle for a file that maps the genes in the first genome
299 :     to corresponding genes in the second genome. These files can be found for some
300 :     genomes in the organism directories. Additional files are available in the
301 :     organism cache directory (I<$FIG_Config::orgCache>). If the desired file does
302 :     not exist, one will be created in the organism cache directory, presumably to be
303 :     moved to a permanent location at a later time.
304 :    
305 :     =over 4
306 :    
307 :     =item genome1
308 :    
309 :     ID of the source genome.
310 :    
311 :     =item genome2
312 :    
313 :     ID of the target genome.
314 :    
315 :     =item RETURN
316 :    
317 :     Returns the name of a tab-delimited file. The first column in the file contains IDs
318 :     of genes in the source genome; the second column contains IDs of genes in the
319 :     target genone. The remaining columns contain additional data about the correspondence.
320 :    
321 :     =back
322 :    
323 :     =cut
324 :    
325 :     sub FindGeneCorrespondenceFile {
326 :     # Get the parameters.
327 :     my ($genome1, $genome2) = @_;
328 :     # Declare the return variable.
329 :     my $retVal;
330 :     # Look for a pre-computed file in the organism directories.
331 :     my $fileName = "$FIG_Config::organisms/$genome1/CorrToReferenceGenomes/$genome2";
332 :     if (-f $fileName) {
333 :     # Use the pre-computed file.
334 :     Trace("Using pre-computed file $fileName for genome correspondence.") if T(3);
335 :     $retVal = Open(undef, "<$fileName");
336 :     } else {
337 :     # Check for an organism cache.
338 :     if (! $FIG_Config::orgCache) {
339 :     # No cache, so simply open a pipe.
340 :     Trace("No organism cache found: using pipe to compute $genome1 vs. $genome2.") if T(3);
341 :     $retVal = Open(undef, "$FIG_Config::bin/svr_corresponding_genes $genome1 $genome2 |");
342 :     } else {
343 :     # Insure the source organism has a subdirectory in the cache.
344 :     my $orgDir = "$FIG_Config::orgCache/$genome1";
345 :     Tracer::Insure($orgDir, 0777);
346 :     # Check for a correspondence file that matches the target genome.
347 :     $fileName = "$orgDir/$genome2";
348 :     if (-f $fileName) {
349 :     # We found one, so try to open it.
350 :     my $ok = open $retVal, "<$fileName";
351 :     # If the open failed, then the file is being built by another process, so
352 :     # use a pipe.
353 :     if (! $ok) {
354 :     Trace("Failed to open $fileName. Using pipe to compute correspondence.") if T(3);
355 :     $retVal = Open(undef, "$FIG_Config::bin/svr_corresponding_genes $genome1 $genome2 |");
356 :     } else {
357 :     Trace("Using cached file $fileName for genome correspondence.") if T(3);
358 :     }
359 :     } else {
360 :     # Here we need to create the file.
361 :     Trace("Creating genome correspondence file $fileName.") if T(3);
362 :     system "svr_corresponding_genes $genome1 $genome2 >$fileName";
363 :     Trace("Using created file for genome correspondence.") if T(3);
364 :     $retVal = Open(undef, "<$fileName");
365 :     }
366 :     }
367 :     }
368 :     # Return the desired file handle.
369 :     return $retVal;
370 :     }
371 :    
372 : parrello 1.9
373 :     =head2 Internal Utility Methods
374 :    
375 :     The methods in this section are used internally by this package.
376 :    
377 : parrello 1.6 =head3 RunRequest
378 :    
379 : parrello 1.9 ServerThing::RunRequest($cgi, $serverName);
380 : parrello 1.6
381 :     Run a request from the specified server using the incoming CGI parameter
382 :     object for the parameters.
383 :    
384 :     =over 4
385 :    
386 :     =item cgi
387 :    
388 :     CGI query object containing the parameters from the web service request.
389 :    
390 : parrello 1.13 =item serverThing
391 : parrello 1.6
392 : parrello 1.13 Server object against which to run the request.
393 : parrello 1.6
394 :     =back
395 :    
396 :     =cut
397 :    
398 :     sub RunRequest {
399 :     # Get the parameters.
400 : parrello 1.13 my ($cgi, $serverThing, $docURL) = @_;
401 : parrello 1.9 # Determine the request type.
402 :     if ($cgi->param('pod')) {
403 : parrello 1.4 # Here we have a documentation request. In this case, we produce POD HTML.
404 : parrello 1.9 ProducePod($cgi->param('pod'));
405 : disz 1.31 } elsif ($cgi->param('code')) {
406 : parrello 1.32 # Here the user wants to see the code for one of our scripts.
407 :     LineNumberize($cgi->param('code'));
408 : parrello 1.9 } elsif ($cgi->param('file')) {
409 :     # Here we have a file request. Process according to the type.
410 :     my $type = $cgi->param('file');
411 :     if ($type eq 'open') {
412 :     OpenFile($cgi->param('name'));
413 :     } elsif ($type eq 'create') {
414 :     CreateFile();
415 :     } elsif ($type eq 'read') {
416 :     ReadChunk($cgi->param('name'), $cgi->param('location'), $cgi->param('size'));
417 :     } elsif ($type eq 'write') {
418 :     WriteChunk($cgi->param('name'), $cgi->param('data'));
419 :     } else {
420 :     Die("Invalid file function \"$type\".");
421 : parrello 1.4 }
422 : parrello 1.1 } else {
423 : parrello 1.9 # The default is a function request. Get the function name.
424 : parrello 1.4 my $function = $cgi->param('function') || "";
425 : parrello 1.15 Trace("Server function for task $$ is $function.") if T(3);
426 : parrello 1.4 # Insure the function name is valid.
427 :     Die("Invalid function name.")
428 :     if $function =~ /\W/;
429 :     # The parameter structure will go in here.
430 :     my $args;
431 :     # Start the timer.
432 :     my $start = time();
433 :     # The output document goes in here.
434 :     my $document;
435 :     # The sapling database goes in here.
436 :     my $sapling;
437 :     # Protect from errors.
438 : parrello 1.1 eval {
439 : parrello 1.4 # Parse the arguments.
440 :     $args = YAML::Load($cgi->param('args'));
441 : parrello 1.1 };
442 : parrello 1.4 # Check to make sure we got everything.
443 : parrello 1.1 if ($@) {
444 : parrello 1.10 SendError($@, "Error formatting parameters.");
445 : parrello 1.4 } elsif (! $function) {
446 : parrello 1.10 SendError("No function specified.", "No function specified.");
447 : parrello 1.1 } else {
448 : parrello 1.30 $document = eval { $serverThing->$function($args) };
449 : parrello 1.1 # If we have an error, create an error document.
450 :     if ($@) {
451 : parrello 1.13 SendError($@, "Error detected by service.");
452 : parrello 1.32 Trace("Error encountered by service: $@") if T(0);
453 : parrello 1.1 } else {
454 : parrello 1.13 # No error, so we output the result.
455 :     print $cgi->header(-type => 'text/plain');
456 : parrello 1.18 my $string = YAML::Dump($document);
457 :     print $string;
458 :     MemTrace(length($string) . " bytes returned from $function by task $$.") if T(Memory => 3);
459 : parrello 1.1 }
460 :     }
461 : parrello 1.4 # Stop the timer.
462 :     my $duration = int(time() - $start + 0.5);
463 : parrello 1.29 Trace("Function $function executed in $duration seconds by task $$.") if T(2);
464 : parrello 1.1 }
465 :     }
466 :    
467 : parrello 1.9 =head3 CreateFile
468 :    
469 :     ServerThing::CreateFile();
470 :    
471 :     Create a new, empty temporary file and send its name back to the client.
472 :    
473 :     =cut
474 :    
475 :     sub CreateFile {
476 :     ##TODO: Code
477 :     }
478 :    
479 :     =head3 OpenFile
480 : parrello 1.6
481 : parrello 1.9 ServerThing::OpenFile($name);
482 : parrello 1.1
483 : parrello 1.9 Send the length of the named file back to the client.
484 :    
485 :     =over 4
486 :    
487 :     =item name
488 :    
489 :     ##TODO: name description
490 :    
491 :     =back
492 :    
493 :     =cut
494 :    
495 :     sub OpenFile {
496 :     # Get the parameters.
497 :     my ($name) = @_;
498 :     ##TODO: Code
499 :     }
500 : parrello 1.1
501 : parrello 1.9 =head3 ReadChunk
502 : parrello 1.1
503 : parrello 1.9 ServerThing::ReadChunk($name, $location, $size);
504 : parrello 1.1
505 : parrello 1.9 Read the indicated number of bytes from the specified location of the
506 :     named file and send them back to the client.
507 : parrello 1.1
508 :     =over 4
509 :    
510 :     =item name
511 :    
512 : parrello 1.9 ##TODO: name description
513 : parrello 1.1
514 : parrello 1.9 =item location
515 : parrello 1.1
516 : parrello 1.9 ##TODO: location description
517 : parrello 1.1
518 : parrello 1.9 =item size
519 : parrello 1.1
520 : parrello 1.9 ##TODO: size description
521 : parrello 1.1
522 :     =back
523 :    
524 :     =cut
525 :    
526 : parrello 1.9 sub ReadChunk {
527 : parrello 1.1 # Get the parameters.
528 : parrello 1.9 my ($name, $location, $size) = @_;
529 :     ##TODO: Code
530 : parrello 1.1 }
531 :    
532 : parrello 1.9 =head3 WriteChunk
533 : parrello 1.1
534 : parrello 1.9 ServerThing::WriteChunk($name, $data);
535 : parrello 1.8
536 : parrello 1.9 Write the specified data to the named file.
537 : parrello 1.8
538 :     =over 4
539 :    
540 :     =item name
541 :    
542 : parrello 1.9 ##TODO: name description
543 :    
544 :     =item data
545 :    
546 :     ##TODO: data description
547 :    
548 :     =back
549 :    
550 :     =cut
551 :    
552 :     sub WriteChunk {
553 :     # Get the parameters.
554 :     my ($name, $data) = @_;
555 :     ##TODO: Code
556 :     }
557 :    
558 :    
559 : disz 1.31 =head3 LineNumberize
560 :    
561 :     ServerThing::LineNumberize($module);
562 :    
563 :     Output the module line by line with line numbers
564 :    
565 :     =over 4
566 :    
567 :     =item module
568 :    
569 :     Name of the module to line numberized
570 :    
571 :     =back
572 :    
573 :     =cut
574 :    
575 :     sub LineNumberize {
576 :     # Get the parameters.
577 :     my ($module) = @_;
578 :     my $fks_path = "$FIG_Config::fig_disk/dist/releases/current/FigKernelScripts/$module";
579 :     # Start the output page.
580 :     print CGI::header();
581 :     print CGI::start_html(-title => 'Documentation Page',
582 :     -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
583 :     # Protect from errors.
584 :     eval {
585 : parrello 1.32 if (-e $fks_path) {
586 :     print "<pre>\n";
587 :     my $i = 1;
588 :     foreach my $line (`cat $fks_path`) {
589 :     print "$i.\t$line";
590 :     $i++;
591 :     }
592 :     print "</pre>\n";
593 :     } else {
594 :     print "File $fks_path not found";
595 :     }
596 : disz 1.31 };
597 :     # Process any error.
598 :     if ($@) {
599 :     print CGI::blockquote({ class => 'error' }, $@);
600 :     }
601 :     # Close off the page.
602 :     print CGI::end_html();
603 :    
604 :     }
605 :    
606 : parrello 1.9 =head3 ProducePod
607 :    
608 :     ServerThing::ProducePod($module);
609 :    
610 :     Output the POD documentation for the specified module.
611 :    
612 :     =over 4
613 : parrello 1.8
614 : parrello 1.9 =item module
615 : parrello 1.8
616 : parrello 1.9 Name of the module whose POD document is to be displayed.
617 : parrello 1.8
618 :     =back
619 :    
620 :     =cut
621 :    
622 : parrello 1.9 sub ProducePod {
623 : parrello 1.8 # Get the parameters.
624 : parrello 1.9 my ($module) = @_;
625 :     # Start the output page.
626 :     print CGI::header();
627 :     print CGI::start_html(-title => 'Documentation Page',
628 :     -style => { src => "http://servers.nmpdr.org/sapling/Html/css/ERDB.css" });
629 :     # Protect from errors.
630 :     eval {
631 :     # We'll format the HTML text in here.
632 :     require DocUtils;
633 : parrello 1.20 my $html = DocUtils::ShowPod($module, "http://servers.nmpdr.org/sapling/server.cgi?pod=");
634 : parrello 1.9 # Output the POD HTML.
635 :     print $html;
636 :     };
637 :     # Process any error.
638 :     if ($@) {
639 :     print CGI::blockquote({ class => 'error' }, $@);
640 : parrello 1.8 }
641 : parrello 1.9 # Close off the page.
642 :     print CGI::end_html();
643 :    
644 : parrello 1.8 }
645 :    
646 :     =head3 TraceErrorLog
647 :    
648 :     ServerThing::TraceErrorLog($name, $errorLog);
649 :    
650 :     Trace the specified error log file. This is a very dinky routine that
651 :     performs a task required by L</RunTool> in multiple places.
652 :    
653 :     =over 4
654 :    
655 :     =item name
656 :    
657 :     Name of the tool relevant to the log file.
658 :    
659 :     =item errorLog
660 :    
661 :     Name of the log file.
662 :    
663 :     =back
664 :    
665 :     =cut
666 :    
667 :     sub TraceErrorLog {
668 :     my ($name, $errorLog) = @_;
669 :     my $errorData = Tracer::GetFile($errorLog);
670 :     Trace("$name error log:\n$errorData");
671 :     }
672 :    
673 : parrello 1.10 =head3 SendError
674 :    
675 :     ServerThing::SendError($message, $status);
676 :    
677 :     Fail an HTTP request with the specified error message and the specified
678 :     status message.
679 :    
680 :     =over 4
681 :    
682 :     =item message
683 :    
684 :     Detailed error message. This is sent as the page content.
685 :    
686 :     =item status
687 :    
688 :     Status message. This is sent as part of the status code.
689 :    
690 :     =back
691 :    
692 :     =cut
693 :    
694 :     sub SendError {
695 :     # Get the parameters.
696 :     my ($message, $status) = @_;
697 :     Trace("Error \"$status\" $message") if T(2);
698 : parrello 1.30 # Check for a DBserver error. These can be retried and get a special status
699 :     # code.
700 :     my $realStatus;
701 :     if ($message =~ /DBServer Error:\s+/) {
702 :     $realStatus = "503 $status";
703 :     } else {
704 :     $realStatus = "500 $status";
705 :     }
706 : parrello 1.10 # Print the header and the status message.
707 :     print CGI::header(-type => 'text/plain',
708 : parrello 1.30 -status => $realStatus);
709 : parrello 1.10 # Print the detailed message.
710 :     print $message;
711 :     }
712 :    
713 :    
714 : disz 1.31 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3