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

Diff of /FigKernelPackages/SSserver.pm

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

revision 1.10, Thu Aug 27 19:46:36 2009 UTC revision 1.11, Tue Nov 3 21:20:07 2009 UTC
# Line 6  Line 6 
6    
7  use LWP::UserAgent;  use LWP::UserAgent;
8  use YAML;  use YAML;
9    use ErrorMessage;
10    no warnings qw(once);
11    
12  use strict;  use strict;
13    
# Line 46  Line 48 
48    
49      my $ss = SSserver->new(%options);      my $ss = SSserver->new(%options);
50    
51  Construct a new SSserver object. The following options are supported.  Construct a new server object. The
52    following options are supported.
53    
54  =over 4  =over 4
55    
56  =item url  =item url
57    
58  URL for the subsystem 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.  
59    
60  =item singleton  =item singleton (optional)
61    
62  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
63  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 68  Line 70 
70  sub new {  sub new {
71      # Get the parameters.      # Get the parameters.
72      my ($class, %options) = @_;      my ($class, %options) = @_;
73        # Turn off YAML compression, which causes problems with our hash keys.
74        $YAML::CompressSeries = 0;
75      # Get the options.      # Get the options.
76      my $url = $options{url} || "http://servers.nmpdr.org/subsystem/server.cgi";      my $url = $options{url};
77      my $singleton = $options{singleton} || 0;      my $singleton = $options{singleton} || 0;
78      # Create the fields of the object.      # Create the fields of the object. Note that if we're in localhost mode,
79        # the user agent is actually a SAP object.
80      my $server_url = $url;      my $server_url = $url;
81      my $ua = LWP::UserAgent->new();      my $ua;
82      # Create the SAPserver object.      if ($server_url ne 'localhost') {
83            require LWP::UserAgent;
84            $ua = LWP::UserAgent->new();
85        } else {
86            require "SS.pm";
87            $ua = SS->new();
88        }
89        # Create the server object.
90      my $retVal = {      my $retVal = {
91                      server_url => $server_url,                      server_url => $server_url,
92                      ua => $ua,                      ua => $ua,
93                      singleton => $singleton,                      singleton => $singleton,
94                   };                   };
95      # Bless and return it.      # Bless it.
96      bless $retVal, $class;      bless $retVal, $class;
97        # Get the list of permitted methods from the server.
98        my $methodList = $retVal->_call_method(methods => []);
99        # Convert it to a hash and store it in this object.
100        $retVal->{methodHash} = { map { $_ => 1 } @$methodList };
101        # Return the object.
102      return $retVal;      return $retVal;
103  }  }
104    
 =head2 Public Methods  
   
 All L<SS/Primary Methods> are also methods of this object.  
   
105  =head3 AUTOLOAD  =head3 AUTOLOAD
106    
107      my $result = $ss->method(%args);      my $result = $server->method(%args);
108    
109  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
110  the constructor) is translated into a request against the server. This  the constructor) is translated into a request against the server. This
111  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
112  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
113  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.
114    To deistinguish between the two cases, all hash keys must begin with hyphens.
115    
116    If an error occurs, we will throw an exception.
117    
118  =cut  =cut
119    
# Line 106  Line 122 
122    
123  sub AUTOLOAD {  sub AUTOLOAD {
124      # 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
125      # in a hash, a list, or a hash reference.      # in a hash, a list, a list reference, or a hash reference.
126      my $self = shift @_;      my $self = shift @_;
127      my $args = $_[0];      my $args = $_[0];
128      if (defined $args) {      if (defined $args) {
# Line 136  Line 152 
152      my $function = $AUTOLOAD;      my $function = $AUTOLOAD;
153      # Strip off the stuff before the method name.      # Strip off the stuff before the method name.
154      $function =~ s/.+:://;      $function =~ s/.+:://;
155      # Compute the argument document.      # Validate the method name.
156      my $argString = YAML::Dump($args);      if (! $self->{methodHash}{$function}) {
157      # 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";  
158      } else {      } else {
159          $retVal = YAML::Load($content);          # Call the method.
160          # Figure out what we got back.          $retVal = $self->_call_method($function, $args);
161          my $returnType = ref $retVal;          # We have our result. Adjust for singleton mode.
162          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) {  
163                  # Here we're in singleton mode and we got a single result,                  # Here we're in singleton mode and we got a single result,
164                  # so we dereference a bit to make it easier for the user                  # so we dereference a bit to make it easier for the user
165                  # to access it.                  # to access it.
166                  ($retVal) = values %$retVal;                  ($retVal) = values %$retVal;
167              }              }
168          }          }
     }  
169      # Return the result.      # Return the result.
170      return $retVal;      return $retVal;
171  }  }
# Line 181  Line 181 
181    
182  sub DESTROY { }  sub DESTROY { }
183    
184    =head2 Utility Methods
185    
186    =head3 _call_method
187    
188        my $result = $server->_call_method($method, $args);
189    
190    Call the specified method on the server with the specified arguments and
191    return the result. The arguments must already be packaged as a hash or
192    list reference. This method is the heart of the AUTOLOAD method, and is
193    provided as a utility for specialized methods that can't use the AUTOLOAD
194    facility.
195    
196    =over 4
197    
198    =item method
199    
200    Name of the server function being invoked.
201    
202    =item args
203    
204    Argument object to pass to the function.
205    
206    =item RETURN
207    
208    Returns a hash or list reference with the function results.
209    
210    =back
211    
212    =cut
213    
214    sub _call_method {
215        # Get the parameters.
216        my ($self, $method, $args) = @_;
217        # Declare the return variable.
218        my $retVal;
219        # Get our user agent.
220        my $ua = $self->{ua};
221        # Determine the type.
222        if (ref $ua eq 'LWP::UserAgent') {
223            # Here we're going to a server. Compute the argument document.
224            my $argString = YAML::Dump($args);
225            # Request the function from the server.
226            my $content = $self->_send_request(function => $method, args => $argString,
227                                               source => __PACKAGE__);
228            $retVal = YAML::Load($content);
229        } else {
230            # Here we're calling a local method.
231            $retVal = eval("\$ua->$method(\$args)");
232            # Check for an error.
233            if ($@) {
234                die "Package error: $@";
235            }
236        }
237        # Return the result.
238        return $retVal;
239    }
240    
241    =head3 _send_request
242    
243        my $result = $server->_send_request(%parms);
244    
245    Send a request to the server. This method must not be called in localhost
246    mode. If an error occurs, this method will die; otherwise, the content of
247    the response will be passed back as the result.
248    
249    =over 4
250    
251    =item parms
252    
253    Hash of CGI parameters to send to the server.
254    
255    =item RETURN
256    
257    Returns the string returned by the server in response to the request.
258    
259    =back
260    
261    =cut
262    
263    sub _send_request {
264        # Get the parameters.
265        my ($self, %parms) = @_;
266        # Get the user agent.
267        my $ua = $self->{ua};
268        # Request the function from the server. Note that the hash is actually passed
269        # as a list reference.
270        my $response = $ua->post($self->{server_url}, [ %parms ]);
271        # Get the response content.
272        my $retVal = $response->content;
273        # Fail if there was an error.
274        if (! $response->is_success) {
275            die ErrorMessage->new($retVal, $response->status_line);
276        }
277        # Return the result.
278        return $retVal;
279    }
280    
281    
282  1;  1;

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3