File Coverage

blib/lib/Net/Radius/Server/Set/Replace.pm

Criterion	Covered	Total	%
statement	15	15	100.0
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	20	20	100.0

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

package Net::Radius::Server::Set::Replace;

use 5.008;
use strict;
use warnings;

our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 75 $ =~ /\d+/g)[0]/1000 };

use Net::Radius::Server::Base qw/:set/;
use base qw/Net::Radius::Server::Set/;
__PACKAGE__->mk_accessors(qw/attr vsattr result/);

sub set_attr
{
    my $self = shift;
    my $r_data = shift;

    my $rep = $r_data->{response};
    my $spec = $self->attr || [];

    my $i = 0;
    while ($i < @$spec)
    {
	my $attr = $spec->[$i];
	my $cond = $spec->[$i + 1];
	my $newv = $spec->[$i + 2];

	if (not grep { $_ eq $attr } $rep->attributes)
	{
	    $self->log(4, "Skip $attr replacement");
	    $i += 3;
	    next;
	}

	my $curv = $rep->attr($attr);

	if (not ref($cond))
	{
	    if ($curv eq $cond)
	    {
		$self->log(4, "Replace $attr $curv with $newv (eq $cond)");
		$rep->set_attr($attr, $newv);
	    }
	    else
	    {
		$self->log(4,
			   "Don't replace $attr $curv with $newv (!= $cond)");
	    }
	}
	elsif (ref($cond) eq 'Regexp')
	{
	    if ($curv =~ m/$cond/)
	    {
		$self->log(4, "Replace $attr $curv with $newv (=~ $cond)");
		$rep->set_attr($attr, $newv);
	    }
	    else
	    {
		$self->log(4,
			   "Don't replace $attr $curv with $newv (!~ $cond)");
	    }
	}
	elsif (ref($cond) eq 'NetAddr::IP')
	{
	    my $ip = new NetAddr::IP $curv;
	    if ($ip and $cond->contains($ip))
	    {
		$self->log(4, "Replace $attr $curv with $newv ($ip)");
		$rep->set_attr($attr, $newv);
	    }
	    else
	    {
		$self->log(4,
			   "Don't replace $attr $curv with $newv "
			   . "(!contains $cond)");

	    }
	}
	else
	{
	    die $self->description . ": Don't know how to work with $cond\n";
	}

	$i += 3;
    }
}

sub set_vsattr
{
    my $self = shift;
    my $r_data = shift;

    my $rep = $r_data->{response};
    my $spec = $self->vsattr || [];

    my $i = 0;
    while ($i < @$spec)
    {
	my $vend = $spec->[$i];
	my $attr = $spec->[$i + 1];
	my $cond = $spec->[$i + 2];
	my $newv = $spec->[$i + 3];

	if (not grep { $_ eq $attr } $rep->vsattributes($vend))
	{
	    $self->log(4, "Skip $vend" . ".$attr replacement");
	    $i += 4;
	    next;
	}

	for my $curv (@{$rep->vsattr($vend, $attr) || []})
	{
	    if (not ref($cond))
	    {
		if ($curv eq $cond)
		{
		    $self->log(4, "Replace $vend" . ".$attr $curv with $newv"
			       . " (eq $cond)");
		    $curv = $newv;
		}
		else
		{
		    $self->log(4, "Don't replace $vend"
			       . ".$attr $curv with $newv (ne $cond)");
		}
	    }
	    elsif (ref($cond) eq 'Regexp')
	    {
		if ($curv =~ m/$cond/)
		{
		    $self->log(4, "Replace $vend" . ".$attr $curv with $newv"
			       . " (=~ $cond)");
		    $curv = $newv;
		}
		else
		{
		    $self->log(4, "Don't replace $vend"
			       . ".$attr $curv with $newv (=~ $cond)");
		}
	    }
	    elsif (ref($cond) eq 'NetAddr::IP')
	    {
		my $ip = new NetAddr::IP $curv;
		if ($ip and $cond->contains($ip))
		{
		    $self->log(4, "Replace $vend" . ".$attr $curv with $newv"
			       . " ($cond)");
		    $curv = $newv;
		}
		else
		{
		    $self->log(4, "Don't replace $vend"
			       . ".$attr $curv with $newv ($cond)");
		}

	    }
	    else
	    {
		die $self->description .
		    ": Don't know how to work with $cond\n";
	    }
	}
	$i += 4;
    }
}

42;

__END__