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

Diff of /FigKernelPackages/SAPserver.pm

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

revision 1.1, Tue Jun 16 16:37:23 2009 UTC revision 1.8, Tue Sep 8 21:31:32 2009 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl -w  #!/usr/bin/perl -w
2    #
3    #       This is a SAS Component.
4  #  #
5  # Copyright (c) 2003-2006 University of Chicago and Fellowship  # Copyright (c) 2003-2006 University of Chicago and Fellowship
6  # for Interpretations of Genomes. All Rights Reserved.  # for Interpretations of Genomes. All Rights Reserved.
# Line 20  Line 21 
21  package SAPserver;  package SAPserver;
22    
23      use strict;      use strict;
     use Tracer;  
     use LWP::UserAgent;  
24      use YAML;      use YAML;
25    
26  =head1 Sapling Server Helper Object  =head1 Sapling Server Helper Object
27    
28  =head2 Introduction  =head2 Description
29    
30  This module is used to call the sapling server, which is a general-purpose  This module is used to call the sapling server, which is a general-purpose
31  server for extracting data from the Sapling database. Each Sapling server  server for extracting data from the Sapling database. Each Sapling server
32  function correspond to a method of this object.  function correspond to a method of this object.
33    
34    This package deliberately uses no internal SEED packages or scripts, only common
35    PERL modules.
36    
37  The fields in this object are as follows.  The fields in this object are as follows.
38    
39  =over 4  =over 4
40    
41  =item server_url  =item server_url
42    
43  The URL used to request data from the sapling server.  The URL used to request data from the sapling server. If C<localhost> is
44    specified, then the L<SAP> module will be called directly.
45    
46  =item ua  =item ua
47    
48  The user agent for communication with the server.  The user agent for communication with the server.
49    
50    =item singleton
51    
52    Indicates whether or not results are to be returned in singleton mode. In
53    singleton mode, if the return document is a hash reference with only one
54    entry, the entry value is returned rather than the hash.
55    
56  =back  =back
57    
58  =cut  =cut
# Line 61  Line 70 
70  URL for the sapling server. This option may be used to redirect requests to a  URL for the sapling server. This option may be used to redirect requests to a
71  test version of the server, or to an older server script.  test version of the server, or to an older server script.
72    
73    =item singleton
74    
75    If TRUE, results from methods will be returned in singleton mode. In singleton
76    mode, if a single result comes back, it will come back as a scalar rather than
77    as a hash value accessible via an incoming ID.
78    
79  =back  =back
80    
81  =cut  =cut
# Line 69  Line 84 
84      # Get the parameters.      # Get the parameters.
85      my ($class, %options) = @_;      my ($class, %options) = @_;
86      # Get the options.      # Get the options.
87      my $url = $options{url} || "http://servers.nmpdr.org/sap/server.cgi";      my $url = $options{url} || "http://servers.nmpdr.org/sapling/server.cgi";
88      # Create the fields of the object.      my $singleton = $options{singleton} || 0;
89        # Create the fields of the object. Note that if we're in localhost mode,
90        # the user agent is actually a SAP object.
91      my $server_url = $url;      my $server_url = $url;
92      my $ua = LWP::UserAgent->new();      my $ua;
93        if ($server_url ne 'localhost') {
94            require LWP::UserAgent;
95            $ua = LWP::UserAgent->new();
96        } else {
97            require SAP;
98            $ua = SAP->new();
99        }
100      # Create the SAPserver object.      # Create the SAPserver object.
101      my $retVal = {      my $retVal = {
102                      server_url => $server_url,                      server_url => $server_url,
103                      ua => $ua,                      ua => $ua,
104                        singleton => $singleton,
105                   };                   };
106      # Bless and return it.      # Bless and return it.
107      bless $retVal, $class;      bless $retVal, $class;
# Line 85  Line 110 
110    
111  =head2 Public Methods  =head2 Public Methods
112    
113    All L<SAP/Primary Methods> are also methods of this object.
114    
115  =head3 AUTOLOAD  =head3 AUTOLOAD
116    
117      my $result = $ss->method(%args);      my $result = $ss->method(%args);
# Line 93  Line 120 
120  the constructor) is translated into a request against the server. This  the constructor) is translated into a request against the server. This
121  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
122  module. The parameters are specified as a hash, and the result is a scalar  module. The parameters are specified as a hash, and the result is a scalar
123  or object reference. If an error occurred, we will confess.  or object reference. If an error occurred, we will throw an exception.
124    
125  =cut  =cut
126    
# Line 101  Line 128 
128  our $AUTOLOAD;  our $AUTOLOAD;
129    
130  sub AUTOLOAD {  sub AUTOLOAD {
131      # Get the parameters.      # Get the parameters. We do some fancy dancing to allow the user to pass
132      my ($self, %args) = @_;      # in a hash or a hash reference.
133        my $self = shift @_;
134        my $args = $_[0];
135        if (defined $args && ref $args ne 'HASH') {
136            my %args = @_;
137            $args = \%args;
138        }
139      # Declare the return variable.      # Declare the return variable.
140      my $retVal;      my $retVal;
141      # Get the method name.      # Get the method name.
142      my $function = $AUTOLOAD;      my $function = $AUTOLOAD;
143        # Strip off the stuff before the method name.
144      $function =~ s/.+:://;      $function =~ s/.+:://;
     # Compute the argument document.  
     my $argString = YAML::Dump(\%args);  
145      # Get our user agent.      # Get our user agent.
146      my $ua = $self->{ua};      my $ua = $self->{ua};
147        # Determine the type.
148        if (ref $ua eq 'LWP::UserAgent') {
149            # Here we're going to a server. Compute the argument document.
150            my $argString = YAML::Dump($args);
151      # Request the function from the server.      # Request the function from the server.
152      my $response = $ua->post($self->{server_url},      my $response = $ua->post($self->{server_url},
153                               [function => $function, args => $argString]);                                   [function => $function, args => $argString,
154                                      source => __PACKAGE__ ]);
155      # Get the response content.      # Get the response content.
156      my $content = $response->content;      my $content = $response->content;
157      if (! $response->is_success) {      if (! $response->is_success) {
158          Confess("Server error " . $response->status_line . "\n$content");              die "Server error " . $response->status_line . "\n$content";
159      } else {      } else {
         Trace("YAML document is\n$content.") if T(3);  
160          $retVal = YAML::Load($content);          $retVal = YAML::Load($content);
161          # Figure out what we got back.          # Figure out what we got back.
         Trace("Checking for an error document.") if T(3);  
162          my $returnType = ref $retVal;          my $returnType = ref $retVal;
163          if ($returnType && $returnType eq 'ErrorDocument') {              if ($returnType) {
164              Confess($retVal->{message});                  if ($returnType eq 'ErrorDocument') {
165                        # Here an error occurred, so we throw an exception using the
166                        # error message.
167                        die $retVal->{message};
168                    }
169                }
170            }
171        } else {
172            # Here we're calling a local method.
173            $retVal = eval("\$ua->$function(\$args)");
174            # Check for an error.
175            if ($@) {
176                die "Package error: $@";
177            }
178          }          }
179        # We have our result. Adjust for singleton mode.
180        if ($self->{singleton} && ref $retVal eq 'HASH' && scalar(keys %$retVal) <= 1) {
181            # Here we're in singleton mode and we got a single result,
182            # so we dereference a bit to make it easier for the user
183            # to access it.
184            ($retVal) = values %$retVal;
185      }      }
186      # Return the result.      # Return the result.
187      return $retVal;      return $retVal;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3