[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.5, Tue Jun 30 19:02:29 2009 UTC revision 1.6, Wed Sep 30 15:33:23 2009 UTC
# Line 4  Line 4 
4  #  #
5  # This is a SAS Component  # 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    
11  use strict;  =head1 Annotation Clearinghouse Server Helper Object
12    
13  #  =head2 Description
 # This is a SAS Component  
 #  
14    
15    This module is used to call the Annotation Clearinghouse Server, which is a
16    special-purpose server for assertion data from the Sapling database. Each
17    Annotation Clearinghouse Server function corresponds to a method of this object.
18    
19  sub new  This package deliberately uses no internal SEED packages or scripts, only common
20  {  PERL modules.
     my($class, $server_url) = @_;  
21    
22      $server_url = "http://servers.nmpdr.org/ach/server.cgi" unless $server_url;  The fields in this object are as follows.
23    
24  #    $server_url = "http://bio-macpro-2.mcs.anl.gov/~disz/FIG/ach_server.cgi" unless $server_url;  =over 4
     #$server_url = "http://bio-macpro-1.mcs.anl.gov/ross-proj/FIG/co_occurs_server.cgi" unless $server_url;  
25    
26      my $self = {  =item server_url
         server_url => $server_url,  
         ua => LWP::UserAgent->new(),  
     };  
     return bless $self, $class;  
 }  
27    
28  sub equiv_precise {  The URL used to request data from the subsystem server.
         my ($self, @args) = @_;  
         return $self->run_query("equiv_precise", @args);  
 }  
 sub equiv_sequence {  
         my ($self, @args) = @_;  
         return $self->run_query("equiv_sequence", @args);  
 }  
29    
30    =item ua
31    
32  sub run_query  The user agent for communication with the server.
 {  
     my($self, $function, @args ) = @_;  
33    
34              my $arg_string = Dump(@args);  =item singleton
             my $form = [function => $function,  
                         args => "$arg_string"];  
35    
36              my $res = $self->{ua}->post($self->{server_url}, $form);  Indicates whether or not results are to be returned in singleton mode. In
37              if ($res->is_success)  singleton mode, if the return document is a hash reference with only one
38              {  entry, the entry value is returned rather than the hash.
39                  return Load($res->content);  
40              }  =back
41              else  
42              {  =cut
                 die "error on post " . $res->content;  
             }  
 }  
43    
44  sub run_query_bad  =head3 new
 {  
     my($self, $function, @args ) = @_;  
45    
46              my $arg_string = Dump(@args);      my $ach = ACHserver->new(%options);
             my $form = [function => $function,  
                         args => "$arg_string"];  
47    
48              my $res = $self->{ua}->post($self->{server_url}, $form);  Construct a new ACHserver object. The following options are supported.
49              if ($res->is_success)  
50              {  =over 4
51  print Dumper $res;  
52                  my $rc;  =item url
53                  eval {  
54                      $rc = Load($res->content);  URL for the ACH server. This option may be used to redirect requests to a
55    test version of the server, or to an older server script.
56    
57    =item singleton
58    
59    If TRUE, results from methods will be returned in singleton mode. In singleton
60    mode, if a single result comes back, it will come back as a scalar rather than
61    as a hash value accessible via an incoming ID.
62    
63    =back
64    
65    =cut
66    
67    sub new {
68        # Get the parameters.
69        my ($class, %options) = @_;
70        # Get the options.
71        my $url = $options{url} || "http://servers.nmpdr.org/ach/server.cgi";
72        my $singleton = $options{singleton} || 0;
73        # Create the fields of the object.
74        my $server_url = $url;
75        my $ua = LWP::UserAgent->new();
76        # Create the SAPserver object.
77        my $retVal = {
78                        server_url => $server_url,
79                        ua => $ua,
80                        singleton => $singleton,
81                  };                  };
82                  if ($@)      # Bless and return it.
83                  {      bless $retVal, $class;
84                      die "Bad YAML parse $@ on input\n" .  $res->content;      return $retVal;
85                  }  }
86              }  
87              else  =head2 Public Methods
88              {  
89                  die "error on post " . $res->status_line . " " . $res->content;  All L<ACH/Primary Methods> are also methods of this object.
90              }  
91  }  =head3 AUTOLOAD
92    
93        my $result = $ach->method(%args);
94    
95    Call a function on the server. Any method call on this object (other than
96    the constructor) is translated into a request against the server. This
97    enables us to add new server functions without requiring an update to this
98    module. The parameters are specified as a hash, and the result is a scalar
99    or object reference. If an error occurred, we will throw an exception.
100    
101    =cut
102    
103    # This variable will contain the method name.
104    our $AUTOLOAD;
105    
106    sub AUTOLOAD {
107        # Get the parameters. We do some fancy dancing to allow the user to pass
108        # in a hash, a list, or a hash reference.
109        my $self = shift @_;
110        my $args = $_[0];
111        if (defined $args) {
112            if (scalar @_ gt 1) {
113                # Here we have multiple arguments. We check the first one for a
114                # leading hyphen.
115                if ($args =~ /^-/) {
116                    # This means we have hash-form parameters.
117                    my %args = @_;
118                    $args = \%args;
119                } else {
120                    # This means we have list-form parameters.
121                    my @args = @_;
122                    $args = \@args;
123                }
124            } else {
125                # Here we have a single argument. If it's a scalar, we convert it
126                # to a singleton list.
127                if (! ref $args) {
128                    $args = [$args];
129                }
130            }
131        }
132        # Declare the return variable.
133        my $retVal;
134        # Get the method name.
135        my $function = $AUTOLOAD;
136        # Strip off the stuff before the method name.
137        $function =~ s/.+:://;
138        # Compute the argument document.
139        my $argString = YAML::Dump($args);
140        # Get our user agent.
141        my $ua = $self->{ua};
142        # Request the function from the server.
143        my $response = $ua->post($self->{server_url},
144                                 [function => $function, args => $argString,
145                                  source => __PACKAGE__ ]);
146        # Get the response content.
147        my $content = $response->content;
148        if (! $response->is_success) {
149            die "Server error " . $response->status_line . "\n$content";
150        } else {
151            $retVal = YAML::Load($content);
152            # Figure out what we got back.
153            my $returnType = ref $retVal;
154            if ($returnType) {
155                if ($returnType eq 'ErrorDocument') {
156                    # Here an error occurred, so we throw an exception using the
157                    # error message.
158                    die $retVal->{message};
159                } elsif ($self->{singleton} && $returnType eq 'HASH' &&
160                         scalar(keys %$retVal) <= 1) {
161                    # Here we're in singleton mode and we got a single result,
162                    # so we dereference a bit to make it easier for the user
163                    # to access it.
164                    ($retVal) = values %$retVal;
165                }
166            }
167        }
168        # Return the result.
169        return $retVal;
170    }
171    
172    =head3 DESTROY
173    
174        $ss->DESTROY();
175    
176  1;  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    
184    1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3