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

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.13

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3