view release on metacpan or  search on metacpan

Radius.pm  view on Meta::CPAN

    return undef;
}

sub _decode_integer64 {
    my ( $self, $vendor, $id, $name, $value ) = @_;
    return unpack( 'Q>', $value );
}

sub _decode_avpair {
    my ( $self, $vendor, $id, $name, $value ) = @_;

    $value =~ s/^.*=//;
    return $value;
}

sub _decode_sublist {
    my ( $self, $vendor, $id, $name, $value ) = @_;

    # never got a chance to test it, since it seems that Digest attributes only come from clients

    my ( $subid, $subvalue, $sublength, @values );
    while ( length($value) ) {
        ( $subid, $sublength, $value ) = unpack( 'CCa*', $value );
        ( $subvalue, $value ) = unpack( 'a' . ( $sublength - 2 ) . ' a*', $value );
        push @values, "$dict_val{$name}{$subid}{name} = \"$subvalue\"";
    }

    return join( '; ', @values );
}

sub _decode_octets {
    my ( $self, $vendor, $id, $name, $value ) = @_;
    return '0x'.unpack("H*", $value);
}

my %decoder = (
    # RFC2865
    string  => \&_decode_string,
    integer => \&_decode_integer,
    ipaddr  => \&_decode_ipaddr,
    date    => \&_decode_integer,
    time    => \&_decode_integer,
    octets  => \&_decode_octets,
    # RFC3162
    ipv6addr   => \&_decode_ipv6addr,
    ipv6prefix => \&_decode_ipv6prefix,
    ifid       => \&_decode_ifid,
    # RFC6929
    integer64 => \&_decode_integer64,
    # internal
    avpair  => \&_decode_avpair,
    sublist => \&_decode_sublist,
);

sub _decode_value {
    my ( $self, $vendor, $id, $type, $name, $value, $has_tag ) = @_;

    if ( defined $type ) {
        if ( exists $decoder{$type} ) {
            my ($decoded, $tag) = $decoder{$type}->( $self, $vendor, $id, $name, $value, $has_tag );
            return wantarray ? ($decoded, $tag) : $decoded;
        }
        else {
            if ($debug) {
                print {*STDERR} "Unsupported type '$type' for attribute with id: '$id'.\n";
            }
        }
    }
    else {
        if ($debug) {
            print {*STDERR} "Unknown type for attribute with id: '$id'. Check RADIUS dictionaries!\n";
        }
    }

    return undef;
} ## end sub _decode_value

sub get_attributes {
    my $self = shift;
    my ( $vendor, $vendor_id, $name, $id, $length, $value, $type, $rawvalue, $tag, @a );
    my $attrs = $self->{attributes} // '';

    $self->set_error;

    while ( length($attrs) ) {
        ( $id, $length, $attrs ) = unpack( 'CCa*', $attrs );
        ( $rawvalue, $attrs ) = unpack( 'a' . ( $length - 2 ) . 'a*', $attrs );

        if ( $id == ATTR_VENDOR ) {
            ( $vendor_id, $id, $length, $rawvalue ) = unpack( 'NCCa*', $rawvalue );
            $vendor = $dict_vendor_id{$vendor_id}{name} // $vendor_id;
        }
        else {
            $vendor = NO_VENDOR;
        }

        my $r = $dict_id{ $vendor }{ $id } // {};

        $name  = $r->{name} // $id;
        $type  = $r->{type};

        ($value, $tag) = $self->_decode_value( $vendor, $id, $type, $name, $rawvalue, $r->{has_tag} );

        push(
            @a, {
                Name     => $tag ? $name . ':' . $tag : $name,
                AttrName => $name,
                Code     => $id,
                Value    => $value,
                RawValue => $rawvalue,
                Vendor   => $vendor,
                Tag      => $tag,
            }
        );
    } ## end while ( length($attrs) )

    return @a;
} ## end sub get_attributes

# returns vendor's ID or 'not defined' string for the attribute
sub vendorID ($) {