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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3