File Coverage

blib/lib/Data/Radius/Constants.pm

Criterion	Covered	Total	%
statement	16	23	69.5
branch	0	8	0.0
condition			n/a
subroutine	6	7	85.7
pod	1	1	100.0
total	23	39	58.9

package Data::Radius::Constants;
use strict;
use warnings;

my %RFC_TYPES;

BEGIN {
    %RFC_TYPES = (
        # RADIUS Codes
        ACCESS_REQUEST      => 1,
        ACCESS_ACCEPT       => 2,
        ACCESS_REJECT       => 3,
        ACCOUNTING_REQUEST  => 4,
        ACCOUNTING_RESPONSE => 5,
        ACCOUNTING_STATUS   => 6,
        ACCESS_CHALLENGE    => 11,
        # unused - not exported
        STATUS_SERVER       => 12,
        STATUS_CLIENT       => 13,
        # rfc3576
        DISCONNECT_REQUEST  => 40,
        DISCONNECT_ACCEPT   => 41,
        DISCONNECT_REJECT   => 42,
        COA_REQUEST         => 43,
        COA_ACCEPT          => 44,
        COA_REJECT          => 45,
    );
}
use constant \%RFC_TYPES;

use Exporter qw(import);

our @EXPORT_OK = (keys (%RFC_TYPES), '%RADIUS_PACKET_TYPES', 'accepting_packet_type');
our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );

use Const::Fast;

# include all canonical type names and some aliases
const our %RADIUS_PACKET_TYPES => (
    %RFC_TYPES,
    # and aliases
    'COA' => COA_REQUEST,
    'DM' => DISCONNECT_REQUEST,
    'POD' => DISCONNECT_REQUEST,
    'ACCT' => ACCOUNTING_REQUEST,
    'AUTH' => ACCESS_REQUEST,
);

const my %accepting_types => (
    &ACCESS_REQUEST => {
        &ACCESS_ACCEPT => 1,
        &ACCESS_REJECT => 0,
        &ACCESS_CHALLENGE => undef, # this requires explicit handling
    },
    &ACCOUNTING_REQUEST => {
        &ACCOUNTING_RESPONSE => 1,
    },
    &ACCOUNTING_STATUS => {
        &ACCOUNTING_RESPONSE => 1,
    },
    &DISCONNECT_REQUEST => {
        &DISCONNECT_ACCEPT => 1,
        &DISCONNECT_REJECT => 0,
    },
    &COA_REQUEST => {
        &COA_ACCEPT => 1,
        &COA_REJECT => 0,
    },
);

sub accepting_packet_type {
    my ($req_type, $response_type) = @_;
    $req_type = $RADIUS_PACKET_TYPES{$req_type}
        if exists $RADIUS_PACKET_TYPES{$req_type};
    return undef unless exists $accepting_types{$req_type};
    my $atr = $accepting_types{$req_type};
    $response_type = $RADIUS_PACKET_TYPES{$response_type}
        if exists $RADIUS_PACKET_TYPES{$response_type};
    return undef unless exists $atr->{$response_type};
    return $atr->{$response_type};
}

1;

__END__