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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (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 :     use ErrorDocument;
12 :     use CGI;
13 :    
14 :     =head1 General Server Helper
15 :    
16 :     This package provides a method-- I<RunServer>-- that can be called from a CGI
17 :     script to perform the duties of a FIG server. RunServer is called with two
18 :     parameters: the name of the server package (e.g. C<SAP> for B<Sap.pm>) and
19 :     the first command-line parameter. This last is only used when the server
20 :     script is being invoked from the debugging console.
21 :    
22 :     =cut
23 :    
24 :     sub RunServer {
25 :     # Get the parameters.
26 :     my ($serverName, $key) = @_;
27 :     # Get the CGI parameters.
28 :     my $cgi;
29 :     if (! $key) {
30 :     # No tracing key, so presume we're a web service.
31 :     $cgi = CGI->new();
32 :     ETracing($cgi);
33 :     } else {
34 :     # We're being invoked from the command line. Use the tracing
35 :     # key to find the parm file and create the CGI object from that.
36 :     my $ih = Open(undef, "<$FIG_Config::temp/$key.parms");
37 :     $cgi = CGI->new($ih);
38 :     # Set up tracing using the specified key.
39 :     ETracing($key);
40 :     # Trace the CGI parameters.
41 :     Tracer::TraceParms($cgi);
42 :     }
43 :     Trace("Running $serverName server request.") if T(3);
44 :     # Get the function name.
45 :     my $function = $cgi->param('function') || "";
46 :     Trace("Server function is $function.") if T(3);
47 :     # The parameter structure will go in here.
48 :     my $args;
49 :     # Start the timer.
50 :     my $start = time();
51 :     # The output document goes in here.
52 :     my $document;
53 :     # The sapling database goes in here.
54 :     my $sapling;
55 :     # Protect from errors.
56 :     eval {
57 :     # Parse the arguments.
58 :     $args = YAML::Load($cgi->param('args'));
59 :     };
60 :     # Check to make sure we got everything.
61 :     if ($@) {
62 :     $document = ErrorDocument->new('<initialization>', $@);
63 :     } elsif (! $function) {
64 :     $document = ErrorDocument->new('<missing>', "No function specified.");
65 :     } else {
66 :     # We're okay, so load the server function object.
67 :     Trace("Requiring $serverName") if T(3);
68 :     eval {
69 :     require "$serverName.pm";
70 :     };
71 :     # If we have an error, create an error document.
72 :     if ($@) {
73 :     $document = ErrorDocument->new($function, $@);
74 :     Trace("Error loadin server module: $@") if T(2);
75 :     } else {
76 :     # Having successfully loaded the server code, we create the object.
77 :     my $serverThing = eval("$serverName" . '->new()');
78 :     # If we have an error, create an error document.
79 :     if ($@) {
80 :     $document = ErrorDocument->new($function, $@);
81 :     Trace("Error creating server function object: $@") if T(2);
82 :     } else {
83 :     # No error, so execute the server method.
84 :     Trace("Executing $function.") if T(2);
85 :     $document = eval("\$serverThing->$function(\$args)");
86 :     # If we have an error, create an error document.
87 :     if ($@) {
88 :     $document = ErrorDocument->new($function, $@);
89 :     Trace("Error encountered by service: $@") if T(2);
90 :     }
91 :     }
92 :     }
93 :     }
94 :     # Stop the timer.
95 :     my $duration = int(time() - $start + 0.5);
96 :     Trace("Function executed in $duration seconds.") if T(2);
97 :     # Output the YAML.
98 :     print $cgi->header(-type => 'text/yaml');
99 :     print YAML::Dump($document);
100 :     }
101 :    
102 :     =head2 Utility Methods
103 :    
104 :     The methods in this section are utilities of general use to the various
105 :     server modules.
106 :    
107 :     =head3 GetIdList
108 :    
109 :     my $ids = ServerThing::GetIdList($name => $args);
110 :    
111 :     Get a named list of IDs from an argument structure. If the IDs are
112 :     missing, or are not a list, an error will occur.
113 :    
114 :     =over 4
115 :    
116 :     =item name
117 :    
118 :     Name of the argument structure member that should contain the ID list.
119 :    
120 :     =item args
121 :    
122 :     Argument structure from which the ID list is to be extracted.
123 :    
124 :     =item RETURN
125 :    
126 :     Returns a reference to a list of IDs taken from the argument structure.
127 :    
128 :     =back
129 :    
130 :     =cut
131 :    
132 :     sub GetIdList {
133 :     # Get the parameters.
134 :     my ($name, $args) = @_;
135 :     # Try to get the IDs from the argument structure.
136 :     my $retVal = $args->{$name};
137 :     # Throw an error if no member was found.
138 :     Confess("No '$name' parameter found.") if ! defined $retVal;
139 :     # Get the parameter type. We was a list reference. If it's a scalar, we'll
140 :     # convert it to a singleton list. If it's anything else, it's an error.
141 :     my $type = ref $retVal;
142 :     if (! $type) {
143 :     $retVal = [$retVal];
144 :     } elsif ($type ne 'ARRAY') {
145 :     Confess("The '$name' parameter must be a list.");
146 :     }
147 :     # Return the result.
148 :     return $retVal;
149 :     }
150 :    
151 :    
152 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3