Dave Cross: Still Munging Data With Perl: Online event - Mar 27 Learn more

#!/usr/bin/perl
#
# Copyright (C) 2010 by Mark Hindess
use strict;
use constant {
DEBUG => $ENV{DEVICE_RFXCOM_TX_TEST_DEBUG}
};
$|=1;
BEGIN {
require Test::More;
eval { require AnyEvent; import AnyEvent;
require AnyEvent::Handle; import AnyEvent::Handle;
require AnyEvent::Socket; import AnyEvent::Socket };
if ($@) {
import Test::More skip_all => 'Missing AnyEvent module(s): '.$@;
}
eval { require AnyEvent::MockTCPServer; import AnyEvent::MockTCPServer };
if ($@) {
import Test::More skip_all => 'No AnyEvent::MockTCPServer module: '.$@;
}
import Test::More;
use t::Helpers qw/test_warn/;
}
my @connections =
(
[
{
transmit => undef,
desc => 'version check',
recv => 'F030F030',
send => '10',
init => 0,
},
{
transmit => undef,
desc => 'set mode',
recv => 'F037F037',
send => '37',
init => 1,
},
{
transmit => { type => 'x10', command => 'off', device => 'i10' },
desc => 'x10/i10/off',
recv => '20E41B30CF',
send => '37',
init => 1,
},
{
transmit => { type => 'x10', command => 'on', device => 'i2,i3,q0' },
desc => 'x10/i2,i3/on - i2',
recv => '20E01F10EF', # i2/on
send => '37',
init => 1,
},
{
transmit => undef,
desc => 'x10/i2,i3/on - i3',
recv => '20E01F08F7', # i3/on
send => '37',
init => 1,
},
# no q0 as that is invalid
{
transmit => { type => 'x10', command => 'bright', house => 'j' },
desc => 'x10/j/bright',
recv => '20F00F8877',
send => '37',
init => 1,
},
{
transmit => { type => 'homeeasy', command => 'off',
address => 'xmas', unit => 10 },
desc => 'homeeasy/xmas/10/off',
recv => '2101D5EA0A00',
send => '37',
init => 1,
},
{
transmit => { type => 'homeeasy', command => 'on',
address => '0x3333', unit => 1 },
desc => 'homeeasy/0x3333/1/on',
recv => '21000CCCD100',
send => '37',
init => 1,
},
{
transmit => { type => 'homeeasy', command => 'preset',
address => 'test', unit => 9, level => 5 },
desc => 'homeeasy/test/9/preset/5',
recv => '2401CD490950',
send => '37',
init => 1,
},
],
[
{
transmit => { type => 'homeeasy', command => 'on',
address => 'console', unit => 'group' },
desc => 'homeeasy/console/group/on',
recv => 'F030F030',
send => '10',
init => 0,
},
{
transmit => undef,
desc => 'enable harrison',
recv => 'F03CF03C',
send => '33',
init => 0,
},
{
transmit => undef,
desc => 'enable koko',
recv => 'F03DF03D',
send => '33',
init => 0,
},
{
transmit => undef,
desc => 'enable flamingo',
recv => 'F03EF03E',
send => '33',
init => 0,
},
{
transmit => undef,
desc => 'disabling x10',
recv => 'F03FF03F',
send => '37',
init => 0,
},
{
transmit => undef,
desc => 'set mode',
recv => 'F033F033',
send => '33',
init => 1,
},
{
transmit => undef,
desc => 'homeeasy/console/group/on',
recv => '21AA163DB000',
send => '33',
init => 1,
},
],
);
my @sc = ();
foreach my $con (@connections) {
my @a = ();
foreach my $rec (@$con) {
my ($recv, $send, $desc) = @{$rec}{qw/recv send desc/};
push @a,
[ packrecv => $recv, $desc ],
[ packsend => $send, $desc ];
}
push @sc, \@a;
}
my $server;
eval { $server = AnyEvent::MockTCPServer->new(connections => \@sc); };
plan skip_all => "Failed to create dummy server: $@" if ($@);
my ($host, $port) = $server->connect_address;
my $addr = join ':', $host, $port;
import Test::More tests => 56;
use_ok('Device::RFXCOM::TX');
my $tx;
my $w;
my %args = ();
my $cv;
foreach my $con (@connections) {
my $init = 0;
$tx = Device::RFXCOM::TX->new(%args,
device => $addr,
init_callback => sub { $init++ });
ok($tx, 'instantiate Device::RFXCOM::TX object');
$w = AnyEvent->io(fh => $tx->filehandle, poll => 'r',
cb => sub { $cv->send($tx->wait_for_ack()) });
$cv = AnyEvent->condvar;
foreach my $rec (@$con) {
my ($tran, $desc, $sent, $init_exp) = @{$rec}{qw/transmit desc send init/};
if ($tran) {
print STDERR "Transmitting: $desc\n" if DEBUG;
$tx->transmit(%$tran) if ($tran);
}
my $res = $cv->recv;
print STDERR "Received ack for $desc\n" if DEBUG;
is((unpack 'H*', $res), $sent, 'response - '.$desc);
is($init, $init_exp, 'init == '.$init_exp.' - '.$desc);
$cv = AnyEvent->condvar;
}
# invert all the defaults
%args =
(
receiver_connected => 1,
harrison => 1,
koko => 1,
flamingo => 1,
x10 => 0,
);
}
undef $server;
eval { $tx->transmit(type => 'magic', command => 'fetch cake'); };
like($@, qr!^\Q$tx\E->transmit: magic encoding not supported at !,
'invalid transmit type');
like(test_warn(sub { $tx->transmit(type => 'x10', command => 'on'); }),
qr!->encode: Invalid x10 message!, 'invalid x10 message');
SKIP: {
skip 'fails with some event loops', 1
unless ($AnyEvent::MODEL eq 'AnyEvent::Impl::Perl');
eval { my $res = $cv->recv; };
like($@, qr!^closed at \Q$0\E line \d+!, 'check close');
}
undef $tx;
undef $w;
eval { Device::RFXCOM::TX->new(device => $addr) };
like($@, qr!^TCP connect to '\Q$addr\E' failed:!o, 'connection failed');
undef $tx;
eval { Device::RFXCOM::TX->new(device => $host, port => $port) };
like($@, qr!^TCP connect to '\Q$addr\E' failed:!o,
'connection failed (default port)');
undef $tx;