File Coverage

blib/lib/Net/Radius/Server/Match.pm

Criterion	Covered	Total	%
statement	21	48	43.7
branch	0	16	0.0
condition	0	22	0.0
subroutine	7	10	70.0
pod			n/a
total	28	96	29.1

#! /usr/bin/perl
#
#
# $Id: Match.pm 75 2009-08-12 22:08:28Z lem $

package Net::Radius::Server::Match;

use 5.008;
use strict;
use warnings;
use Carp qw/croak/;

use Net::Radius::Server::Base ':match';
use base 'Net::Radius::Server::Base';
our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 75 $ =~ /\d+/g)[0]/1000 };

sub mk
{
    my $self = shift;
    croak "->mk() cannot have arguments when in object-method mode\n"
	if ref($self) and $self->isa('UNIVERSAL') and @_;

    my $n = $self;

    if (@_)
    {
	$n = $self->new(@_);
	die "Failed to create new object\n" unless $n;
    }

    return sub { $n->_match(@_) };
}

sub _match
{
    my $self	= shift;
    my $r_args	= shift;

    for my $arg (sort keys %$self)
    {
	my $n = NRS_MATCH_OK;
	next if $arg =~ /^_/;
	if ($self->can('match_' . $arg))
	{
	    no strict 'refs';
	    my $m = 'match_' . $arg;
	    $self->log(4, "Invoking match method $m");
	    $n = $self->$m($r_args, @_);
	}
	unless ($n == NRS_MATCH_OK)
	{
	    if ($r_args->{dict})
	    {
		$self->log(2, "Fail request from " .
			   ($r_args->{request}->attr
			    ($r_args->{dict}->attr_name(4))
			    || '(no NAS-IP-Address)')
			   . " [" . ($r_args->{peer_addr} || '(no peer)')
			   . "] for user "
			   . ($r_args->{request}->attr
			      ($r_args->{dict}->attr_name(1))
			      || '(no user)'));
	    }
	    else
	    {
		$self->log(2, "Fail request from ["
			   . ($r_args->{peer_addr} || '(no peer)')
			   . "] and no dictionary");
	    }
	    $self->log(4, "Return $n from match method");
	    return $n;
	}
    }

    if ($r_args->{dict})
    {
	$self->log(2, "Match request from " .
		   ($r_args->{request}->attr
		    ($r_args->{dict}->attr_name(4))
		    || '(no NAS-IP-Address)')
		   . " [" . ($r_args->{peer_addr} || '(no peer)')
		   . "] for user "
		   . ($r_args->{request}->attr
		      ($r_args->{dict}->attr_name(1))
		      || '(no user)'));
    }
    else
    {
	$self->log(2, "Match request from ["
		   . ($r_args->{peer_addr} || '(no peer)')
		   . "] and no dictionary");
    }
    return NRS_MATCH_OK;	# Fail by default
}

42;

__END__