File Coverage

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

Criterion	Covered	Total	%
statement	18	93	19.3
branch	0	52	0.0
condition	0	20	0.0
subroutine	6	10	60.0
pod			n/a
total	24	175	13.7

#! /usr/bin/perl
#
#
# $Id: DBStore.pm 109 2009-10-17 22:00:16Z lem $

package Net::Radius::Server::DBStore;

use 5.010;
use strict;
use warnings;

use Storable qw/freeze/;

use Net::Radius::Server::Base qw/:set/;
use base 'Net::Radius::Server::Base';
__PACKAGE__->mk_accessors(qw/key_attrs param store result sync
			  pre_store_hook single frozen hashref
			  internal_tie/);
our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 109 $ =~ /\d+/g)[0]/1000 };

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

    my $self = $class;

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

    die "->mk() cannot proceed with no valid param defined\n"
	unless ref($self->param) eq 'ARRAY';

    # Enforce default values

    $self->frozen(1)       unless defined $self->frozen();
    $self->single(1)       unless defined $self->single();
    $self->internal_tie(1) unless defined $self->internal_tie();

    $self->key_attrs([ 'NAS-IP-Address', '|', 'Acct-Session-Id' ])
	unless $self->key_attrs();

    $self->store([ qw/ packet peer_addr peer_host peer_port port /])
	unless $self->store();

    $self->sync(1)
	unless defined $self->sync();

    $self->log_level(1)
	unless defined $self->log_level();

    # Create the tied hash that we will be passing into the actual method.

    my ($db, %hash);
    my ($c, @params) = (@{$self->param});

    $self->hashref(\%hash) unless $self->hashref;

    $self->log(2, "Tying to class '" . $c  . "'");
    $self->log(3, "Tie parameters are " . join(', ', @params));
    if ($self->internal_tie)
    {
	eval { $db = tie %{$self->hashref}, $c, @params };

	die "->mk() unable to tie: $!" unless $db;
	die "->mk() problem during tie: $@" if $@;
    }
    else
    {
	$self->log(2, "Not tying because ->internal_tie is true");
    }

    return sub { $self->_do_tie( $db, $self->hashref, @_ ) };
}

# Convert a scalar into the corresponding Radius attribute in
# $req. Will return non-matched scalars, to be used as delimiters in
# the resulting key.
sub _k
{
    my ($self, $db, $rhash, $r_data, $req, $attr) = @_;
    my $v = undef;

    if (ref($attr) eq 'ARRAY')
    {
	$v = $req->vsattr(@$attr);
	return $v->[0] if ref($v) eq 'ARRAY';
	return $v if defined $v;
	return '';
    }
    elsif (ref($attr) eq 'CODE')
    {
	return $attr->($self, $db, $rhash, $r_data, $req);
    }
    else
    {
	$v = $req->attr($attr);
	return $v if defined $v;
    }

    return $attr;
}

sub _do_tie
{
    my $self   = shift;
    my $db     = shift;
    my $rhash  = shift;
    my $r_data = shift;

    my $req    = $r_data->{request};

    $self->log(2, 'Storing data');
    $self->log(4, "self=$self rhash=$rhash r_data=$r_data");

    # Find the key to store
    my $key = join('', (map { $self->_k($db, $rhash, $r_data, $req, $_) }
			@{$self->key_attrs}));
    $self->log(4, 'Storing data using key "' . $key . '"');

    # Invoke hook, if available
    my $f = undef;
    if ($f = $self->pre_store_hook()
	and ref($f) eq 'CODE')
    {
	$self->log(3, 'Invoking pre_store_hook');
	# Note that the pre_store_hook could change object's config...
	$f->($self, $db, $rhash, $r_data, $req, $key);
    }
    else
    {
	$self->log(4, 'no pre_store_hook');
    }

    # Find what to store
    my @store = @{$self->store};
    $self->log(4, 'Storing the following items: ' . join(', ', @store));
    my %data = map { $_ => $r_data->{$_} } @store;

    if ($self->single)
    {
	$self->log(4, "Single Store $key: ", \%data);
	$rhash->{$key} = ($self->frozen ? freeze \%data : \%data);
    }
    else
    {
	while (my ($k, $v) = each %data)
	{
	    $self->log(4, "Non-Single Store $key->$k: $v");
	    $rhash->{$key}->{$k} = ($self->frozen ? freeze $v : $v)
	}
    }
    $self->log(4, "tuple contains: " . $rhash->{$key} // 'undef');

    # Force sync writes
    $db->db_sync if $db and $self->sync and $db->can('db_sync');

    if ($self->can('result') and exists $self->{result})
    {
	my $r = $self->result;
	$self->log(3, "Returning $r");
	return $r;
    }

    $self->log(3, "Returning CONTINUE by default");
    return NRS_SET_CONTINUE;
}

42;

__END__