File Coverage

blib/lib/Net/Radius/Client.pm

Criterion	Covered	Total	%
statement	28	100	28.0
branch	2	42	4.7
condition	0	9	0.0
subroutine	9	10	90.0
pod	2	3	66.6
total	41	164	25.0

package Net::Radius::Client;

use 5.008;
use IO::Socket::INET;
use Net::Radius::Dictionary;
use Net::Radius::Packet;
use strict;
use warnings;
use Carp;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Net::Radius::Client ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
    load
    query
);

our $VERSION = '0.03';
our $debug = 0;

# Preloaded methods go here.

my $ident = 1;

# subroutine to make string of 16 random bytes
sub bigrand() {
    pack "n8",
    rand(65536), rand(65536), rand(65536), rand(65536),
    rand(65536), rand(65536), rand(65536), rand(65536);
}

my $dict = undef;

sub load {
    my ($d) = @_;
    # Net::Radius::Dictionary pass silently if
    # dictionary is not readable (seems like bug)
    die "Couldn't read dictionary $d\n" unless (-r $d);
    $dict = new Net::Radius::Dictionary $d
        or die "Couldn't read dictionary: $!";
}

sub query {
    my ($servers, $code, $argref) = @_;
    my $retref={};
    my ($rec, $req, $rsp);
    my $password;

    if (not defined($dict)) {
        load("dictionary");
    }

    $req = new Net::Radius::Packet $dict;
    $req->set_code($code);

    foreach my $vs (keys %$argref) {
        foreach my $a (keys %{$argref->{$vs}}) {
            if ($vs) {
                $req->set_vsattr($vs, $a, @{$argref->{$vs}->{$a}});
            } else {
                if ($a eq 'User-Password') {
                    $password = $argref->{$vs}->{$a}[0];
                } else {
                    $req->set_attr($a, $argref->{$vs}->{$a}[0]);
                }
            }
        }
    }

    my ($retries, $timeout, $rc);

    foreach my $host (keys %$servers) {
        foreach my $port (keys %{$servers->{$host}}) {
            if (defined($servers->{$host}->{$port}->{'retries'})) {
                $retries = $servers->{$host}->{$port}->{'retries'};
            } else {
                $retries = 3;
            }
            if (defined($servers->{$host}->{$port}->{'timeout'})) {
                $timeout = $servers->{$host}->{$port}->{'timeout'};
            } else {
                $timeout = 1;
            }

            $ident = ($ident + 1) & 255;
            $req->set_identifier($ident);

            if ($code eq 'Access-Request') {
                $req->set_authenticator(bigrand);
            } else {
                $req->set_authenticator("");
            }

            if ($code eq 'Access-Request') {
                $req->unset_attr('User-Password');
                $req->set_password($password, $servers->{$host}->{$port}->{'secret'});
            }

            $req->dump if ($debug);

            my $pack = $req->pack; # Can generate error 'Unknown RADIUS tuples'
                                   # if dictionary has not been loaded (bug?)
            if ($code ne 'Access-Request') {
                $pack = auth_resp($pack,$servers->{$host}->{$port}->{'secret'});
            }

            my $socket = new IO::Socket::INET->new(PeerAddr => $host,
                                                   PeerPort => $port,
                                                   Proto    => 'udp',
                                                   Timeout  => $timeout);

            while($retries) {
                $retries--;

                $rc = $socket->send($pack);
                next if ($rc != length($pack));

                # Timeout parametor has no effect to recv method;
                # so we use select to detect timeout
                my $rin = '';
                vec($rin, fileno($socket), 1) = 1;
                my $nfound = select($rin, undef, undef, $timeout);
                next if ($nfound <= 0); # either timeout or end of file

                my $rec;
                $rc = $socket->recv($rec, 4096); # RFC2866: 20<=size<=4095
                next unless ($rc);

                $rsp = new Net::Radius::Packet $dict, $rec;

                # Make sure response is authentic
                {
                    my $p = $rec;
                    substr($p, 4, 16) = $req->authenticator;
                    $p = auth_resp($p,$servers->{$host}->{$port}->{'secret'});
                    if ($rsp->authenticator ne substr($p, 4, 16)) {
                        next; # ignore non-authentic response
                    }
                }

                $rsp->dump if ($debug);

                next if ($rsp->identifier != $ident);

                if ($code eq 'Access-Request' and
                    $rsp->code ne 'Access-Accept' and
                    $rsp->code ne 'Access-Reject') {
                    next;
                }
                if ($code eq 'Accounting-Request' and
                    $rsp->code ne 'Accounting-Response') {
                    next;
                }

                foreach my $a ($rsp->attributes) {
                    if (not defined($retref->{0})) {
                        $retref->{0} = {};
                    }
                    $retref->{0}->{$a} = [ $rsp->attr($a) ];
                }
                foreach my $v ($rsp->vendors) {
                    foreach my $a ($rsp->vsattributes($v)) {
                        if (not defined($retref->{$v})) {
                            $retref->{$v} = {};
                        }
                        $retref->{$v}->{$a} = $rsp->vsattr($v, $a);
                    }
                }

                return ($rsp->code, \%$retref);
            }
        }
    }

    return ('', \%$retref);
}

1;
__END__