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

Annotation of /FigKernelPackages/ServerThing.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3