File Coverage

blib/lib/RADIUS/Packet.pm

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

package RADIUS::Packet;

use strict;
require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA       = qw(Exporter);
@EXPORT    = qw(auth_resp);
@EXPORT_OK = qw( );

$VERSION = '1.0';

use RADIUS::Dictionary;
use Socket;
use MD5;

sub new {
  my ($class, $dict, $data) = @_;
  my $self = { };
  bless $self, $class;
  $self->set_dict($dict) if defined($dict);
  $self->unpack($data) if defined($data);
  return $self;
}

# Set the dictionary
sub set_dict {
  my ($self, $dict) = @_;
  $self->{Dict} = $dict;
}

# Functions for accessing data structures
sub code          { $_[0]->{Code};          }
sub identifier    { $_[0]->{Identifier};    }
sub authenticator { $_[0]->{Authenticator}; }

sub set_code          { $_[0]->{Code} = $_[1];          }
sub set_identifier    { $_[0]->{Identifier} = $_[1];    }
sub set_authenticator { $_[0]->{Authenticator} = $_[1]; }

sub attributes { keys %{$_[0]->{Attributes}}; }
sub attr     { $_[0]->{Attributes}->{$_[1]}; }
sub set_attr { $_[0]->{Attributes}->{$_[1]} = $_[2]; }

# Decode the password
sub password {
  my ($self, $secret) = @_;
  my $lastround = $self->authenticator;
  my $pwdin = $self->attr("Password");
  my $pwdout;
  for (my $i = 0; $i < length($pwdin); $i += 16) {
    $pwdout .= substr($pwdin, $i, 16) ^ MD5->hash($secret . $lastround);
    $lastround = substr($pwdin, $i, 16);
  }
  $pwdout =~ s/\000*$//;
  return $pwdout;
}

# Set response authenticator in binary packet
sub auth_resp {
  my $new = $_[0];
  substr($new, 4, 16) = MD5->hash($_[0] . $_[1]);
  return $new;
}

# Utility functions for printing/debugging
sub pdef { defined $_[0] ? $_[0] : "UNDEF"; }
sub pclean {
  my $str = $_[0];
  $str =~ s/([\000-\037\177-\377])/<${\ord($1)}>/g;
  return $str;
}

sub dump {
  my $self = shift;
  print "*** DUMP OF RADIUS PACKET ($self)\n";
  print "Code:       ", pdef($self->{Code}), "\n";
  print "Identifier: ", pdef($self->{Identifier}), "\n";
  print "Authentic:  ", pclean(pdef($self->{Authenticator})), "\n";
  print "Attributes:\n";
  foreach my $attr ($self->attributes) {
    printf "  %-20s %s\n", $attr . ":" , pclean($self->attr($attr));
  }
  print "*** END DUMP\n";

}

sub pack {
  my $self = shift;
  my $hdrlen = 1 + 1 + 2 + 16;    # Size of packet header
  my $p_hdr  = "C C n a16 a*";    # Pack template for header
  my $p_attr = "C C a*";          # Pack template for attribute
  my %codes  = ('Access-Request'      => 1,  'Access-Accept'      => 2,
		'Access-Reject'       => 3,  'Accounting-Request' => 4,
		'Accounting-Response' => 5,  'Access-Challenge'   => 11,
		'Status-Server'       => 12, 'Status-Client'      => 13);
  my $attstr = "";                # To hold attribute structure
  # Define a hash of subroutine references to pack the various data types
  my %packer = ("string" => sub {
		  return $_[0];
		},
		"integer" => sub {
#		  return pack "N", $self->{Dict}->{val}->{$_[1]} ?
		  return pack "N", $self->{Dict}->attr_has_val($_[1]) ?
		    $self->{Dict}->val_num(@_[1, 0]) : $_[0];
		},
		"ipaddr" => sub {
		  return inet_aton($_[0]);
		},
		"time" => sub {
		  return pack "N", $_[0];
		});

  # Pack the attributes
  foreach my $attr ($self->attributes) {
    my $val = &{$packer{$self->{Dict}->attr_type($attr)}}($self->attr($attr),
			$self->{Dict}->attr_num($attr));
    $attstr .= pack $p_attr, $self->{Dict}->attr_num($attr), length($val)+2, $val;
  }
  # Prepend the header and return the complete binary packet
  return pack $p_hdr, $codes{$self->code}, $self->identifier,
                      length($attstr) + $hdrlen, $self->authenticator,
                      $attstr;
}

sub unpack {
  my ($self, $data) = @_;
  my $dict = $self->{Dict};
  my $p_hdr  = "C C n a16 a*";    # Pack template for header
  my $p_attr = "C C a*";          # Pack template for attribute
  my %rcodes = (1  => 'Access-Request',      2  => 'Access-Accept',
	        3  => 'Access-Reject',       4  => 'Accounting-Request',
	        5  => 'Accounting-Response', 11 => 'Access-Challenge',
		12 => 'Status-Server',       13 => 'Status-Client');

  # Decode the header
  my ($code, $id, $len, $auth, $attrdat) = unpack $p_hdr, $data;

  # Generate a skeleton data structure to be filled in
  $self->set_code($rcodes{$code});
  $self->set_identifier($id);
  $self->set_authenticator($auth);

  # Functions for the various data types
  my %unpacker = ("string" => sub {
		    return $_[0];
		  },
		  "integer" => sub {
		    return $dict->val_has_name($_[1]) ?
		      $dict->val_name($_[1], unpack("N", $_[0]))
			: unpack("N", $_[0]);
		  },
		  "ipaddr" => sub {
		    return inet_ntoa($_[0]);
		  },
		  "time" => sub {
		    return unpack "N", $_[0];
		  });

  # Unpack the attributes
  while (length($attrdat)) {
    my $length = unpack "x C", $attrdat;
    my ($type, $value) = unpack "C x a${\($length-2)}", $attrdat;
    my $val = &{$unpacker{$dict->attr_numtype($type)}}($value, $type);
    $self->set_attr($dict->attr_name($type), $val);
    substr($attrdat, 0, $length) = "";
  }
}

1;
__END__