[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.2 - (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 :     $server->dispatch_to(@d);
118 :     #$server->dispatch_to('XMLPKG');
119 :    
120 :     print $server->url, "\n";
121 :     STDOUT->autoflush();
122 :    
123 :     # $server->handle;
124 :    
125 : olson 1.2 my $s = $server->new();
126 :     my $sel = IO::Select->new();
127 : olson 1.1 $sel->add($s->{_daemon});
128 :     my $stdin = \*STDIN;
129 :     $sel->add($stdin);
130 :     while (1)
131 :     {
132 : olson 1.2 my @ready = $sel->can_read();
133 : olson 1.1 for my $fh (@ready)
134 :     {
135 :     if ($fh == $s->{_daemon})
136 :     {
137 :     my $c = $s->accept;
138 :     while (my $r = $c->get_request)
139 :     {
140 :     $s->request($r);
141 :     $s->SOAP::Transport::HTTP::Server::handle;
142 :     $c->send_response($s->response);
143 :     }
144 :     }
145 :     elsif ($fh == $stdin)
146 :     {
147 : olson 1.2 my $buf;
148 : olson 1.1 my $n = sysread($stdin, $buf, 1);
149 :     if ($n == 0)
150 :     {
151 :     print "Exiting due to closed stdin\n";
152 :     $sel->remove($stdin);
153 :     #exit;
154 :     }
155 :     }
156 :     }
157 :     }
158 :    
159 :    
160 :    
161 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3