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

Annotation of /FigKernelPackages/SSserver.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (view) (download) (as text)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3