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

Diff of /FigKernelPackages/ACHserver.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2, Wed May 13 20:03:06 2009 UTC revision 1.7, Tue Nov 3 21:20:07 2009 UTC
# Line 1  Line 1 
1    
2  package ACHserver;  package ACHserver;
3    
4    #
5    # This is a SAS Component
6    #
7        use strict;
8  use LWP::UserAgent;  use LWP::UserAgent;
 use Data::Dumper;  
9  use YAML;  use YAML;
10        use ErrorMessage;
11        no warnings qw(once);
12    
13  use strict;  =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  sub new  =head3 new
 {  
     my($class, $server_url) = @_;  
47    
48      $server_url = "http://bio-macpro-2.mcs.anl.gov/~disz/FIG/ach_server.cgi" unless $server_url;      my $ss = ACHserver->new(%options);
     #$server_url = "http://bio-macpro-1.mcs.anl.gov/ross-proj/FIG/co_occurs_server.cgi" unless $server_url;  
49    
50      my $self = {  Construct a new server object. The
51    following options are supported.
52    
53    =over 4
54    
55    =item url
56    
57    URL for the server. This option is required.
58    
59    =item singleton (optional)
60    
61    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    
65    =back
66    
67    =cut
68    
69    sub new {
70        # Get the parameters.
71        my ($class, %options) = @_;
72        # Turn off YAML compression, which causes problems with our hash keys.
73        $YAML::CompressSeries = 0;
74        # Get the options.
75        my $url = $options{url};
76        my $singleton = $options{singleton} || 0;
77        # Create the fields of the object. Note that if we're in localhost mode,
78        # the user agent is actually a SAP object.
79        my $server_url = $url;
80        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        my $retVal = {
90          server_url => $server_url,          server_url => $server_url,
91          ua => LWP::UserAgent->new(),                      ua => $ua,
92                        singleton => $singleton,
93      };      };
94      return bless $self, $class;      # Bless it.
95        bless $retVal, $class;
96        # 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        return $retVal;
102  }  }
103    
104  sub equiv_precise {  =head3 AUTOLOAD
105          my ($self, @args) = @_;  
106          return $self->run_query("equiv_precise", @args);      my $result = $server->method(%args);
107    
108    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    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    
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        # in a hash, a list, a list reference, or a hash reference.
125        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                }
146            }
147  }  }
148  sub equiv_sequence {      # Declare the return variable.
149          my ($self, @args) = @_;      my $retVal;
150          return $self->run_query("equiv_sequence", @args);      # Get the method name.
151        my $function = $AUTOLOAD;
152        # Strip off the stuff before the method name.
153        $function =~ s/.+:://;
154        # Validate the method name.
155        if (! $self->{methodHash}{$function}) {
156            die "Method \"$function\" not supported.";
157        } else {
158            # 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  }  }
167        }
168        # Return the result.
169        return $retVal;
170    }
171    
172    =head3 DESTROY
173    
174        $ss->DESTROY();
175    
176    This method has no function. It's purpose is to keep the destructor from
177    being caught by the autoload processing.
178    
179    =cut
180    
181    sub DESTROY { }
182    
183    =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  sub run_query  =item RETURN
 {  
     my($self, $function, @args ) = @_;  
206    
207              my $arg_string = Dump(@args);  Returns a hash or list reference with the function results.
             my $form = [function => $function,  
                         args => "$arg_string"];  
208    
209              my $res = $self->{ua}->post($self->{server_url}, $form);  =back
210              if ($res->is_success)  
211              {  =cut
212                  return Load($res->content);  
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              }              }
             else  
             {  
                 die "error on post " . $res->content;  
235              }              }
236        # Return the result.
237        return $retVal;
238  }  }
239    
240    =head3 _send_request
241    
242  1;      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    
281    1;

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.7

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3