139 lines
3.0 KiB
Perl
139 lines
3.0 KiB
Perl
|
|
package istest;
|
|
|
|
=head1 NAME
|
|
|
|
istest - a perl module for doing APRS-IS network server tests.
|
|
|
|
=cut
|
|
|
|
use 5.006;
|
|
use strict;
|
|
use warnings;
|
|
use Data::Dumper;
|
|
|
|
my $debug = 0;
|
|
|
|
sub txrx($$$$$)
|
|
{
|
|
my($ok, $i_tx, $i_rx, $tx, $rx) = @_;
|
|
|
|
warn "sending: $tx\n" if ($debug);
|
|
my $sent = $i_tx->sendline($tx);
|
|
|
|
warn "sent\n" if ($debug);
|
|
|
|
if (!$sent) {
|
|
&$ok(0, 1, "Failed to send line to server: '$tx'");
|
|
return;
|
|
}
|
|
|
|
if ($i_tx->{'state'} ne 'connected') {
|
|
&$ok(1, 0, "Server TX connection error after sending: '$tx': " . $i_tx->{'error'});
|
|
}
|
|
|
|
warn "receiving\n" if ($debug);
|
|
|
|
my $received = $i_rx->getline_noncomment();
|
|
|
|
if (!defined $received) {
|
|
if ($i_rx->{'state'} eq 'connected') {
|
|
&$ok(1, 0, "Did not receive packet from server (timeout): '$tx'");
|
|
} else {
|
|
&$ok(1, 0, "Server RX connection error after sending: '$tx': " . $i_rx->{'error'});
|
|
}
|
|
return;
|
|
}
|
|
|
|
#warn "received '$rx'\n";
|
|
|
|
if ($received ne $rx) {
|
|
&$ok($received, $rx, "Server returned wrong line");
|
|
return;
|
|
}
|
|
|
|
&$ok(1, 1, "ok");
|
|
}
|
|
|
|
sub should_drop($$$$$;$$)
|
|
{
|
|
my($ok, $i_tx, $i_rx, $tx, $helper, $no_random_drop, $no_random_helper) = @_;
|
|
|
|
my $drop_key = '';
|
|
$drop_key .= ' drop.' . int(rand(1000000)) if (!$no_random_drop);
|
|
my $sent = $i_tx->sendline($tx . $drop_key);
|
|
|
|
if (!$sent) {
|
|
&$ok($sent, 1, "Failed to send line to server: '$tx'");
|
|
return;
|
|
}
|
|
|
|
my $helper_key = 'helper.' . int(rand(1000000));
|
|
my $helper_l = $helper;
|
|
$helper_l .= ' ' . $helper_key if (!$no_random_helper);
|
|
$sent = $i_tx->sendline($helper_l);
|
|
|
|
if (!$sent) {
|
|
&$ok($sent, 1, "Failed to send helper line to server: '$helper_l'");
|
|
return;
|
|
}
|
|
|
|
my $received = $i_rx->getline_noncomment();
|
|
|
|
if (!defined $received) {
|
|
if ($i_rx->{'state'} eq 'connected') {
|
|
&$ok(1, 0, "Did not receive helper packet from server (timeout): '$helper_l'");
|
|
} else {
|
|
&$ok(1, 0, "Server connection went down after sending: '$tx' and '$helper_l'");
|
|
}
|
|
return;
|
|
}
|
|
|
|
my $tx2 = $tx;
|
|
$tx2 =~ s/([^>]+)>([^,]+),[^:]+(:.*)$/$1>$2$3/;
|
|
my $hl2 = $helper;
|
|
$hl2 =~ s/([^>]+)>([^,]+),[^:]+(:.*)$/$1>$2$3/;
|
|
my $rec2 = $received;
|
|
$rec2 =~ s/([^>]+)>([^,]+),[^:]+(:.*)$/$1>$2$3/;
|
|
|
|
if ($no_random_helper) {
|
|
#warn "exp '$hl2'\n";
|
|
#warn "got '$rec2'\n";
|
|
if ($hl2 eq $rec2) {
|
|
&$ok(1, 1, "ok, received helper packet only");
|
|
return;
|
|
}
|
|
} else {
|
|
if ($received =~ /$helper_key/) {
|
|
&$ok(1, 1, "ok, received helper packet only");
|
|
return;
|
|
}
|
|
}
|
|
|
|
if ($no_random_drop) {
|
|
if ($hl2 eq $tx2) {
|
|
&$ok($received, $helper, "Server forwarded packet it should have dropped");
|
|
} else {
|
|
&$ok($received, $helper, "Server returned completely unexpected packet");
|
|
}
|
|
} else {
|
|
if ($received =~ /$drop_key/) {
|
|
&$ok($received, $helper, "Server forwarded packet it should have dropped");
|
|
} else {
|
|
&$ok($received, $helper, "Server returned completely unexpected packet");
|
|
}
|
|
}
|
|
|
|
# since we received an extra packet, get one more line to receive the helper
|
|
$i_rx->getline_noncomment();
|
|
}
|
|
|
|
sub read_and_disconnect($)
|
|
{
|
|
my($i) = @_;
|
|
|
|
|
|
}
|
|
|
|
1;
|