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

Annotation of /FigWebServices/AttribXMLRPC.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (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 :     return $self->{xmlrpc}->string($value);
60 :     }
61 :    
62 :     #
63 :     # Wrap a FIG method that returns a scalar.
64 :     #
65 :    
66 :     sub wrap_scalar_return
67 :     {
68 :     my($self, $func) = @_;
69 :    
70 :     #
71 :     # We return a new anonymous subroutine that invokes the
72 :     # routine thru the $fig instance saved in our instance variables.
73 :     #
74 :    
75 :     return sub {
76 :     my $ret;
77 :    
78 :     $ret = $self->{attributes}->$func(@_);
79 :    
80 :     #
81 :     # Coerce to string if we need to.
82 :     #
83 :    
84 :     if (!ref($ret))
85 :     {
86 :     $ret = $self->coerce_to_string($ret);
87 :     }
88 :    
89 :     return $ret;
90 :     }
91 :     }
92 :    
93 :     #
94 :     # Wrap a FIG method that returns a list. The list needs to be
95 :     # converted into a list reference instead of a plain list.
96 :     #
97 :    
98 :     sub wrap_array_return
99 :     {
100 :     my($self, $func) = @_;
101 :    
102 :     #
103 :     # We return a new anonymous subroutine that invokes the
104 :     # routine thru the $fig instance saved in our instance variables.
105 :     #
106 :    
107 :     return sub {
108 :     my $ret;
109 :     my @func_ret;
110 :    
111 :     $ret = [];
112 :    
113 :     #
114 :     # Invoke the function.
115 :     #
116 :     @func_ret = $self->{attributes}->$func(@_);
117 :    
118 :     #
119 :     # For each value returned, if it isn't a reference (to a list, for instance),
120 :     # coerce it to a string.
121 :     #
122 :     # Push each value to the list we're creating.
123 :     #
124 :     for $_ (@func_ret)
125 :     {
126 :     if (ref($_))
127 :     {
128 :     push(@$ret, $_);
129 :     }
130 :     else
131 :     {
132 :     push(@$ret, $self->coerce_to_string($_));
133 :     }
134 :     }
135 :     return $ret;
136 :     }
137 :     }
138 :    
139 :     #
140 :     # back in the main package, finished with class definition.
141 :     #
142 :    
143 :     package main;
144 :    
145 :     $| = 1; # Perl magic to use unbuffered output on standard output
146 :    
147 :     my $xml_rpc_server = Frontier::RPC2->new;
148 :    
149 :     my $attr = CustomAttributes->new();
150 :    
151 :     #
152 :     # Create a wrapper-helper object.
153 :     #
154 :    
155 :     my $wrapper = new FrontierXMLRPCWrapper($attr, $xml_rpc_server);
156 :    
157 :     #
158 :     # Create a list of the methods to be served
159 :     #
160 :    
161 :     my $methods = {
162 :     'GetAll' => $wrapper->wrap_array_return("GetAll"),
163 :     'InsertValue' => $wrapper->wrap_scalar_return("InsertValue"),
164 :     'DeleteValue' => $wrapper->wrap_scalar_return("DeleteValue"),
165 :     'GetSecondaryFields' => $wrapper->wrap_array_return("GetSecondaryFields"),
166 :     };
167 :    
168 :     process_cgi_call($methods);
169 :    
170 :     #==========================================================================
171 :     # CGI Support
172 :     #==========================================================================
173 :     # Simple CGI support for Frontier::RPC2. You can copy this into your CGI
174 :     # scripts verbatim, or you can package it into a library.
175 :     # (Based on xmlrpc_cgi.c by Eric Kidd <http://xmlrpc-c.sourceforge.net/>.)
176 :    
177 :     # Process a CGI call.
178 :     sub process_cgi_call ($) {
179 :     my ($methods) = @_;
180 :    
181 :     # Get our CGI request information.
182 :     my $method = $ENV{'REQUEST_METHOD'};
183 :     my $type = $ENV{'CONTENT_TYPE'};
184 :     my $length = $ENV{'CONTENT_LENGTH'};
185 :    
186 :     # Perform some sanity checks.
187 :     http_error(405, "Method Not Allowed") unless $method eq "POST";
188 :     http_error(400, "Bad Request") unless $type eq "text/xml";
189 :     http_error(411, "Length Required") unless $length > 0;
190 :    
191 :     # Fetch our body.
192 :     my $body;
193 :     my $count = read STDIN, $body, $length;
194 :     http_error(400, "Bad Request") unless $count == $length;
195 :    
196 :     # Serve our request.
197 :     my $coder = Frontier::RPC2->new;
198 :     send_xml($coder->serve($body, $methods));
199 :     }
200 :    
201 :     # Send an HTTP error and exit.
202 :     sub http_error ($$) {
203 :     my ($code, $message) = @_;
204 :     print <<"EOD";
205 :     Status: $code $message
206 :     Content-type: text/html
207 :    
208 :     <title>$code $message</title>
209 :     <h1>$code $message</h1>
210 :     <p>Unexpected error processing XML-RPC request.</p>
211 :     EOD
212 :     exit 0;
213 :     }
214 :    
215 :     # Send an XML document (but don't exit).
216 :     sub send_xml ($) {
217 :     my ($xml_string) = @_;
218 :     my $length = length($xml_string);
219 :     print <<"EOD";
220 :     Status: 200 OK
221 :     Content-type: text/xml
222 :     Content-length: $length
223 :    
224 :     EOD
225 :     # We want precise control over whitespace here.
226 :     print $xml_string;
227 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3