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

Annotation of /FigKernelPackages/ACHserver.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (view) (download) (as text)

1 : disz 1.1
2 :     package ACHserver;
3 :    
4 : olson 1.4 #
5 :     # This is a SAS Component
6 :     #
7 : parrello 1.7 use strict;
8 :     use LWP::UserAgent;
9 :     use YAML;
10 :     use ErrorMessage;
11 :     no warnings qw(once);
12 : disz 1.1
13 : parrello 1.6 =head1 Annotation Clearinghouse Server Helper Object
14 :    
15 :     =head2 Description
16 :    
17 :     This module is used to call the Annotation Clearinghouse Server, which is a
18 :     special-purpose server for assertion data from the Sapling database. Each
19 :     Annotation Clearinghouse Server function corresponds to a method of this object.
20 :    
21 :     This package deliberately uses no internal SEED packages or scripts, only common
22 :     PERL modules.
23 :    
24 :     The fields in this object are as follows.
25 :    
26 :     =over 4
27 :    
28 :     =item server_url
29 :    
30 :     The URL used to request data from the subsystem server.
31 :    
32 :     =item ua
33 :    
34 :     The user agent for communication with the server.
35 :    
36 :     =item singleton
37 :    
38 :     Indicates whether or not results are to be returned in singleton mode. In
39 :     singleton mode, if the return document is a hash reference with only one
40 :     entry, the entry value is returned rather than the hash.
41 :    
42 :     =back
43 :    
44 :     =cut
45 :    
46 :     =head3 new
47 :    
48 : parrello 1.7 my $ss = ACHserver->new(%options);
49 : parrello 1.6
50 : parrello 1.7 Construct a new server object. The
51 :     following options are supported.
52 : parrello 1.6
53 :     =over 4
54 :    
55 :     =item url
56 : disz 1.1
57 : parrello 1.7 URL for the server. This option is required.
58 : disz 1.5
59 : parrello 1.7 =item singleton (optional)
60 : disz 1.5
61 : parrello 1.6 If TRUE, results from methods will be returned in singleton mode. In singleton
62 :     mode, if a single result comes back, it will come back as a scalar rather than
63 :     as a hash value accessible via an incoming ID.
64 : disz 1.1
65 : parrello 1.6 =back
66 : olson 1.3
67 : parrello 1.6 =cut
68 : disz 1.1
69 : parrello 1.6 sub new {
70 :     # Get the parameters.
71 :     my ($class, %options) = @_;
72 : parrello 1.7 # Turn off YAML compression, which causes problems with our hash keys.
73 :     $YAML::CompressSeries = 0;
74 : parrello 1.6 # Get the options.
75 : parrello 1.7 my $url = $options{url};
76 : parrello 1.6 my $singleton = $options{singleton} || 0;
77 : parrello 1.7 # Create the fields of the object. Note that if we're in localhost mode,
78 :     # the user agent is actually a SAP object.
79 : parrello 1.6 my $server_url = $url;
80 : parrello 1.7 my $ua;
81 :     if ($server_url ne 'localhost') {
82 :     require LWP::UserAgent;
83 :     $ua = LWP::UserAgent->new();
84 :     } else {
85 :     require "ACH.pm";
86 :     $ua = ACH->new();
87 :     }
88 :     # Create the server object.
89 : parrello 1.6 my $retVal = {
90 :     server_url => $server_url,
91 :     ua => $ua,
92 :     singleton => $singleton,
93 :     };
94 : parrello 1.7 # Bless it.
95 : parrello 1.6 bless $retVal, $class;
96 : parrello 1.7 # Get the list of permitted methods from the server.
97 :     my $methodList = $retVal->_call_method(methods => []);
98 :     # Convert it to a hash and store it in this object.
99 :     $retVal->{methodHash} = { map { $_ => 1 } @$methodList };
100 :     # Return the object.
101 : parrello 1.6 return $retVal;
102 : disz 1.1 }
103 :    
104 : parrello 1.6 =head3 AUTOLOAD
105 : disz 1.1
106 : parrello 1.7 my $result = $server->method(%args);
107 : disz 1.1
108 : parrello 1.6 Call a function on the server. Any method call on this object (other than
109 :     the constructor) is translated into a request against the server. This
110 :     enables us to add new server functions without requiring an update to this
111 : parrello 1.7 object or its parent. The parameters are usually specified as a hash, and the
112 :     result is a scalar or object reference. In some cases the parameters are a list.
113 :     To deistinguish between the two cases, all hash keys must begin with hyphens.
114 :    
115 :     If an error occurs, we will throw an exception.
116 : parrello 1.6
117 :     =cut
118 :    
119 :     # This variable will contain the method name.
120 :     our $AUTOLOAD;
121 :    
122 :     sub AUTOLOAD {
123 :     # Get the parameters. We do some fancy dancing to allow the user to pass
124 : parrello 1.7 # in a hash, a list, a list reference, or a hash reference.
125 : parrello 1.6 my $self = shift @_;
126 :     my $args = $_[0];
127 :     if (defined $args) {
128 :     if (scalar @_ gt 1) {
129 :     # Here we have multiple arguments. We check the first one for a
130 :     # leading hyphen.
131 :     if ($args =~ /^-/) {
132 :     # This means we have hash-form parameters.
133 :     my %args = @_;
134 :     $args = \%args;
135 :     } else {
136 :     # This means we have list-form parameters.
137 :     my @args = @_;
138 :     $args = \@args;
139 :     }
140 :     } else {
141 :     # Here we have a single argument. If it's a scalar, we convert it
142 :     # to a singleton list.
143 :     if (! ref $args) {
144 :     $args = [$args];
145 : disz 1.5 }
146 : parrello 1.6 }
147 :     }
148 :     # Declare the return variable.
149 :     my $retVal;
150 :     # Get the method name.
151 :     my $function = $AUTOLOAD;
152 :     # Strip off the stuff before the method name.
153 :     $function =~ s/.+:://;
154 : parrello 1.7 # Validate the method name.
155 :     if (! $self->{methodHash}{$function}) {
156 :     die "Method \"$function\" not supported.";
157 : parrello 1.6 } else {
158 : parrello 1.7 # Call the method.
159 :     $retVal = $self->_call_method($function, $args);
160 :     # We have our result. Adjust for singleton mode.
161 :     if ($self->{singleton} && ref $retVal eq 'HASH' && scalar(keys %$retVal) <= 1) {
162 :     # Here we're in singleton mode and we got a single result,
163 :     # so we dereference a bit to make it easier for the user
164 :     # to access it.
165 :     ($retVal) = values %$retVal;
166 : parrello 1.6 }
167 :     }
168 :     # Return the result.
169 :     return $retVal;
170 : disz 1.5 }
171 :    
172 : parrello 1.6 =head3 DESTROY
173 :    
174 :     $ss->DESTROY();
175 : disz 1.1
176 : parrello 1.6 This method has no function. It's purpose is to keep the destructor from
177 :     being caught by the autoload processing.
178 : disz 1.1
179 : parrello 1.6 =cut
180 : disz 1.1
181 : parrello 1.6 sub DESTROY { }
182 : disz 1.1
183 : parrello 1.7 =head2 Utility Methods
184 :    
185 :     =head3 _call_method
186 :    
187 :     my $result = $server->_call_method($method, $args);
188 :    
189 :     Call the specified method on the server with the specified arguments and
190 :     return the result. The arguments must already be packaged as a hash or
191 :     list reference. This method is the heart of the AUTOLOAD method, and is
192 :     provided as a utility for specialized methods that can't use the AUTOLOAD
193 :     facility.
194 :    
195 :     =over 4
196 :    
197 :     =item method
198 :    
199 :     Name of the server function being invoked.
200 :    
201 :     =item args
202 :    
203 :     Argument object to pass to the function.
204 :    
205 :     =item RETURN
206 :    
207 :     Returns a hash or list reference with the function results.
208 :    
209 :     =back
210 :    
211 :     =cut
212 :    
213 :     sub _call_method {
214 :     # Get the parameters.
215 :     my ($self, $method, $args) = @_;
216 :     # Declare the return variable.
217 :     my $retVal;
218 :     # Get our user agent.
219 :     my $ua = $self->{ua};
220 :     # Determine the type.
221 :     if (ref $ua eq 'LWP::UserAgent') {
222 :     # Here we're going to a server. Compute the argument document.
223 :     my $argString = YAML::Dump($args);
224 :     # Request the function from the server.
225 :     my $content = $self->_send_request(function => $method, args => $argString,
226 :     source => __PACKAGE__);
227 :     $retVal = YAML::Load($content);
228 :     } else {
229 :     # Here we're calling a local method.
230 :     $retVal = eval("\$ua->$method(\$args)");
231 :     # Check for an error.
232 :     if ($@) {
233 :     die "Package error: $@";
234 :     }
235 :     }
236 :     # Return the result.
237 :     return $retVal;
238 :     }
239 :    
240 :     =head3 _send_request
241 :    
242 :     my $result = $server->_send_request(%parms);
243 :    
244 :     Send a request to the server. This method must not be called in localhost
245 :     mode. If an error occurs, this method will die; otherwise, the content of
246 :     the response will be passed back as the result.
247 :    
248 :     =over 4
249 :    
250 :     =item parms
251 :    
252 :     Hash of CGI parameters to send to the server.
253 :    
254 :     =item RETURN
255 :    
256 :     Returns the string returned by the server in response to the request.
257 :    
258 :     =back
259 :    
260 :     =cut
261 :    
262 :     sub _send_request {
263 :     # Get the parameters.
264 :     my ($self, %parms) = @_;
265 :     # Get the user agent.
266 :     my $ua = $self->{ua};
267 :     # Request the function from the server. Note that the hash is actually passed
268 :     # as a list reference.
269 :     my $response = $ua->post($self->{server_url}, [ %parms ]);
270 :     # Get the response content.
271 :     my $retVal = $response->content;
272 :     # Fail if there was an error.
273 :     if (! $response->is_success) {
274 :     die ErrorMessage->new($retVal, $response->status_line);
275 :     }
276 :     # Return the result.
277 :     return $retVal;
278 :     }
279 :    
280 : disz 1.1
281 : parrello 1.6 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3