149 lines
4.8 KiB
Perl
149 lines
4.8 KiB
Perl
#
|
|
# Filter command testing
|
|
#
|
|
# Filter can be set either by a "server adjunct command" in the login:
|
|
# user <username> pass <passcode> vers <soft> <vers> filter <filterstring>
|
|
#
|
|
# or with a #command (case insensitive) in the incoming stream:
|
|
# "# filter <filterstring>"
|
|
# "#filter <filterstring>"
|
|
# "#alfhilawuehflwieuhffilter <filterstring>"
|
|
# "#FILTER <filterstring>"
|
|
#
|
|
# or with an APRS message with a recipient call of "SERVER", saying
|
|
# "filter <filterstring>"
|
|
#
|
|
# Yes, the command can be prefixed with anything, even in the "user"
|
|
# command.
|
|
#
|
|
|
|
use Test;
|
|
BEGIN { plan tests => 6 + 1 + 2 + 2 + 2 + 4 + 2 + 3 };
|
|
use runproduct;
|
|
use istest;
|
|
use Ham::APRS::IS;
|
|
use Time::HiRes qw(sleep);
|
|
|
|
my $p = new runproduct('basic');
|
|
|
|
ok(defined $p, 1, "Failed to initialize product runner");
|
|
ok($p->start(), 1, "Failed to start product");
|
|
|
|
my $login = "N5CAL-1";
|
|
my $server_call = "TESTING";
|
|
my $i_tx = new Ham::APRS::IS("localhost:55580", $login);
|
|
ok(defined $i_tx, 1, "Failed to initialize Ham::APRS::IS");
|
|
|
|
# First filter is for uncompressed packet, second for compressed,
|
|
# third for mic-e, fourth for prefix filter test.
|
|
# The first and last one also test upper-case letters as filter keys.
|
|
my $rx_login = "N5CAL-2";
|
|
my $i_rx = new Ham::APRS::IS("localhost:55580", $rx_login,
|
|
'filter' => 'p/OH');
|
|
ok(defined $i_rx, 1, "Failed to initialize Ham::APRS::IS");
|
|
|
|
my $ret;
|
|
$ret = $i_tx->connect('retryuntil' => 8);
|
|
ok($ret, 1, "Failed to connect to the server: " . $i_tx->{'error'});
|
|
|
|
$ret = $i_rx->connect('retryuntil' => 8);
|
|
ok($ret, 1, "Failed to connect to the server: " . $i_rx->{'error'});
|
|
|
|
# do the actual tests
|
|
my($tx, $rx, $helper);
|
|
|
|
# check that the initial p/ filter works
|
|
$tx = $rx = "OH2SRC>APRS,qAR,$login:>should pass";
|
|
istest::txrx(\&ok, $i_tx, $i_rx, $tx, $rx);
|
|
|
|
# change filter
|
|
$i_rx->sendline("#filter p/N/K");
|
|
sleep(0.2);
|
|
|
|
# check that the new filter is applied
|
|
$tx = "OH2SRC>APRS,qAR,$login:>should drop";
|
|
$helper = "K2SRC>APRS,qAR,$login:>should pass";
|
|
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
|
|
|
$tx = "OH2SRC>APRS,qAR,$login:>should drop2";
|
|
$helper = "N2SRC>APRS,qAR,$login:>should pass2";
|
|
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
|
|
|
# change filter, with some spaces
|
|
$i_rx->sendline("# fIlTer p/N/K ");
|
|
sleep(0.2);
|
|
|
|
# check that the new filter is applied
|
|
$tx = "OH2SRC>APRS,qAR,$login:>should drop3";
|
|
$helper = "K2SRC>APRS,qAR,$login:>should pass3";
|
|
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
|
|
|
$tx = "OH2SRC>APRS,qAR,$login:>should drop4";
|
|
$helper = "N2SRC>APRS,qAR,$login:>should pass4";
|
|
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
|
|
|
# send an awfully long invalid filter, just to see
|
|
# it doesn't cause a crash due to buffer overflow
|
|
#$i_rx->sendline("# filter p/" . ("OG/OF/OH" x 1024));
|
|
#sleep(0.2);
|
|
|
|
# change filter, with some rubbish in front
|
|
$i_rx->sendline("#blaablaaanxauyg3iuyq2gFILTER p/OG/OF/OH");
|
|
sleep(0.2);
|
|
|
|
# check that the new filter is applied
|
|
$tx = "K2SRC>APRS,qAR,$login:>should drop5";
|
|
$helper = "OH2SRC>APRS,qAR,$login:>should pass5";
|
|
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
|
|
|
$tx = "N2SRC>APRS,qAR,$login:>should drop6";
|
|
$helper = "OH2SRC>APRS,qAR,$login:>should pass6";
|
|
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
|
|
|
# change filter using an APRS message
|
|
$tx = sprintf("$rx_login>APRS::%-9.9s:%s{ax", "SERVER", "filter p/OZ/ZZ");
|
|
$i_rx->sendline($tx);
|
|
my $ack = $i_rx->getline_noncomment(2);
|
|
#warn "received ack: $ack\n";
|
|
# SERVER>APJS40,TCPIP*,qAZ,TESTING::N5CAL-2 :ackax
|
|
ok($ack, qr/^SERVER>[^,]+,TCPIP\*,qAZ,TESTING::N5CAL-2 :ackax$/);
|
|
my $reply = $i_rx->getline_noncomment(2);
|
|
#warn "received reply: $reply\n";
|
|
# SERVER>APJS40,TCPIP*,qAZ,TESTING::N5CAL-2 :filter b/OZ*/ZZ* active{839
|
|
ok($reply, qr/^SERVER>[^,]+,TCPIP\*,qAZ,TESTING::N5CAL-2 :filter.*active{.*$/);
|
|
|
|
# check that the new filter is applied
|
|
$tx = "OH2SRC>APRS,qAR,$login:>should drop7";
|
|
$helper = "OZ2SRC>APRS,qAR,$login:>should pass7";
|
|
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
|
|
|
$tx = "OH2SRC>APRS,qAR,$login:>should drop8";
|
|
$helper = "ZZ2SRC>APRS,qAR,$login:>should pass8";
|
|
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
|
|
|
# query filter using an APRS message
|
|
$tx = sprintf("$rx_login>APRS::%-9.9s:%s{bx", "SERVER", "filter p/OZ/ZZ");
|
|
$i_rx->sendline($tx);
|
|
$ack = $i_rx->getline_noncomment(2);
|
|
#warn "received ack: $ack\n";
|
|
# SERVER>APJS40,TCPIP*,qAZ,TESTING::N5CAL-2 :ackax
|
|
ok($ack, qr/^SERVER>[^,]+,TCPIP\*,qAZ,TESTING::N5CAL-2 :ackbx$/);
|
|
$reply = $i_rx->getline_noncomment(2);
|
|
#warn "received reply: $reply\n";
|
|
# SERVER>APJS40,TCPIP*,qAZ,TESTING::N5CAL-2 :filter b/OZ*/ZZ* active{839
|
|
ok($reply, qr/^SERVER>[^,]+,TCPIP\*,qAZ,TESTING::N5CAL-2 :filter.*active\{.*$/);
|
|
|
|
|
|
# disconnect
|
|
|
|
$ret = $i_rx->disconnect();
|
|
ok($ret, 1, "Failed to disconnect from the server: " . $i_rx->{'error'});
|
|
|
|
$ret = $i_tx->disconnect();
|
|
ok($ret, 1, "Failed to disconnect from the server: " . $i_tx->{'error'});
|
|
|
|
# stop
|
|
|
|
ok($p->stop(), 1, "Failed to stop product");
|
|
|