1 # Copyright (c) 2009-2012 Zmanda, Inc. All Rights Reserved.
3 # This program is free software; you can redistribute it and/or modify it
4 # under the terms of the GNU General Public License version 2 as published
5 # by the Free Software Foundation.
7 # This program is distributed in the hope that it will be useful, but
8 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
9 # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
12 # You should have received a copy of the GNU General Public License along
13 # with this program; if not, write to the Free Software Foundation, Inc.,
14 # 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
16 # Contact information: Zmanda Inc, 465 S. Mathilda Ave., Suite 300
17 # Sunnyvale, CA 94086, USA, or: http://www.zmanda.com
19 use Test::More tests => 6;
23 use lib "@amperldir@";
25 use Amanda::IPC::LineProtocol;
33 # Define a test protocol
36 use base "Amanda::IPC::LineProtocol";
37 use Amanda::IPC::LineProtocol;
39 use constant SIMPLE => message("SIMPLE",
43 use constant FOO => message("FOO",
44 format => [ qw( name? nicknames* ) ],
47 use constant FO => message("FO", # prefix of "FOO"
51 use constant ASSYM => message("ASSYM",
58 use constant BAR => message("BAR",
59 match => qr/^BA[Rh]$/i, # more elaborate regex
60 format => [ qw( mandatory optional? ) ],
63 use constant QUIT => message("QUIT",
66 format => [ qw( reason? ) ],
71 # set up debugging so debug output doesn't interfere with test results
72 Amanda::Debug::dbopen("installcheck");
73 Installcheck::log_test_output();
75 # and disable Debug's die() and warn() overrides
76 Amanda::Debug::disable_die_override();
78 # run $code in a separate process, with read and write handles hooked up, and returns
79 # read and write handles.
83 my ($parent_read, $child_write) = POSIX::pipe();
84 my ($child_read, $parent_write) = POSIX::pipe();
87 if (!defined($pid) or $pid < 0) {
88 die("Can't fork: $!");
94 # get our file-handle house in order
95 POSIX::close($parent_read);
96 POSIX::close($parent_write);
98 $code->(IO::Handle->new_from_fd($child_read, "r"),
99 IO::Handle->new_from_fd($child_write, "w"));
105 POSIX::close($child_read);
106 POSIX::close($child_write);
108 return (IO::Handle->new_from_fd($parent_read, "r"),
109 IO::Handle->new_from_fd($parent_write, "w"),
113 # generic "die" message_cb
114 my $message_cb = make_cb(message_cb => sub {
115 my ($msgtype, %params) = @_;
116 if (defined $msgtype) {
117 diag(Dumper(\%params));
118 die("unhandled message: $msgtype");
120 die("IPC error: $params{'error'}");
129 my ($rx_fh, $tx_fh, $pid);
131 # on QUIT, stop the protocol and quit the mainloop
132 my $quit_cb = make_cb(quit_cb => sub {
133 push @events, [ @_ ];
134 $proto->stop(finished_cb => sub {
135 Amanda::MainLoop::quit();
141 # test a simple "QUIT"
144 ($rx_fh, $tx_fh, $pid) = in_fork(sub {
145 my ($rdh, $wrh) = @_;
148 $rdh->getline(); # get 'start\n'
149 $wrh->write("QUIT \"just because\"");
152 $proto = TestProtocol->new(
153 rx_fh => $rx_fh, tx_fh => $tx_fh,
154 message_cb => $message_cb);
155 $proto->set_message_cb(TestProtocol::QUIT, $quit_cb);
156 Amanda::MainLoop::call_later(sub {
157 $tx_fh->autoflush(1);
158 $tx_fh->write("start\n");
160 Amanda::MainLoop::run();
163 is_deeply([ @events ],
165 [ "QUIT", reason => "just because" ],
168 "correct events for a simple 'QUIT \"just because\"")
169 or diag(Dumper(\@events));
173 # test a bogus message
176 ($rx_fh, $tx_fh, $pid) = in_fork(sub {
177 my ($rdh, $wrh) = @_;
180 $rdh->getline(); # get 'start\n'
181 $wrh->write("SNARSBLAT, yo");
184 $proto = TestProtocol->new(
185 rx_fh => $rx_fh, tx_fh => $tx_fh,
186 message_cb => sub { push @events, [ @_ ]; });
187 $proto->set_message_cb(TestProtocol::QUIT, $quit_cb);
188 Amanda::MainLoop::call_later(sub {
189 $tx_fh->autoflush(1);
190 $tx_fh->write("start\n");
192 Amanda::MainLoop::run();
195 is_deeply([ @events ],
197 [ undef, 'error' => 'unknown command' ],
198 [ "QUIT" ], # from EOF
200 "bogus message handled correctly")
201 or diag(Dumper(\@events));
205 # a more complex conversation
208 ($rx_fh, $tx_fh, $pid) = in_fork(sub {
209 my ($rdh, $wrh) = @_;
212 $wrh->write("FOO\n");
213 $rdh->getline() =~ /SIMPLE/ or die("bad response");
215 $wrh->write("FOO one\n");
216 $rdh->getline() =~ /SIMPLE/ or die("bad response");
218 $wrh->write("FOO one \"t w o\"\n");
219 $rdh->getline() =~ /SIMPLE/ or die("bad response");
221 $wrh->write("FOO one \"t w o\" three\n");
222 $rdh->getline() =~ /SIMPLE/ or die("bad response");
225 $proto = TestProtocol->new(
226 rx_fh => $rx_fh, tx_fh => $tx_fh,
227 message_cb => $message_cb);
228 $proto->set_message_cb(TestProtocol::QUIT, $quit_cb);
229 $proto->set_message_cb(TestProtocol::FOO, sub {
230 push @events, [ shift @_, { @_ } ];
231 $proto->send(TestProtocol::SIMPLE);
233 Amanda::MainLoop::run();
236 is_deeply([ @events ],
238 [ "FOO", { nicknames => [] } ],
239 [ "FOO", { nicknames => [], name => "one" } ],
240 [ "FOO", { nicknames => [ "t w o" ], name => "one" } ],
241 [ "FOO", { nicknames => [ "t w o", "three" ], name => "one" } ],
244 "correct events for a few conversation steps, parsing")
245 or diag(Dumper(\@events));
248 # Asymmetrical formats
251 ($rx_fh, $tx_fh, $pid) = in_fork(sub {
252 my ($rdh, $wrh) = @_;
255 $wrh->write("ASSYM 1 2\n");
256 $rdh->getline() =~ /ASSYM a/ or die("bad response");
259 $proto = TestProtocol->new(
260 rx_fh => $rx_fh, tx_fh => $tx_fh,
261 message_cb => $message_cb);
262 $proto->set_message_cb(TestProtocol::QUIT, $quit_cb);
263 $proto->set_message_cb(TestProtocol::ASSYM, sub {
264 push @events, [ shift @_, { @_ } ];
265 $proto->send(TestProtocol::ASSYM, x => "a");
267 Amanda::MainLoop::run();
270 is_deeply([ @events ],
272 [ "ASSYM", { a => "1", b => "2" } ],
275 "correct events for asymmetric message format")
276 or diag(Dumper(\@events));
280 # test queueing up of messages on writing.
282 # The idea here is to write more than a pipe buffer can hold, while the child
283 # process does not read that data, and then to signal the child process,
284 # causing it to read all of that data, write a reply, and exit. Recent linuxes
285 # have a pipe buffer of 64k, so we exceed that threshold. We use an 'alarm' to
286 # fail in the case that this blocks.
291 ($rx_fh, $tx_fh, $pid) = in_fork(sub {
292 my ($rdh, $wrh) = @_;
295 # on USR1, read lots of inputs
297 for (my $i = 0; $i < $NMSGS; $i++) {
301 # send a message that the parent can hope to get
302 $wrh->write("BAR \"got your inputs\"\n");
308 $wrh->write("SIMPLE\n");
310 # and sleep forever, or until killed.
311 while (1) { sleep(100); }
314 $proto = TestProtocol->new(
315 rx_fh => $rx_fh, tx_fh => $tx_fh,
316 message_cb => $message_cb);
317 $proto->set_message_cb(TestProtocol::QUIT, $quit_cb);
318 $proto->set_message_cb(TestProtocol::SIMPLE, sub {
319 push @events, [ shift @_ ];
320 # send $NMSGS messages to the child, which isn't listening yet!
321 for (my $i = 0; $i < $NMSGS; $i++) {
322 $proto->send(TestProtocol::SIMPLE);
324 # and then send it SIGUSR1, so it reads those
327 $proto->set_message_cb(TestProtocol::BAR, sub {
328 push @events, [ shift @_, { @_ } ];
331 # die after 10 minutes
334 Amanda::MainLoop::run();
336 alarm 0; # cancel the alarm
338 is_deeply([ @events ],
341 [ "BAR", { mandatory => "got your inputs" } ],
344 "write buffering handled correctly")
345 or diag(Dumper(\@events));
348 # test the message_obj functionality
350 package main::MessageObj;
354 push @{$self}, [ shift @_, { @_ } ];
355 $proto->send(TestProtocol::SIMPLE);
360 push @{$self}, [ shift @_, { @_ } ];
361 $proto->send(TestProtocol::SIMPLE);
367 ($rx_fh, $tx_fh, $pid) = in_fork(sub {
368 my ($rdh, $wrh) = @_;
371 $wrh->write("FOO\n");
372 $rdh->getline() =~ /SIMPLE/ or die("bad response");
374 $wrh->write("BAR one\n");
375 $rdh->getline() =~ /SIMPLE/ or die("bad response");
377 $wrh->write("BAH one \"t w o\"\n"); # note alternate spelling "BAH"
378 $rdh->getline() =~ /SIMPLE/ or die("bad response");
380 $wrh->write("FOO one \"t w o\" three\n");
381 $rdh->getline() =~ /SIMPLE/ or die("bad response");
384 $proto = TestProtocol->new(
385 rx_fh => $rx_fh, tx_fh => $tx_fh,
386 message_obj => bless(\@events, "main::MessageObj"));
387 $proto->set_message_cb(TestProtocol::QUIT, $quit_cb);
388 Amanda::MainLoop::run();
391 is_deeply([ @events ],
392 [ [ 'FOO', { 'nicknames' => [] } ],
393 [ 'BAR', { 'mandatory' => 'one' } ],
394 [ 'BAR', { 'mandatory' => 'one', 'optional' => 't w o' } ],
395 [ 'FOO', { 'name' => 'one', 'nicknames' => [ 't w o', 'three' ] } ],
399 or diag(Dumper(\@events));