[Bio] / FigWebServices / AttribXMLRPC.cgi Repository:
ViewVC logotype

Annotation of /FigWebServices/AttribXMLRPC.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (view) (download)

1 : olson 1.1 #
2 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
3 :     # for Interpretations of Genomes. All Rights Reserved.
4 :     #
5 :     # This file is part of the SEED Toolkit.
6 :     #
7 :     # The SEED Toolkit is free software. You can redistribute
8 :     # it and/or modify it under the terms of the SEED Toolkit
9 :     # Public License.
10 :     #
11 :     # You should have received a copy of the SEED Toolkit Public License
12 :     # along with this program; if not write to the University of Chicago
13 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14 :     # Genomes at veronika@thefig.info or download a copy from
15 :     # http://www.theseed.org/LICENSE.TXT.
16 :     #
17 :    
18 :     use Frontier::RPC2;
19 :    
20 :     use FIG;
21 :     use CustomAttributes;
22 :     use strict;
23 :    
24 :    
25 :     package FrontierXMLRPCWrapper;
26 :    
27 :     #
28 :     # We'll make a class to hold the fig instance and the
29 :     # XMLRPC server instance; this will make it easier to invoke the
30 :     # wrapping functions (since each one will need these values).
31 :     #
32 :    
33 :    
34 :     #
35 :     # Constructor.
36 :     #
37 :     sub new
38 :     {
39 :     my($class, $attr, $xmlrpc) = @_;
40 :    
41 :     my $self = {
42 :     attributes => $attr,
43 :     xmlrpc => $xmlrpc,
44 :     };
45 :    
46 :     return bless $self, $class;
47 :     }
48 :    
49 :    
50 :     #
51 :     # Return a value properly coerced to a string for passing
52 :     # as an XMLRPC return. Use the string() method on the
53 :     # xmlrpc instance variable.
54 :     #
55 :     sub coerce_to_string
56 :     {
57 :     my($self, $value) = @_;
58 :    
59 : olson 1.2 my $new;
60 :     if (ref($value) eq "ARRAY")
61 :     {
62 :     $new = [];
63 :     for my $v (@$value)
64 :     {
65 :     push(@$new, $self->coerce_to_string($v));
66 :     }
67 :     }
68 :     elsif (ref($value) eq "HASH")
69 :     {
70 :     $new = {};
71 :     for my $k (keys(%$value))
72 :     {
73 :     $new->{$k} = $self->coerce_to_string($value->{$k});
74 :     }
75 :     }
76 : olson 1.4 elsif ($value =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/)
77 :     {
78 :     $new = $self->{xmlrpc}->string($value);
79 :     }
80 : olson 1.2 else
81 :     {
82 : olson 1.4 $new = $value;
83 : olson 1.2 }
84 :     return $new;
85 : olson 1.1 }
86 :    
87 :     #
88 :     # Wrap a FIG method that returns a scalar.
89 :     #
90 :    
91 :     sub wrap_scalar_return
92 :     {
93 :     my($self, $func) = @_;
94 :    
95 :     #
96 :     # We return a new anonymous subroutine that invokes the
97 :     # routine thru the $fig instance saved in our instance variables.
98 :     #
99 :    
100 :     return sub {
101 :     my $ret;
102 :    
103 :     $ret = $self->{attributes}->$func(@_);
104 :    
105 :     #
106 :     # Coerce to string if we need to.
107 :     #
108 :    
109 :     if (!ref($ret))
110 :     {
111 :     $ret = $self->coerce_to_string($ret);
112 :     }
113 :    
114 :     return $ret;
115 :     }
116 :     }
117 :    
118 :     #
119 :     # Wrap a FIG method that returns a list. The list needs to be
120 :     # converted into a list reference instead of a plain list.
121 :     #
122 :    
123 :     sub wrap_array_return
124 :     {
125 :     my($self, $func) = @_;
126 :    
127 :     #
128 :     # We return a new anonymous subroutine that invokes the
129 :     # routine thru the $fig instance saved in our instance variables.
130 :     #
131 :    
132 :     return sub {
133 :     my $ret;
134 :     my @func_ret;
135 :    
136 :     $ret = [];
137 :    
138 :     #
139 :     # Invoke the function.
140 :     #
141 :     @func_ret = $self->{attributes}->$func(@_);
142 :    
143 :     #
144 :     # For each value returned, if it isn't a reference (to a list, for instance),
145 :     # coerce it to a string.
146 :     #
147 :     # Push each value to the list we're creating.
148 :     #
149 :     for $_ (@func_ret)
150 :     {
151 : olson 1.2 push(@$ret, $self->coerce_to_string($_));
152 : olson 1.1 }
153 :     return $ret;
154 :     }
155 :     }
156 :    
157 :     #
158 :     # back in the main package, finished with class definition.
159 :     #
160 :    
161 :     package main;
162 :    
163 :     $| = 1; # Perl magic to use unbuffered output on standard output
164 :    
165 :     my $xml_rpc_server = Frontier::RPC2->new;
166 :    
167 :     my $attr = CustomAttributes->new();
168 :    
169 :     #
170 :     # Create a wrapper-helper object.
171 :     #
172 :    
173 :     my $wrapper = new FrontierXMLRPCWrapper($attr, $xml_rpc_server);
174 :    
175 :     #
176 :     # Create a list of the methods to be served
177 :     #
178 :    
179 :     my $methods = {
180 : parrello 1.3 'GetAttributes' => $wrapper->wrap_array_return("GetAttributes"),
181 :     'AddAttribute' => $wrapper->wrap_scalar_return("AddAttribute"),
182 :     'DeleteAttribute' => $wrapper->wrap_scalar_return("DeleteAttribute"),
183 :     'ChangeAttribute' => $wrapper->wrap_scalar_return("ChangeAttribute"),
184 : parrello 1.5 'EraseAttribute' => $wrapper->wrap_scalar_return("EraseAttribute"),
185 : parrello 1.6 'GetAttributeKeys' => $wrapper->wrap_array_return("GetAttributeKeys"),
186 : parrello 1.9 'GetAttributeData' => $wrapper->wrap_array_return("GetAttributeData"),
187 : parrello 1.8 'DeleteMatchingAttributes' => $wrapper->wrap_array_return("DeleteMatchingAttributes"),
188 :     'QueryAttributes' => $wrapper->wrap_array_return("QueryAttributes")
189 : olson 1.1 };
190 :    
191 :     process_cgi_call($methods);
192 :    
193 :     #==========================================================================
194 :     # CGI Support
195 :     #==========================================================================
196 :     # Simple CGI support for Frontier::RPC2. You can copy this into your CGI
197 :     # scripts verbatim, or you can package it into a library.
198 :     # (Based on xmlrpc_cgi.c by Eric Kidd <http://xmlrpc-c.sourceforge.net/>.)
199 :    
200 :     # Process a CGI call.
201 :     sub process_cgi_call ($) {
202 :     my ($methods) = @_;
203 :    
204 :     # Get our CGI request information.
205 :     my $method = $ENV{'REQUEST_METHOD'};
206 :     my $type = $ENV{'CONTENT_TYPE'};
207 :     my $length = $ENV{'CONTENT_LENGTH'};
208 :    
209 :     # Perform some sanity checks.
210 :     http_error(405, "Method Not Allowed") unless $method eq "POST";
211 :     http_error(400, "Bad Request") unless $type eq "text/xml";
212 :     http_error(411, "Length Required") unless $length > 0;
213 :    
214 :     # Fetch our body.
215 :     my $body;
216 :     my $count = read STDIN, $body, $length;
217 :     http_error(400, "Bad Request") unless $count == $length;
218 :    
219 :     # Serve our request.
220 :     my $coder = Frontier::RPC2->new;
221 :     send_xml($coder->serve($body, $methods));
222 :     }
223 :    
224 :     # Send an HTTP error and exit.
225 :     sub http_error ($$) {
226 :     my ($code, $message) = @_;
227 :     print <<"EOD";
228 :     Status: $code $message
229 :     Content-type: text/html
230 :    
231 :     <title>$code $message</title>
232 :     <h1>$code $message</h1>
233 :     <p>Unexpected error processing XML-RPC request.</p>
234 :     EOD
235 :     exit 0;
236 :     }
237 :    
238 :     # Send an XML document (but don't exit).
239 :     sub send_xml ($) {
240 :     my ($xml_string) = @_;
241 :     my $length = length($xml_string);
242 :     print <<"EOD";
243 :     Status: 200 OK
244 :     Content-type: text/xml
245 :     Content-length: $length
246 :    
247 :     EOD
248 :     # We want precise control over whitespace here.
249 :     print $xml_string;
250 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3