Commit | Line | Data |
4536f655 |
1 | # File: Stem/Test/PacketIO.pm |
2 | |
3 | # This file is part of Stem. |
4 | # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc. |
5 | |
6 | # Stem is free software; you can redistribute it and/or modify |
7 | # it under the terms of the GNU General Public License as published by |
8 | # the Free Software Foundation; either version 2 of the License, or |
9 | # (at your option) any later version. |
10 | |
11 | # Stem is distributed in the hope that it will be useful, |
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
14 | # GNU General Public License for more details. |
15 | |
16 | # You should have received a copy of the GNU General Public License |
17 | # along with Stem; if not, write to the Free Software |
18 | # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
19 | |
20 | # For a license to use the Stem under conditions other than those |
21 | # described here, to purchase support for this software, or to purchase a |
22 | # commercial warranty contract, please contact Stem Systems at: |
23 | |
24 | # Stem Systems, Inc. 781-643-7504 |
25 | # 79 Everett St. info@stemsystems.com |
26 | # Arlington, MA 02474 |
27 | # USA |
28 | |
29 | package Stem::Test::PacketIO ; |
30 | |
31 | use Test::More ; |
32 | |
33 | use Stem::Route qw( register_cell unregister_cell ) ; |
34 | use Stem::SockMsg ; |
35 | |
36 | use base 'Stem::Cell' ; |
37 | |
38 | my $attr_spec = [ |
39 | |
40 | { |
41 | 'name' => 'reg_name', |
42 | 'help' => <<HELP, |
43 | This is the name under which this Cell was registered. |
44 | HELP |
45 | }, |
46 | |
47 | { |
48 | 'name' => 'port', |
49 | 'default' => 8889, |
50 | 'help' => <<HELP, |
51 | The port to use for the SockMsg cells. |
52 | HELP |
53 | }, |
54 | { |
55 | 'name' => 'write_addr', |
56 | 'help' => <<HELP, |
57 | The Cell address of a sending port |
58 | HELP |
59 | }, |
60 | { |
61 | 'name' => 'cell_attr', |
62 | 'class' => 'Stem::Cell', |
63 | 'help' => <<HELP, |
64 | Argument list passed to Stem::Cell for this Cell |
65 | HELP |
66 | }, |
67 | ] ; |
68 | |
69 | |
70 | my @msg_data = ( |
71 | "Packet scalar", |
72 | \"Packet ref", |
73 | { foo => 2 }, |
74 | [ qw( a b c ) ], |
75 | bless( { abc => 1 }, 'PIO_class' ), |
76 | { bar => 'xyz', qwert => 3 }, |
77 | { |
78 | list => [ 1 .. 4 ], |
79 | hash => { qwert => 3 }, |
80 | } |
81 | ) ; |
82 | |
83 | my @codecs = qw( YAML Storable Data::Dumper SimpleHash ) ; |
84 | #my @codecs = qw( SimpleHash ) ; |
85 | @codecs = grep { eval "require Stem::Codec::$_" } @codecs ; |
86 | |
87 | plan tests => @msg_data * @codecs ; |
88 | |
89 | sub new { |
90 | |
91 | my( $class ) = shift ; |
92 | |
93 | my $self = Stem::Class::parse_args( $attr_spec, @_ ) ; |
94 | return $self unless ref $self ; |
95 | |
96 | my $flow_text = <<FLOW ; |
97 | |
98 | WHILE codecs_left { |
99 | |
100 | create_sock_msg_pair ; |
101 | DELAY 1 ; |
102 | send_msg ; |
103 | STOP ; |
104 | } |
105 | STOP ; |
106 | FLOW |
107 | |
108 | $self->cell_flow_init( 'test', $flow_text ) ; |
109 | |
110 | $self->cell_flow_go_in() ; |
111 | |
112 | return $self ; |
113 | } |
114 | |
115 | sub send_msg { |
116 | |
117 | my( $self ) = @_ ; |
118 | |
119 | my $codec = $self->{'codec'} ; |
120 | |
121 | # we send to the client hence to the server, on to echo, back to the |
122 | # server and through the client all the way to here |
123 | |
124 | foreach my $data ( @msg_data ) { |
125 | |
126 | if ( $codec eq 'SimpleHash' ) { |
127 | |
128 | if ( ref $data ne 'HASH' ) { |
129 | |
130 | ok( 1, |
131 | 'skip SimpleHash only allows hash refs for data') ; |
132 | next ; |
133 | } |
134 | |
135 | if ( grep ref $_, values %{$data} ) { |
136 | |
137 | ok( 1, |
138 | 'skip SimpleHash only allows single level hashes for data') ; |
139 | next ; |
140 | } |
141 | } |
142 | |
143 | my $msg = Stem::Msg->new( |
144 | 'to' => "client_$codec", |
145 | 'from' => $self->{'reg_name'}, |
146 | 'type' => 'data', |
147 | 'data' => $data, |
148 | ) ; |
149 | |
150 | #print $msg->dump("MSG OUT") ; |
151 | $msg->dispatch() ; |
152 | |
153 | push( @{$self->{'sent_data'}}, $data ) ; |
154 | } |
155 | |
156 | return ; |
157 | } |
158 | |
159 | sub data_in { |
160 | |
161 | my( $self, $msg ) = @_ ; |
162 | |
163 | #print $msg->dump( 'PACKET IN' ) ; |
164 | |
165 | my $recv_data = $msg->data() ; |
166 | |
167 | my $sent_data = shift @{$self->{'sent_data'}} ; |
168 | |
169 | #print "SENT [$sent_data]\nGOT[$recv_data]\n" ; |
170 | |
171 | my $data_type = ref $sent_data || 'scalar' ; |
172 | |
173 | is_deeply( $recv_data, $sent_data, "$self->{'codec'} - $data_type " ) ; |
174 | |
175 | unless ( @{$self->{'sent_data'}} ) { |
176 | |
177 | $self->destroy_sock_msg_pair() ; |
178 | $self->cell_flow_go_in() ; |
179 | } |
180 | } |
181 | |
182 | sub test_done { |
183 | |
184 | return 'FLOW_STOP' ; |
185 | } |
186 | |
187 | sub codecs_left { |
188 | |
189 | my( $self ) = @_ ; |
190 | |
191 | exit unless @codecs ; |
192 | |
193 | #die "CODECS END" |
194 | |
195 | return( $self->{codec} = shift @codecs ) ; |
196 | } |
197 | |
198 | sub create_sock_msg_pair { |
199 | |
200 | my( $self ) = @_ ; |
201 | |
202 | my $codec = $self->{'codec'} ; |
203 | |
204 | #print "CREATE [$codec]\n" ; |
205 | |
206 | my $server_name = "server_$codec" ; |
207 | |
208 | my $server_sock = Stem::SockMsg->new( |
209 | reg_name => $server_name, |
210 | port => ++$self->{port}, |
211 | server => 1, |
212 | cell_attr => [ |
213 | 'data_addr' => 'echo', |
214 | 'codec' => $codec, |
215 | ], |
216 | ) ; |
217 | |
218 | #print "SERVER [$server_sock]\n" ; |
219 | die $server_sock unless ref $server_sock ; |
220 | my $err = register_cell( $server_sock, $server_name ) ; |
221 | $err and die "register error: $err" ; |
222 | |
223 | $self->{server_cell} = $server_sock ; |
224 | $self->{server_name} = $server_name ; |
225 | |
226 | my $client_name = "client_$codec" ; |
227 | |
228 | my $client_sock = Stem::SockMsg->new( |
229 | reg_name => $client_name, |
230 | port => $self->{port}, |
231 | connect_now => 1, |
232 | sync => 1, |
233 | cell_attr => [ |
234 | 'data_addr' => 'packet_io', |
235 | 'codec' => $codec, |
236 | ], |
237 | ) ; |
238 | #print "CLIENT [$client_sock]\n" ; |
239 | |
240 | die $client_sock unless ref $client_sock ; |
241 | register_cell( $client_sock, $client_name ) ; |
242 | $self->{client_cell} = $client_sock ; |
243 | $self->{client_name} = $client_name ; |
244 | |
245 | return ; |
246 | } |
247 | |
248 | sub destroy_sock_msg_pair { |
249 | |
250 | my( $self ) = @_ ; |
251 | |
252 | my $codec = $self->{'codec'} ; |
253 | |
254 | #print "DESTROY [$codec]\n" ; |
255 | |
256 | foreach my $type ( qw( server client ) ) { |
257 | |
258 | my $sock_msg = delete $self->{"${type}_cell"} ; |
259 | # my $sock_msg = delete $self->{"${type}_$codec"} ; |
260 | unregister_cell( $sock_msg ) ; |
261 | $sock_msg->shut_down() ; |
262 | } |
263 | } |
264 | |
265 | 1 ; |