perl/libnet-radius-perl
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Imported Upstream version 2.103+dfsg

Browse Source
This commit is contained in:
Mario Fetka
2017-09-15 15:01:34 +02:00
commit 885cfb79ed
115 changed files with 16877 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
t/00-load.t Normal file
View File

@@ -0,0 +1,7 @@
# $Id: 00-load.t 9 2003-10-16 20:10:25Z lem $
use Test::More tests => 2;
use_ok("Net::Radius::Dictionary");
use_ok("Net::Radius::Packet");

10
t/00-pod.t Normal file
View File

@@ -0,0 +1,10 @@
# 00-pod.t: Verify all the POD documentation
use strict;
use Test::More;
eval "use Test::Pod 1.00";
plan skip_all => 'Test::Pod is not available' if $@;
all_pod_files_ok();

111
t/attrdict.t Normal file
View File

@@ -0,0 +1,111 @@
#!/usr/bin/perl
# Test the parsing of individual attributes
# $Id: attrdict.t 27 2006-08-09 16:00:01Z lem $
use IO::File;
use Test::More;
use Data::Dumper;
use Net::Radius::Dictionary;
my $dictfile = "dict$$.tmp";
END
{
unlink $dictfile;
};
my @dicts = ();
my @refs = ();
{
local $/ = "EOD\n";
@dicts = map { (s/EOD\n$//, $_)[1] } <DATA>;
};
$refs[0] = bless {
'vsattr' => {},
'rattr' => {},
'vendors' => {},
'rvsaval' => {},
'val' => {},
'rvsattr' => {},
'attr' => {},
'rval' => {},
'vsaval' => {}
}, 'Net::Radius::Dictionary';
$refs[1] = bless {
'vsattr' => {
'9' => {
'Cisco-AVPair' => ['1', 'string' ],
'cisco-thing' => ['2', 'string' ]
}
},
'rattr' => {
'1' => ['User-Name', 'string'],
'23' => ['Framed-IPX-Network', 'ipaddr'],
'10' => ['Framed-Routing', 'integer']
},
'vendors' => {
'Cisco' => '9'
},
'rvsaval' => {},
'val' => {},
'rvsattr' => {
'9' => {
'1' => ['Cisco-AVPair', 'string'],
'2' => ['cisco-thing', 'string']
}
},
'attr' => {
'Framed-IPX-Network' => ['23', 'ipaddr'],
'Framed-Routing' => ['10', 'integer'],
'User-Name' => ['1', 'string']
},
'rval' => {},
'vsaval' => {}
}, 'Net::Radius::Dictionary';
sub _write
{
my $dict = shift;
my $fh = new IO::File;
$fh->open($dictfile, "w") or diag "Failed to write dict $dictfile: $!";
print $fh $dict;
$fh->close;
}
plan tests => 20 * scalar @dicts;
for my $i (0 .. $#dicts)
{
_write $dicts[$i];
my $d;
eval { $d = new Net::Radius::Dictionary $dictfile; };
isa_ok($d, 'Net::Radius::Dictionary');
ok(!$@, "No errors during parse");
diag $@ if $@;
for my $k (keys %{$refs[$i]})
{
ok(exists $d->{$k}, "Element $k exists in the object");
is_deeply($d->{$k}, $refs[$i]->{$k}, "Same contents in element $k");
}
}
__END__
# Empty dictionary
EOD
# Sample dictionary
ATTRIBUTE User-Name 1 string
ATTRIBUTE Framed-Routing 10 integer
ATTRIBUTE Framed-IPX-Network 23 ipaddr
VENDOR Cisco 9
ATTRIBUTE Cisco-AVPair 1 string Cisco
VENDORATTR 9 cisco-thing 2 string

72
t/attrover.t Normal file
View File

@@ -0,0 +1,72 @@
#!/usr/bin/perl
# Test the attribute overriding code as well as access to the
# attribute stack
# $Id: attrover.t 56 2007-01-08 20:52:18Z lem $
no utf8;
use IO::File;
use Test::More 'no_plan';
use Net::Radius::Packet;
use Net::Radius::Dictionary;
# Init the dictionary for our test run...
BEGIN {
my $fh = new IO::File "dict.$$", ">";
print $fh <<EOF;
ATTRIBUTE User-Name 1 string
ATTRIBUTE Reply-Message 18 string
EOF
close $fh;
};
END { unlink 'dict.' . $$; }
my $d = new Net::Radius::Dictionary "dict.$$";
isa_ok($d, 'Net::Radius::Dictionary');
# Build a request and test it is ok
my $p = new Net::Radius::Packet $d;
isa_ok($p, 'Net::Radius::Packet');
$p->set_identifier(42);
$p->set_authenticator("\x66" x 16);
$p->set_code("Access-Reject");
$p->set_attr("Reply-Message" => 'line-1');
$p->set_attr("Reply-Message" => 'line-2', 1);
# There should be one attribute, a single Reply-Message
is($p->attr_slots, 1, "Correct number of attribute slots");
is($p->attr_slot_name(0), 'Reply-Message', "Correct name for slot 0");
is($p->attr_slot_val(0), 'line-2', "Correct value for slot 0");
is($p->attr_slot_name(1), undef, "Undef slot 1 name");
is($p->attr_slot_val(1), undef, "Undef slot 1 value");
# Now there should be 3 attributes
$p = new Net::Radius::Packet $d;
isa_ok($p, 'Net::Radius::Packet');
$p->set_identifier(42);
$p->set_authenticator("\x66" x 16);
$p->set_code("Access-Reject");
$p->set_attr("Reply-Message" => 'line-1');
$p->set_attr("Reply-Message" => 'line-2');
$p->set_attr("Reply-Message" => 'line-3', 1);
is($p->attr_slots, 3, "Correct number of attribute slots");
is($p->attr_slot_name(0), 'Reply-Message', "Correct name for slot 0");
is($p->attr_slot_val(0), 'line-1', "Correct value for slot 0");
is($p->attr_slot_name(1), 'Reply-Message', "Correct name for slot 1");
is($p->attr_slot_val(1), 'line-2', "Correct value for slot 1");
is($p->attr_slot_name(2), 'Reply-Message', "Correct name for slot 2");
is($p->attr_slot_val(2), 'line-3', "Correct value for slot 2");
is($p->attr_slot_name(3), undef, "Undef slot 3 name");
is($p->attr_slot_val(3), undef, "Undef slot 3 value");

163
t/attrslot.t Normal file
View File

@@ -0,0 +1,163 @@
#!/usr/bin/perl
# Test the attribute slot management
# $Id: attrslot.t 77 2007-01-30 15:15:48Z lem $
no utf8;
use IO::File;
use Test::More tests => 61;
use Net::Radius::Packet;
use Net::Radius::Dictionary;
# Init the dictionary for our test run...
BEGIN {
my $fh = new IO::File "dict.$$", ">";
print $fh <<EOF;
ATTRIBUTE User-Name 1 string
ATTRIBUTE NAS-IP-Address 4 ipaddr
ATTRIBUTE NAS-Port 5 integer
ATTRIBUTE Reply-Message 18 string
EOF
close $fh;
};
END { unlink 'dict.' . $$; }
my $d = new Net::Radius::Dictionary "dict.$$";
isa_ok($d, 'Net::Radius::Dictionary');
# Build a request and test it is ok
my $p = new Net::Radius::Packet $d;
isa_ok($p, 'Net::Radius::Packet');
$p->set_identifier(42);
$p->set_authenticator("\x66" x 16);
$p->set_code("Access-Reject");
is($p->attr_slots, 0, "Correct number of attribute slots in empty packet");
is($p->attr_slot_name(0), undef, "Undefined slot 0 name (e)");
is($p->attr_slot_val(0), undef, "Undefined slot 0 value (e)");
$p->set_attr("Reply-Message" => 'line-1');
$p->set_attr("Reply-Message" => 'line-2');
my $q = new Net::Radius::Packet $d, $p->pack;
isa_ok($q, 'Net::Radius::Packet');
is($p->attr_slots, 2, "Correct number of attribute slots");
is($p->attr_slot_name(0), 'Reply-Message', "Correct name for slot 0");
is($p->attr_slot_val(0), 'line-1', "Correct value for slot 0");
is($p->attr_slot_name(1), 'Reply-Message', "Correct name for slot 1");
is($p->attr_slot_val(1), 'line-2', "Correct value for slot 1");
is($p->attr_slot_name(2), undef, "Undefined slot 2 name");
is($p->attr_slot_val(2), undef, "Undefined slot 2 value");
$q = new Net::Radius::Packet $d, $p->pack;
isa_ok($q, 'Net::Radius::Packet');
is($q->attr_slot_name(0), 'Reply-Message', "Correct name for slot 0 (q)");
is($q->attr_slot_val(0), 'line-1', "Correct value for slot 0 (q)");
is($q->attr_slot_name(1), 'Reply-Message', "Correct name for slot 1 (q)");
is($q->attr_slot_val(1), 'line-2', "Correct value for slot 1 (q)");
is($q->attr_slot_name(2), undef, "Undefined slot 2 name (q)");
is($q->attr_slot_val(2), undef, "Undefined slot 2 value (q)");
# Add a third attribute to the packet and verify what happens
$p->set_attr("NAS-Port" => "42");
is($p->attr_slots, 3, "Correct number of attribute slots");
is($p->attr_slot_name(2), 'NAS-Port', "Correct name for slot 2");
is($p->attr_slot_val(2), '42', "Correct value for slot 2");
is($p->attr_slot_name(3), undef, "Undefined slot 3 name");
is($p->attr_slot_val(3), undef, "Undefined slot 3 value");
# Remove attr slot 1 and check what happened
$p->unset_attr_slot(1);
is($p->attr_slots, 2, "Correct number of attribute slots");
is($p->attr_slot_name(0), 'Reply-Message', "Correct name for slot 0 (q)");
is($p->attr_slot_val(0), 'line-1', "Correct value for slot 0 (q)");
is($p->attr_slot_name(1), 'NAS-Port', "Correct name for slot 1");
is($p->attr_slot_val(1), '42', "Correct value for slot 1");
is($p->attr_slot_name(2), undef, "Undefined slot 2 name");
is($p->attr_slot_val(2), undef, "Undefined slot 2 value");
# Remove an already unexistant slot
$p->unset_attr_slot(2);
is($p->attr_slots, 2, "Correct number of attribute slots");
is($p->attr_slot_name(0), 'Reply-Message', "Correct name for slot 0 (q)");
is($p->attr_slot_val(0), 'line-1', "Correct value for slot 0 (q)");
is($p->attr_slot_name(1), 'NAS-Port', "Correct name for slot 1");
is($p->attr_slot_val(1), '42', "Correct value for slot 1");
is($p->attr_slot_name(2), undef, "Undefined slot 2 name");
is($p->attr_slot_val(2), undef, "Undefined slot 2 value");
# Remove slot 1
$p->unset_attr_slot(1);
is($p->attr_slots, 1, "Correct number of attribute slots");
is($p->attr_slot_name(0), 'Reply-Message', "Correct name for slot 0 (q)");
is($p->attr_slot_val(0), 'line-1', "Correct value for slot 0 (q)");
is($p->attr_slot_name(1), undef, "Undefined slot 1 name");
is($p->attr_slot_val(1), undef, "Undefined slot 1 value");
# Remove last slot
$p->unset_attr_slot(0);
is($p->attr_slots, 0, "Correct number of attribute slots");
is($p->attr_slot_name(0), undef, "Undefined slot 0 name");
is($p->attr_slot_val(0), undef, "Undefined slot 0 value");
# Remove last slot (again)
$p->unset_attr_slot(0);
is($p->attr_slots, 0, "Correct number of attribute slots");
is($p->attr_slot_name(0), undef, "Undefined slot 0 name");
is($p->attr_slot_val(0), undef, "Undefined slot 0 value");
# Remove first slot
$q->set_attr("NAS-Port" => "42");
is($q->attr_slots, 3, "Correct number of attribute slots");
is($q->attr_slot_name(2), 'NAS-Port', "Correct name for slot 2");
is($q->attr_slot_val(2), '42', "Correct value for slot 2");
is($q->attr_slot_name(3), undef, "Undefined slot 3 name");
is($q->attr_slot_val(3), undef, "Undefined slot 3 value");
$q->unset_attr_slot(0);
is($q->attr_slot_name(0), 'Reply-Message', "Correct name for slot 0 (q)");
is($q->attr_slot_val(0), 'line-2', "Correct value for slot 0 (q)");
is($q->attr_slot_name(1), 'NAS-Port', "Correct name for slot 1 (q)");
is($q->attr_slot_val(1), '42', "Correct value for slot 1 (q)");
is($q->attr_slot_name(2), undef, "Undefined slot 2 name (q)");
is($q->attr_slot_val(2), undef, "Undefined slot 2 value (q)");

55
t/attrunset.t Normal file
View File

@@ -0,0 +1,55 @@
#!/usr/bin/perl
# Test attribute unsetting attributes with ASCII and non-ASCII (8-bit) values
# $Id: attrunset.t 81 2007-04-26 20:25:21Z lem $
use IO::File;
use Test::More qw/no_plan/;
use Net::Radius::Packet;
use Net::Radius::Dictionary;
# Init the dictionary for our test run...
BEGIN {
my $fh = new IO::File "dict.$$", ">";
print $fh <<EOF;
ATTRIBUTE User-Name 1 string
ATTRIBUTE NAS-IP-Address 4 ipaddr
ATTRIBUTE NAS-Port 5 integer
ATTRIBUTE Reply-Message 18 string
EOF
close $fh;
};
END { unlink 'dict.' . $$; }
my $d = new Net::Radius::Dictionary "dict.$$";
isa_ok($d, 'Net::Radius::Dictionary');
# Build a request and test it is ok
my $p = new Net::Radius::Packet $d;
isa_ok($p, 'Net::Radius::Packet');
$p->set_identifier(42);
$p->set_authenticator("\x66" x 16);
$p->set_code("Access-Accept");
$p->set_attr('Reply-Message' => 'Hello World 1');
is($p->attr('Reply-Message'), 'Hello World 1', 'ASCII Reply-Message loaded');
$p->unset_attr('Reply-Message', $p->attr('Reply-Message'));
is($p->attr('Reply-Message'), undef, 'ASCII Reply-Message deleted');
$p->set_attr('Reply-Message' => '¡Hola Mundo!');
is($p->attr('Reply-Message'), '¡Hola Mundo!', 'UTF-8 Reply-Message loaded');
$p->unset_attr('Reply-Message', $p->attr('Reply-Message'));
is($p->attr('Reply-Message'), undef, 'UTF-8 Reply-Message loaded');
$p->set_attr('Reply-Message' => "\xde\xad\x00\xbe\xef");
is($p->attr('Reply-Message'), "\xde\xad\x00\xbe\xef",
'8-bit Reply-Message present');
$p->unset_attr('Reply-Message', $p->attr('Reply-Message'));
is($p->attr('Reply-Message'), undef, '8-bit Reply-Message deleted');

106
t/auth.t Normal file
View File

@@ -0,0 +1,106 @@
#!/usr/bin/perl
# Test packet auth code
# $Id: auth.t 48 2006-11-14 20:05:11Z lem $
no utf8;
use IO::File;
use Test::More 'no_plan';
use Net::Radius::Packet;
use Net::Radius::Dictionary;
# Init the dictionary for our test run...
BEGIN {
my $fh = new IO::File "dict.$$", ">";
print $fh <<EOF;
ATTRIBUTE User-Name 1 string
ATTRIBUTE User-Password 2 string
ATTRIBUTE NAS-IP-Address 4 ipaddr
ATTRIBUTE NAS-Port 5 integer
ATTRIBUTE Service-Type 6 integer
ATTRIBUTE Framed-Protocol 7 integer
ATTRIBUTE Called-Station-Id 30 string
ATTRIBUTE Calling-Station-Id 31 string
ATTRIBUTE Acct-Status-Type 40 integer
ATTRIBUTE Acct-Session-Id 44 string
ATTRIBUTE Acct-Authentic 45 integer
ATTRIBUTE NAS-Port-Type 61 integer
VALUE Service-Type Framed-User 2
VALUE Framed-Protocol PPP 1
VALUE Acct-Authentic RADIUS 1
VALUE NAS-Port-Type Virtual 5
VALUE Acct-Status-Type Stop 2
EOF
close $fh;
};
END { unlink 'dict.' . $$; }
my $d = new Net::Radius::Dictionary "dict.$$";
isa_ok($d, 'Net::Radius::Dictionary');
# Build a request and test it is ok
my $p = new Net::Radius::Packet $d;
isa_ok($p, 'Net::Radius::Packet');
$p->set_identifier(42);
$p->set_authenticator("\x66" x 16);
$p->set_code("Access-Request");
$p->set_attr("User-Name" => 'foo');
$p->set_attr('NAS-Port-Type' => 'Virtual');
$p->set_attr('NAS-IP-Address' => '10.10.10.10');
$p->set_attr('Service-Type' => 'Framed-User');
$p->set_attr('NAS-Port' => '42');
$p->set_attr('Calling-Station-Id' => '5551212');
$p->set_attr('Called-Station-Id' => '5551111');
$p->set_attr('Framed-Protocol' => 'PPP');
$p->set_password('bar', 'good-secret', 'User-Password');
my $q = new Net::Radius::Packet $d, $p->pack;
isa_ok($q, 'Net::Radius::Packet');
my $pass = $q->password('good-secret');
is($pass, 'bar', 'Correct password when good secret used');
$pass = $q->password('bad-secret');
isnt($pass, 'bar', 'Bad password when bad secret used');
# Now test the response authentication scheme
my $r = new Net::Radius::Packet $d;
isa_ok($r, 'Net::Radius::Packet');
$r->set_code('Access-Accept');
$r->set_attr("User-Name" => 'foo');
$r->set_identifier($p->identifier);
$r->set_authenticator($p->authenticator);
my $r_data = auth_resp($r->pack, 'good-secret');
ok(auth_req_verify($r_data, 'good-secret', $p->authenticator),
"Response matches request with proper secret");
ok(!auth_req_verify($r_data, 'bad-secret', $p->authenticator),
"Response doesn't match request with bad secret");
# Now test the accounting authentication scheme
$p = new Net::Radius::Packet $d;
isa_ok($p, 'Net::Radius::Packet');
$p->set_identifier(42);
$p->set_authenticator("\x0" x 16);
$p->set_code("Accounting-Request");
$p->set_attr("User-Name" => 'foo');
$p->set_attr('NAS-Port-Type' => 'Virtual');
$p->set_attr('NAS-IP-Address' => '10.10.10.10');
$p->set_attr('Service-Type' => 'Framed-User');
$p->set_attr('NAS-Port' => '42');
$p->set_attr('Calling-Station-Id' => '5551212');
$p->set_attr('Called-Station-Id' => '5551111');
$p->set_attr('Framed-Protocol' => 'PPP');
my $p_data = auth_resp($p->pack, 'good-secret');
ok(auth_acct_verify($p_data, 'good-secret'),
"Validate acct req with good secret");
ok(!auth_acct_verify($p_data, 'bad-secret'),
"Validate acct req with bad secret");

1918
t/basedict.t Normal file
View File

File diff suppressed because it is too large Load Diff

193
t/bundled.t Normal file
View File

@@ -0,0 +1,193 @@
#!/usr/bin/perl
# Test the parsing of the bundled dictionary files...
# $Id: bundled.t 98 2009-10-14 15:26:33Z lem $
use Test::Warn;
use Test::More;
use Net::Radius::Dictionary;
my %dict =
(
'dicts/dictionary.base'
=> { attr => 39, vendor => undef, vsa => 0 },
'dicts/dictionary.3com-o'
=> { attr => 3, vendor => 'USR', vsa => 259 },
'dicts/dictionary'
=> { attr => 78, vendor => undef, vsa => 0 },
'dicts/dictionary.3com'
=> { attr => 0, vendor => '3com', vsa => 1 },
'dicts/dictionary.3gpp2'
=> { attr => 0, vendor => '3GPP2', vsa => 74 },
'dicts/dictionary.3gpp'
=> { attr => 0, vendor => '3GPP', vsa => 17 },
'dicts/dictionary.acc'
=> { attr => 0, vendor => 'Acc', vsa => 47 },
'dicts/dictionary.alcatel'
=> { attr => 0, vendor => 'Alcatel', vsa => 21 },
'dicts/dictionary.alteon'
=> { attr => 0, vendor => 'Alteon', vsa => 1 },
'dicts/dictionary.altiga'
=> { attr => 0, vendor => 'Altiga', vsa => 29},
'dicts/dictionary.aptis'
=> { attr => 0, vendor => 'Aptis', vsa => 36 },
'dicts/dictionary.ascend'
=> { attr => 137, vendor => 'Ascend',vsa => 249 },
'dicts/dictionary.bay'
=> { attr=>0,vendor=>'Bay-Networks',vsa => 65 },
'dicts/dictionary.bintec'
=> { attr => 0, vendor => 'BinTec', vsa => 17 },
'dicts/dictionary.bristol'
=> { attr => 0, vendor => 'Bristol', vsa => 5 },
'dicts/dictionary.broadsoft'
=> { attr => 0, vendor => 'BroadSoft', vsa => 132 },
'dicts/dictionary.cablelabs'
=> { attr => 0, vendor => 'CableLabs', vsa => 62 },
'dicts/dictionary.cabletron'
=> { attr => 0, vendor => 'Cabletron', vsa => 2 },
'dicts/dictionary.cisco'
=> { attr => 0, vendor => 'Cisco', vsa => 83 },
'dicts/dictionary.cisco.bbsm'
=> { attr => 0, vendor => 'Cisco-BBSM', vsa => 1 },
'dicts/dictionary.cisco.vpn3000'
=> { attr => 0, vendor => 'Cisco-VPN3000', vsa => 74 },
'dicts/dictionary.cisco.vpn5000'
=> { attr => 0, vendor => 'Cisco-VPN5000', vsa => 7 },
'dicts/dictionary.colubris'
=> { attr => 0, vendor => 'Colubris', vsa => 1 },
'dicts/dictionary.columbia_university'
=> { attr => 0, vendor => 'Columbia-University', vsa => 4 },
'dicts/dictionary.compat'
=> { attr => 21, vendor => undef, vsa => 0 },
'dicts/dictionary.cosine'
=> { attr => 0, vendor => 'Cosine', vsa => 8 },
'dicts/dictionary.erx'
=> { attr => 0, vendor => 'ERX', vsa => 51 },
'dicts/dictionary.extreme'
=> { attr => 0, vendor => 'Extreme', vsa => 4 },
'dicts/dictionary.foundry'
=> { attr => 0, vendor => 'Foundry', vsa => 4 },
'dicts/dictionary.freeradius'
=> { attr => 0, vendor => 'FreeRADIUS', vsa => 1 },
'dicts/dictionary.gandalf'
=> { attr => 0, vendor => 'Gandalf', vsa => 33 },
'dicts/dictionary.garderos'
=> { attr => 0, vendor => 'Garderos', vsa => 2 },
'dicts/dictionary.gemtek'
=> { attr => 0, vendor => 'Gemtek', vsa => 6 },
'dicts/dictionary.huawei'
=> { attr => 0, vendor => 'Huawei', vsa => 52 },
'dicts/dictionary.itk'
=> { attr => 0, vendor => 'ITK', vsa => 32 },
'dicts/dictionary.juniper'
=> { attr => 0, vendor => 'Juniper', vsa => 5 },
'dicts/dictionary.karlnet'
=> { attr => 0, vendor => 'KarlNet', vsa => 4 },
'dicts/dictionary.livingston'
=> { attr => 0, vendor => 'Livingston', vsa => 21 },
'dicts/dictionary.localweb'
=> { attr => 0, vendor => 'Local-Web', vsa => 15 },
'dicts/dictionary.merit'
=> { attr => 0, vendor => 'Merit', vsa => 3 },
'dicts/dictionary.microsoft'
=> { attr => 0, vendor => 'Microsoft', vsa => 33 },
'dicts/dictionary.mikrotik'
=> { attr => 0, vendor => 'Mikrotik', vsa => 3 },
'dicts/dictionary.navini'
=> { attr => 0, vendor => 'Navini', vsa => 1 },
'dicts/dictionary.netscreen'
=> { attr => 0, vendor => 'Netscreen', vsa => 7 },
'dicts/dictionary.nokia'
=> { attr => 5, vendor => undef, vsa => 0 },
'dicts/dictionary.nomadix'
=> { attr => 0, vendor => 'Nomadix', vsa => 13 },
'dicts/dictionary.propel'
=> { attr => 0, vendor => 'Propel', vsa => 5 },
'dicts/dictionary.quintum'
=> { attr => 0, vendor => 'Quintum', vsa => 23 },
'dicts/dictionary.redback'
=> { attr => 0, vendor => 'Redback', vsa => 170 },
'dicts/dictionary.redcreek'
=> { attr => 0, vendor => 'RedCreek', vsa => 9 },
'dicts/dictionary.shasta'
=> { attr => 0, vendor => 'Shasta', vsa => 3 },
'dicts/dictionary.shiva'
=> { attr => 0, vendor => 'Shiva', vsa => 16 },
'dicts/dictionary.sonicwall'
=> { attr => 0, vendor => 'SonicWall', vsa => 4 },
'dicts/dictionary.springtide'
=> { attr => 0, vendor => 'SpringTide', vsa => 8 },
'dicts/dictionary.t_systems_nova'
=> { attr => 0, vendor => 'T-Systems-Nova', vsa => 15 },
'dicts/dictionary.telebit'
=> { attr => 0, vendor => 'Telebit', vsa => 4 },
'dicts/dictionary.trapeze'
=> { attr => 0, vendor => 'Trapeze', vsa => 8 },
'dicts/dictionary.tunnel'
=> { attr => 12, vendor => undef, vsa => 0 },
'dicts/dictionary.unisphere'
=> { attr => 0, vendor => 'Unisphere', vsa => 49 },
'dicts/dictionary.unix'
=> { attr => 0, vendor => 'Unix', vsa => 6 },
'dicts/dictionary.usr'
=> { attr => 2, vendor => 'USR', vsa => 259 },
'dicts/dictionary.valemount'
=> { attr => 0, vendor => 'ValemountNetworks', vsa => 5 },
'dicts/dictionary.versanet'
=> { attr => 0, vendor => 'Versanet', vsa => 1 },
'dicts/dictionary.wispr'
=> { attr => 0, vendor => 'WISPr', vsa => 11 },
'dicts/dictionary.xedia'
=> { attr => 0, vendor => 'Xedia', vsa => 6 },
);
plan tests => 6 * keys %dict;
# Determine which dicts are not readable and produce the appropiate skip
for my $d (keys %dict)
{
unless (-f $d)
{
delete $dict{$d};
fail "Access $d: $!";
SKIP: { skip "(Consequence of previous failure)", 5 };
next;
}
$dict{$d}->{dict} = new Net::Radius::Dictionary;
isa_ok($dict{$d}->{dict}, 'Net::Radius::Dictionary');
}
# Verify what happens upon reading the dictionary - Check for warnings
# if the proper module is available
while (my ($dict, $h) = each %dict)
{
warning_is { $h->{dict}->readfile($dict) } undef,
"No warning to readfile('$dict')";
}
# Now check the dictionary contents...
# XXX - These tests peek inside the object. Probably their methods should
# be encapsulated through adequate accessors. However, these functions
# are never required for real use
while (my ($d, $h) = each %dict)
{
my $dict = $h->{dict};
my $attr = $dict->{attr};
is(keys %{$attr}, $dict{$d}->{attr}, "Correct number of attributes in $d");
my $num = undef;
SKIP: {
skip "No vendors defined in $d", 3
if not defined $dict{$d}->{vendor};
warning_is {$num = $dict->vendor_num($dict{$d}->{vendor})} undef,
"No warn fetching vendor " . $dict{$d}->{vendor} . " in $d" ;
ok(defined $num, "Vendor " . $dict{$d}->{vendor} . " in $d");
is(scalar(keys %{$dict->{vsattr}->{$num}}),
$dict{$d}->{vsa},
"Correct number of VSAs for " . $dict{$d}->{vendor} . " in $d");
# print "$_\n" for keys %{$dict->{vsattr}->{$num}};
};
}

146
t/dictover.t Normal file
View File

@@ -0,0 +1,146 @@
#!/usr/bin/perl
# Test the overriding of specific entries
# $Id: dictover.t 27 2006-08-09 16:00:01Z lem $
use IO::File;
use Test::More;
use Data::Dumper;
use Net::Radius::Dictionary;
my $dictfile = "dict$$.tmp";
my $overfile = "over$$.tmp";
END
{
unlink $dictfile, $overfile;
};
my @dicts = ();
my @refs = ();
{
local $/ = "EOD\n";
@dicts = map { (s/EOD\n$//, $_)[1] } <DATA>;
};
$refs[0] = bless {
'vsattr' => {},
'rattr' => {},
'vendors' => {},
'rvsaval' => {},
'val' => {},
'rvsattr' => {},
'attr' => {},
'rval' => {},
'vsaval' => {}
}, 'Net::Radius::Dictionary';
$refs[1] = bless {
'vsattr' => {
'9' => {
'Cisco-AVPair' => ['1', 'string' ],
'cisco-thing' => ['2', 'string' ]
}
},
'rattr' => {
'1' => ['User-Name', 'string'],
'23' => ['Framed-IPX-Network', 'ipaddr'],
'10' => ['Framed-Routing', 'integer']
},
'vendors' => {
'Cisco' => '9'
},
'rvsaval' => {},
'val' => {},
'rvsattr' => {
'9' => {
'1' => ['Cisco-AVPair', 'string'],
'2' => ['cisco-thing', 'string']
}
},
'attr' => {
'Framed-IPX-Network' => ['23', 'ipaddr'],
'Framed-Routing' => ['10', 'integer'],
'User-Name' => ['1', 'string']
},
'rval' => {},
'vsaval' => {}
}, 'Net::Radius::Dictionary';
sub _write
{
my $dict = shift;
my $fh = new IO::File;
$fh->open($dictfile, "w") or diag "Failed to write dict $dictfile: $!";
print $fh $dict;
$fh->close;
}
plan tests => 27 * scalar @dicts;
my $fh = new IO::File;
$fh->open($overfile, "w") or
diag "Failed to create dictionary override file $overfile: $!";
print $fh <<EOF;
ATTRIBUTE User-Name 255 ipaddr
VENDOR Cisco 254
ATTRIBUTE Cisco-AVPair 253 string Cisco
VENDORATTR 253 cisco-thing 252 string
EOF
;
$fh->close;
for my $i (0 .. $#dicts)
{
_write $dicts[$i];
my $d;
eval { $d = new Net::Radius::Dictionary $dictfile; };
isa_ok($d, 'Net::Radius::Dictionary');
ok(!$@, "No errors during parse");
diag $@ if $@;
for my $k (keys %{$refs[$i]})
{
ok(exists $d->{$k}, "Element $k exists in the object");
is_deeply($d->{$k}, $refs[$i]->{$k}, "Same contents in element $k");
}
eval { $d->readfile($overfile); };
ok(!$@, "No errors during parse of override dictionary");
diag $@ if $@;
is($d->attr_num('User-Name'), 255,
'Correct number of overriden User-Name');
is ($d->attr_name(255), 'User-Name',
'Correct name for User-Name overriden attribute code');
is($d->attr_type('User-Name'), 'ipaddr',
'Correct type of overriden User-Name');
is($d->vendor_num('Cisco'), 254,
'Correct overriding of vendor code');
is ($d->vsattr_num(254, 'Cisco-AVPair'), 253,
'Correct overriding of VSA Attribute name');
is ($d->vsattr_name(254, 253), 'Cisco-AVPair',
'Correct overriding of VSA Attribute number');
}
__END__
# Empty dictionary
EOD
# Sample dictionary
ATTRIBUTE User-Name 1 string
ATTRIBUTE Framed-Routing 10 integer
ATTRIBUTE Framed-IPX-Network 23 ipaddr
VENDOR Cisco 9
ATTRIBUTE Cisco-AVPair 1 string Cisco
VENDORATTR 9 cisco-thing 2 string

72
t/dump.t Normal file
View File

@@ -0,0 +1,72 @@
#!/usr/bin/perl
# Test packet dumping
# $Id: dump.t 38 2006-11-14 01:46:05Z lem $
no utf8;
use IO::File;
use Test::More tests => 257;
use Net::Radius::Packet;
use Net::Radius::Dictionary;
# Init the dictionary for our test run...
BEGIN {
my $fh = new IO::File "dict.$$", ">";
print $fh <<EOF;
ATTRIBUTE User-Name 1 string
ATTRIBUTE User-Password 2 string
ATTRIBUTE NAS-IP-Address 4 ipaddr
EOF
close $fh;
};
END { unlink 'dict.' . $$; }
# Build a request and test it is ok
my $p = new Net::Radius::Packet;
isa_ok($p, 'Net::Radius::Packet');
$p->set_dict("dict.$$");
$p->set_code("Access-Request");
$p->set_attr("User-Name" => 'FOO@MY.DOMAIN');
$p->set_attr("NAS-IP-Address" => "127.0.0.1");
my $str;
# Really special chars
for my $c (0 .. 31, 127..255)
{
$p->set_authenticator(substr("Char-" . chr($c) . "\x0" x 16, 0, 16));
$str = $p->str_dump;
my $re = sprintf('(?m)^Authentic:\s+Char-\\\\x\{%x\}(?:\\\\x\{0\})+$', $c);
like($str, qr/$re/, "Correct dump of chr($c)");
}
# Really normal chars
for my $c (32..35, 44..45, 47 .. 62, 64 .. 90, 95, 97..122, 124)
{
$p->set_authenticator(substr("Char-" . chr($c) . "\x0" x 16, 0, 16));
$str = $p->str_dump;
my $re = sprintf('(?m)^Authentic:\s+Char-%s(?:\\\\x\{0\})+$', chr($c));
like($str, qr/$re/, "Correct dump of chr($c)");
}
# Things that mean something special to Perl
for my $c (42, 43, 46, 63)
{
$p->set_authenticator(substr("Char-" . chr($c) . "\x0" x 16, 0, 16));
$str = $p->str_dump;
my $re = sprintf('(?m)^Authentic:\s+Char-\\%s(?:\\\\x\{0\})+$', chr($c));
like($str, qr/$re/, "Correct dump of chr($c)");
}
# Quote-like things
for my $c (36..41, 91..94, 96, 123..125)
{
$p->set_authenticator(substr("Char-" . chr($c) . "\x0" x 16, 0, 16));
$str = $p->str_dump;
my $re = sprintf('(?m)^Authentic:\s+Char-\\\\\\%s(?:\\\\x\{0\})+$',
chr($c));
like($str, qr/$re/, "Correct dump of chr($c)");
}

108
t/packdict.t Normal file
View File

@@ -0,0 +1,108 @@
#!/usr/bin/perl
# Test the parsing of individual attributes
# $Id: packdict.t 37 2006-11-14 01:42:55Z lem $
use IO::File;
use Test::More tests => 30;
use Data::Dumper;
use Net::Radius::Dictionary;
my $dictfile = "dict$$.tmp";
END
{
unlink $dictfile;
};
{
my $dict;
eval { $dict = Net::Radius::Dictionary->new() };
isa_ok($dict, 'Net::Radius::Dictionary');
ok(!$@, 'No errors during parse');
diag $@ if $@;
# Test presence of some stuff
my %number_for = $dict->packet_numbers();
is(scalar(keys %number_for), 35, 'Default packet numbers number');
is($number_for{'Disconnect-NAK'}, 42, 'Simple mapping presence in hash');
my %name_for = $dict->packet_names();
is(scalar(keys %name_for), 34, 'Default packet names number');
is($name_for{40}, 'Disconnect-Request', 'Simple mapping presence in hash');
is($name_for{6}, 'Interim-Accounting',
'Back-resolution of 6 to Interim Accounting as default');
# Direct resolution
ok($dict->packet_hasname('Access-Reject'),
'packet_hasname() to default');
is($dict->packet_num('Access-Reject'), 3, 'packet_num() to default');
ok($dict->packet_hasnum(2), 'packet_hasnum() to default');
is($dict->packet_name(2), 'Access-Accept', 'packet_name() to default');
ok(! $dict->packet_hasname('@@Inexistent@@'),
'packet_hasname() on inexistent');
is($dict->packet_num('@@Inexistent@@'), undef,
'packet_num() on inexistent');
ok(! $dict->packet_hasnum(-1), 'packet_hasnum() on inexistent');
is($dict->packet_name(-1), undef, 'packet_name() on inexistent');
}
{
my $dict_content = do { local $/; <DATA>; };
_write($dict_content);
my $dict;
eval { $dict = Net::Radius::Dictionary->new($dictfile) };
isa_ok($dict, 'Net::Radius::Dictionary');
ok(!$@, 'No errors during parse');
diag $@ if $@;
# Test presence of some stuff
my %number_for = $dict->packet_numbers();
is(scalar(keys %number_for), 10, 'Packet numbers number');
is($number_for{'My-Experiment'}, 250, 'Simple mapping presence in hash');
my %name_for = $dict->packet_names();
is(scalar(keys %name_for), 10, 'Packet names number');
is($name_for{1}, 'Access-Request', 'Simple mapping presence in hash');
is($name_for{250}, 'My-Experiment', 'Experimental value');
# Direct resolution
ok($dict->packet_hasname('Access-Reject'),
'packet_hasname() to default');
is($dict->packet_num('Access-Reject'), 3, 'packet_num() to default');
ok($dict->packet_hasnum(2), 'packet_hasnum() to default');
is($dict->packet_name(2), 'Access-Accept', 'packet_name() to default');
ok(! $dict->packet_hasname('Disconnect-Request'),
'packet_hasname() on inexistent');
is($dict->packet_num('Disconnect-NAK'), undef,
'packet_num() on inexistent');
ok(! $dict->packet_hasnum(41), 'packet_hasnum() on inexistent');
is($dict->packet_name(41), undef, 'packet_name() on inexistent');
}
sub _write
{
my $dict = shift;
my $fh = new IO::File;
$fh->open($dictfile, "w") or diag "Failed to write dict $dictfile: $!";
print $fh $dict;
$fh->close;
}
__END__
# Sample dictionary
PACKET Access-Request 1
PACKET Access-Accept 2
PACKET Access-Reject 3
PACKET Accounting-Request 4
PACKET Accounting-Response 5
PACKET Accounting-Status 6
PACKET Access-Challenge 11
PACKET Status-Server 12
PACKET Status-Client 13
PACKET My-Experiment 250

128
t/packets.t Normal file
View File

@@ -0,0 +1,128 @@
#!/usr/bin/perl
# Process each binary packet in the distribution, performing generic tests
# on it
# $Id: packets.t 73 2007-01-30 10:22:35Z lem $
no utf8;
use strict;
use warnings;
use IO::File;
use File::Find;
use Test::More;
use Test::Warn;
use Net::Radius::Packet;
use Net::Radius::Dictionary;
# Pick a default dictionary to use in case none is defined
my $def_dict = 'dicts/dictionary';
# Find all the test inputs we will be processing here
my @inputs = ();
find ({ untaint => 1, follow => 1, no_chdir => 1,
wanted => sub
{
return unless $File::Find::name =~ m/\.p$/;
push @inputs, $File::Find::name;
},
}, qw!packets!);
# Provide a test plan based in how many test inputs where found
plan tests => @inputs * 13;
# Perform the tests for each test input
for my $i (@inputs)
{
SKIP: {
# Read the test input
skip "$i not readable", 12 unless -r $i and -r _;
my $fh = new IO::File $i, "r";
my $input = '';
our $VAR1 = undef; # Placeholder for the recovered structure
ok($fh, "Open test input $i for reading");
do {
local $/ = undef;
ok ($input = <$fh>, "Read non-empty test input");
};
ok(close $fh, "Close the test input after reading");
ok(length($input), "Test input is non-empty");
like($input, qr/# Net::Radius test input/m,
"Input looks like a test input");
unless (eval "$input" and ok(!$@, "Eval errors"))
{
diag $@;
skip "Problems with eval() of $i", 7;
}
ok(ref($VAR1) eq 'HASH', "Load $i: " .
($VAR1->{description} || 'No desc'));
# Try to build a suitable dictionary for decoding the packet
my $d;
if ($VAR1->{dictionary})
{
# Use bundled dictionary for decoding this packet
$d = $VAR1->{dictionary};
}
else
{
$d = new Net::Radius::Dictionary;
if ($VAR1->{opts}->{dictionary})
{
# Try to load the specified dictionaries - Ignore errors
$d->readfile($_) for @{$VAR1->{opts}->{dictionary}};
}
else
{
# Try to load the default dictionary
$d->readfile($def_dict);
}
}
isa_ok($d, 'Net::Radius::Dictionary');
my $p;
warnings_are(sub { $p = new Net::Radius::Packet $d, $VAR1->{packet} },
[], "No warnings on packet decode");
isa_ok($p, 'Net::Radius::Packet');
if (exists($VAR1->{slots}))
{
is $p->attr_slots, $VAR1->{slots}, "Correct number of slots";
}
else
{
SKIP: { skip "Test input provides no number of slots", 1 };
}
if (exists($VAR1->{identifier}))
{
is $p->identifier, $VAR1->{identifier}, "Correct identifier";
}
else
{
SKIP: { skip "Test input provides no identifier", 1 };
}
if (exists($VAR1->{authenticator}))
{
is $p->authenticator, $VAR1->{authenticator},
"Correct authenticator";
}
else
{
SKIP: { skip "Test input provides no authenticator", 1 };
}
};
}

84
t/vsa.t Normal file
View File

@@ -0,0 +1,84 @@
#!/usr/bin/perl
# Test VSA packing and unpacking
# $Id: vsa.t 83 2007-06-08 13:57:58Z lem $
use IO::File;
use Test::More tests => 14;
use Net::Radius::Packet;
use Net::Radius::Dictionary;
# Init the dictionary for our test run...
BEGIN {
my $fh = new IO::File "dict.$$", ">";
print $fh <<EOF;
ATTRIBUTE User-Name 1 string
ATTRIBUTE NAS-Port 5 integer
ATTRIBUTE Service-Type 6 integer
VALUE Service-Type Framed-User 2
VENDOR Cisco-VPN3000 3076
ATTRIBUTE CVPN3000-Access-Hours 1 string Cisco-VPN3000
ATTRIBUTE CVPN3000-Simultaneous-Logins 2 integer Cisco-VPN3000
VENDORATTR 88888 Resource-Name 1 string
EOF
close $fh;
};
END { unlink 'dict.' . $$; }
my $d = new Net::Radius::Dictionary "dict.$$";
isa_ok($d, 'Net::Radius::Dictionary');
# use Data::Dumper;
# diag 'd: ', Data::Dumper->Dump([$d]);
# Build a request and test it is ok - We're leaving out the
# authenticator calculation
my $p = new Net::Radius::Packet $d;
isa_ok($p, 'Net::Radius::Packet');
$p->set_identifier(42);
$p->set_authenticator("\x66" x 16);
$p->set_code("Access-Accept");
$p->set_attr("User-Name" => 'foo');
$p->set_attr('Service-Type' => 'Framed-User');
$p->set_attr('NAS-Port' => '42');
$p->set_vsattr('Cisco-VPN3000', 'CVPN3000-Access-Hours', "Access-Hours");
$p->set_vsattr('Cisco-VPN3000', 'CVPN3000-Simultaneous-Logins', 63);
$p->set_vsattr(88888, 'Resource-Name', 'storage');
my $q = new Net::Radius::Packet $d, $p->pack;
isa_ok($q, 'Net::Radius::Packet');
is($p->code, 'Access-Accept', "Correct packet code");
is($p->attr('User-Name'), 'foo', "Correct User-Name");
is($p->attr('Service-Type'), 'Framed-User', "Correct Framed-User");
is($p->attr('NAS-Port'), 42, "Correct NAS-Port");
is($p->attr('User-Name'), 'foo', "Correct User-Name");
is(ref($p->vsattr('Cisco-VPN3000', 'CVPN3000-Access-Hours')),
'ARRAY', "Correct type for string VSA");
is($p->vsattr('Cisco-VPN3000', 'CVPN3000-Access-Hours')->[0],
'Access-Hours', "Correct string VSA");
is(ref($p->vsattr('Cisco-VPN3000', 'CVPN3000-Simultaneous-Logins')),
'ARRAY', "Correct type for integer VSA");
is($p->vsattr('Cisco-VPN3000', 'CVPN3000-Simultaneous-Logins')->[0],
'63', "Correct integer VSA");
if(ok($p->vsattr(88888, 'Resource-Name'), "Fetch of numeric vid from VSA"))
{
is($p->vsattr(88888, 'Resource-Name')->[0],
'storage', "Correct integer VSA (numeric vid)");
}
else
{
# use Data::Dumper;
# diag 'q: ', Data::Dumper->Dump([$q]);
# diag 'p: ', Data::Dumper->Dump([$p]);
fail("Cannot test numeric vid VSA value");
}