[Bio] / FigKernelScripts / fig_xmlrpc_server.pl Repository:
ViewVC logotype

Annotation of /FigKernelScripts/fig_xmlrpc_server.pl

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.1 #
2 :     # XMLRPC server to provide network access to FIG routines.
3 :     #
4 :     # We create a single FIG instance to use for all calls.
5 :     #
6 :     # This is originally intended for the support of the Python interface.
7 :     #
8 :    
9 : olson 1.2 my @util_funcs = qw(
10 :     enqueue_similarities
11 :     plug_url
12 :     min
13 :     max
14 :     between
15 :     translate
16 :     reverse_comp
17 :     rev_comp
18 :     verify_dir
19 :     run
20 :     read_fasta_record
21 :     display_id_and_seq
22 :     display_seq
23 :     abbrev
24 :     ftype
25 :     by_fig_id
26 :     close_enough
27 :     extract_by_who
28 :     read_block
29 :     blastit
30 :     epoch_to_readable
31 :     auto_assign
32 :     roles_of_function
33 :     close_enough_locs
34 :     extract_seq
35 :     limit_labels
36 :     taxonomic_groups
37 :     taxonomic_groups_and_children
38 :     );
39 :    
40 :     my(%util_funcs);
41 :    
42 :     grep({$util_funcs{$_}++} @util_funcs);
43 :    
44 :     use strict;
45 :    
46 :     no strict 'refs';
47 : olson 1.1
48 :     use FIG;
49 :    
50 : olson 1.2
51 : olson 1.1 require XMLRPC::Transport::HTTP;
52 :     require XMLRPC::Lite;
53 :     use IO::Select;
54 :     use IO::Handle;
55 :    
56 :     my $server = XMLRPC::Transport::HTTP::Daemon->new(LocalAddr =>"127.0.0.1",
57 :     ReuseAddr => 1);
58 :     my $fig = new FIG;
59 :    
60 : olson 1.2 my @d = ();
61 :    
62 :     sub wrap_util
63 :     {
64 :     my($name) = @_;
65 :    
66 :     my $sub = sub {
67 :     shift if UNIVERSAL::isa($_[0] => __PACKAGE__);
68 :     print "Args: ", map { "<$_>\n" } @_ , "\n";
69 :     print "name $name\n";
70 :     my @ret = eval " &FIG::$name(\@_);";
71 :     print "Ret: @ret\n";
72 :     return map { ref($_) ? $_ : XMLRPC::Data->type("string", $_) } @ret;
73 :    
74 :     };
75 :    
76 :     return $sub;
77 :     }
78 :    
79 :     sub wrap_method
80 :     {
81 :     my($name, $fig) = @_;
82 :     my $sub = sub {
83 :     shift if UNIVERSAL::isa($_[0] => __PACKAGE__);
84 :     print "Args: ", map { "<$_>\n" } @_ , "\n";
85 :     print "name $name\n";
86 :     my @ret = $fig->$name(@_);
87 :     print "Ret: @ret\n";
88 :     return map { ref($_) ? $_ : XMLRPC::Data->type("string", $_) } @ret;
89 :    
90 :     };
91 :    
92 :     return $sub;
93 :     }
94 :    
95 : olson 1.1 for my $name (keys(%FIG::))
96 :     {
97 :     next if $name !~ /^[a-zA-Z]/;
98 :     next if $name eq "new";
99 :    
100 :     my $glob = $FIG::{$name};
101 :    
102 :     next unless defined(&$glob);
103 :    
104 :     my $methName = $name;
105 :    
106 : olson 1.2 if ($util_funcs{$name})
107 :     {
108 :     *$methName = wrap_util($name);
109 :     }
110 :     else
111 :     {
112 :     *$methName = wrap_method($name, $fig);
113 :     }
114 : olson 1.1
115 :     push(@d, $methName);
116 :     }
117 : mkubal 1.4
118 :     sub genomes
119 :     {
120 :     my($dummy) = @_;
121 :    
122 :     my(@ret);
123 :    
124 :     @ret = $fig->genomes();
125 :    
126 :     return force_to_strings(@ret);
127 :     }
128 :    
129 :    
130 :     sub genus_species
131 :     {
132 :     my($dummy, $genome) = @_;
133 :    
134 :     my($ret);
135 :    
136 :     $ret = $fig->genus_species($genome);
137 :    
138 :     return force_to_string($ret);
139 :     }
140 :    
141 :    
142 : olson 1.1 $server->dispatch_to(@d);
143 :     #$server->dispatch_to('XMLPKG');
144 :    
145 :     print $server->url, "\n";
146 :     STDOUT->autoflush();
147 :    
148 :     # $server->handle;
149 :    
150 : olson 1.2 my $s = $server->new();
151 :     my $sel = IO::Select->new();
152 : olson 1.1 $sel->add($s->{_daemon});
153 :     my $stdin = \*STDIN;
154 :     $sel->add($stdin);
155 :     while (1)
156 :     {
157 : olson 1.2 my @ready = $sel->can_read();
158 : olson 1.1 for my $fh (@ready)
159 :     {
160 :     if ($fh == $s->{_daemon})
161 :     {
162 :     my $c = $s->accept;
163 :     while (my $r = $c->get_request)
164 :     {
165 :     $s->request($r);
166 :     $s->SOAP::Transport::HTTP::Server::handle;
167 :     $c->send_response($s->response);
168 :     }
169 :     }
170 :     elsif ($fh == $stdin)
171 :     {
172 : olson 1.2 my $buf;
173 : olson 1.1 my $n = sysread($stdin, $buf, 1);
174 :     if ($n == 0)
175 :     {
176 :     print "Exiting due to closed stdin\n";
177 :     $sel->remove($stdin);
178 : olson 1.3 exit;
179 : olson 1.1 }
180 :     }
181 :     }
182 :     }
183 :    
184 :    
185 :    
186 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3