[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.6, Wed Sep 30 15:33:23 2009 UTC revision 1.7, Tue Nov 3 21:20:07 2009 UTC
# Line 7  Line 7 
7  use strict;  use strict;
8  use LWP::UserAgent;  use LWP::UserAgent;
9  use YAML;  use YAML;
10        use ErrorMessage;
11        no warnings qw(once);
12    
13  =head1 Annotation Clearinghouse Server Helper Object  =head1 Annotation Clearinghouse Server Helper Object
14    
# Line 43  Line 45 
45    
46  =head3 new  =head3 new
47    
48      my $ach = ACHserver->new(%options);      my $ss = ACHserver->new(%options);
49    
50  Construct a new ACHserver object. The following options are supported.  Construct a new server object. The
51    following options are supported.
52    
53  =over 4  =over 4
54    
55  =item url  =item url
56    
57  URL for the ACH server. This option may be used to redirect requests to a  URL for the server. This option is required.
 test version of the server, or to an older server script.  
58    
59  =item singleton  =item singleton (optional)
60    
61  If TRUE, results from methods will be returned in singleton mode. In singleton  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  mode, if a single result comes back, it will come back as a scalar rather than
# Line 67  Line 69 
69  sub new {  sub new {
70      # Get the parameters.      # Get the parameters.
71      my ($class, %options) = @_;      my ($class, %options) = @_;
72        # Turn off YAML compression, which causes problems with our hash keys.
73        $YAML::CompressSeries = 0;
74      # Get the options.      # Get the options.
75      my $url = $options{url} || "http://servers.nmpdr.org/ach/server.cgi";      my $url = $options{url};
76      my $singleton = $options{singleton} || 0;      my $singleton = $options{singleton} || 0;
77      # Create the fields of the object.      # 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;      my $server_url = $url;
80      my $ua = LWP::UserAgent->new();      my $ua;
81      # Create the SAPserver object.      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 = {      my $retVal = {
90                      server_url => $server_url,                      server_url => $server_url,
91                      ua => $ua,                      ua => $ua,
92                      singleton => $singleton,                      singleton => $singleton,
93                   };                   };
94      # Bless and return it.      # Bless it.
95      bless $retVal, $class;      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;      return $retVal;
102  }  }
103    
 =head2 Public Methods  
   
 All L<ACH/Primary Methods> are also methods of this object.  
   
104  =head3 AUTOLOAD  =head3 AUTOLOAD
105    
106      my $result = $ach->method(%args);      my $result = $server->method(%args);
107    
108  Call a function on the server. Any method call on this object (other than  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  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  enables us to add new server functions without requiring an update to this
111  module. The parameters are specified as a hash, and the result is a scalar  object or its parent. The parameters are usually specified as a hash, and the
112  or object reference. If an error occurred, we will throw an exception.  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  =cut
118    
# Line 105  Line 121 
121    
122  sub AUTOLOAD {  sub AUTOLOAD {
123      # Get the parameters. We do some fancy dancing to allow the user to pass      # Get the parameters. We do some fancy dancing to allow the user to pass
124      # in a hash, a list, or a hash reference.      # in a hash, a list, a list reference, or a hash reference.
125      my $self = shift @_;      my $self = shift @_;
126      my $args = $_[0];      my $args = $_[0];
127      if (defined $args) {      if (defined $args) {
# Line 135  Line 151 
151      my $function = $AUTOLOAD;      my $function = $AUTOLOAD;
152      # Strip off the stuff before the method name.      # Strip off the stuff before the method name.
153      $function =~ s/.+:://;      $function =~ s/.+:://;
154      # Compute the argument document.      # Validate the method name.
155      my $argString = YAML::Dump($args);      if (! $self->{methodHash}{$function}) {
156      # Get our user agent.          die "Method \"$function\" not supported.";
     my $ua = $self->{ua};  
     # Request the function from the server.  
     my $response = $ua->post($self->{server_url},  
                              [function => $function, args => $argString,  
                               source => __PACKAGE__ ]);  
     # Get the response content.  
     my $content = $response->content;  
     if (! $response->is_success) {  
         die "Server error " . $response->status_line . "\n$content";  
157      } else {      } else {
158          $retVal = YAML::Load($content);          # Call the method.
159          # Figure out what we got back.          $retVal = $self->_call_method($function, $args);
160          my $returnType = ref $retVal;          # We have our result. Adjust for singleton mode.
161          if ($returnType) {          if ($self->{singleton} && ref $retVal eq 'HASH' && scalar(keys %$retVal) <= 1) {
             if ($returnType eq 'ErrorDocument') {  
                 # Here an error occurred, so we throw an exception using the  
                 # error message.  
                 die $retVal->{message};  
             } elsif ($self->{singleton} && $returnType eq 'HASH' &&  
                      scalar(keys %$retVal) <= 1) {  
162                  # Here we're in singleton mode and we got a single result,                  # 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                  # so we dereference a bit to make it easier for the user
164                  # to access it.                  # to access it.
165                  ($retVal) = values %$retVal;                  ($retVal) = values %$retVal;
166              }              }
167          }          }
     }  
168      # Return the result.      # Return the result.
169      return $retVal;      return $retVal;
170  }  }
# Line 180  Line 180 
180    
181  sub DESTROY { }  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    =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    
281  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3