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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3