package Net::Radius::Dictionary;

use strict;
use warnings;
use vars qw($VERSION);

# $Id: Dictionary.pm 80 2007-04-26 20:20:02Z lem $

$VERSION = '1.55';

sub new {
  my $class = shift;
  my $self = { 
      rvsattr	=> {},
      vsattr	=> {},
      vsaval	=> {},
      rvsaval	=> {},
      attr	=> {},
      rattr	=> {},
      val	=> {},
      rval	=> {},
      vendors	=> {},
      packet    => undef,  # Fall back to default
      rpacket   => undef,  # Fall back to default
  };
  bless $self, $class;
  $self->readfile($_) for @_; # Read all given dictionaries
  return $self;
}

sub readfile {
  my ($self, $filename) = @_;

  open DICT, "<$filename";

  while (defined(my $l = <DICT>)) {
    next if $l =~ /^\#/;
    next unless my @l = split /\s+/, $l;

    if ($l[0] =~ m/^vendor$/i) 
    {
	if (defined $l[1] and defined $l[2] and $l[2] =~ /^[xo0-9]+$/)
	{
	    if (substr($l[2],0,1) eq "0") { #allow hex or octal
		my $num = lc($l[2]);
		$num =~ s/^0b//;
		$l[2] = oct($num);
	    }   
	    $self->{vendors}->{$l[1]} = $l[2];
	}
	else
	{
	    warn "Garbled VENDOR line $l\n";
	}
    }
    elsif ($l[0] =~ m/^attribute$/i) 
    {
	if (@l == 4)
	{
	    $self->{attr}->{$l[1]}  = [@l[2,3]];
	    $self->{rattr}->{$l[2]} = [@l[1,3]];
	}
	elsif (@l == 5)		# VENDORATTR
	{
	    if (substr($l[2],0,1) eq "0") { #allow hex or octal
		my $num = lc($l[2]);
		$num =~ s/^0b//;
		$l[2] = oct($num);
	    }   
	    if (exists $self->{vendors}->{$l[4]})
	    {
		$self->{vsattr}->{$self->{vendors}->{$l[4]}}->{$l[1]} 
		= [@l[2, 3]];
		$self->{rvsattr}->{$self->{vendors}->{$l[4]}}->{$l[2]} 
		= [@l[1, 3]];
	    }
	    elsif ($l[4] =~ m/^\d+$/)
	    {
		$self->{vsattr}->{$l[4]}->{$l[1]}	= [@l[2, 3]];
		$self->{rvsattr}->{$l[4]}->{$l[2]}	= [@l[1, 3]];
	    }
	    else
	    {
		warn "Warning: Unknown vendor $l[4]\n";
	    }
	}
    }
    elsif ($l[0] =~ m/^value$/i) {
      if (exists $self->{attr}->{$l[1]}) {
	  $self->{val}->{$self->{attr}->{$l[1]}->[0]}->{$l[2]}  = $l[3];
	  $self->{rval}->{$self->{attr}->{$l[1]}->[0]}->{$l[3]} = $l[2];
      }
      else {
	  for my $v (keys %{$self->{vsattr}})
	  {
	      if (defined $self->{vsattr}->{$v}->{$l[1]})
	      {
		  $self->{vsaval}->{$v}->{$self->{vsattr}->{$v}
					      ->{$l[1]}->[0]}->{$l[2]} 
		  = $l[3];
		  $self->{rvsaval}->{$v}->{$self->{vsattr}->{$v}
					   ->{$l[1]}->[0]}->{$l[3]} 
		  = $l[2];
	      }
	  }
      }
    }
    elsif ($l[0] =~ m/^vendorattr$/i) {
	if (substr($l[3],0,1) eq "0") { #allow hex or octal
          my $num = lc($l[3]);
          $num =~ s/^0b//;
          $l[3] = oct($num);
	}   
	if (exists $self->{vendors}->{$l[1]})
	{
	    $self->{vsattr}->{$self->{vendors}->{$l[1]}}->{$l[2]} 
	    = [@l[3, 4]];
	    $self->{rvsattr}->{$self->{vendors}->{$l[1]}}->{$l[3]} 
	    = [@l[2, 4]];
	}
	elsif ($l[1] =~ m/^\d+$/)
	{
	    $self->{vsattr}->{$l[1]}->{$l[2]} = [@l[3, 4]];
	    $self->{rvsattr}->{$l[1]}->{$l[3]} = [@l[2, 4]];
	}
	else
	{
	    warn "Warning: Unknown vendor $l[1]\n";
	}
    }
    elsif ($l[0] =~ m/^vendorvalue$/i) {
	if (substr($l[4],0,1) eq "0") 
	{ #allow hex or octal 
          my $num = lc($l[4]);
          $num =~ s/^0b//;
          $l[4] = oct($num);
	}
	if (exists $self->{vendors}->{$l[1]})
	{
	    $self->{vsaval}->{$self->{vendors}->{$l[1]}}
	    ->{$self->{vsattr}->{$self->{vendors}->{$l[1]}}
	       ->{$l[2]}->[0]}->{$l[3]} = $l[4];
	    $self->{rvsaval}->{$self->{vendors}->{$l[1]}}
	    ->{$self->{vsattr}->{$self->{vendors}->{$l[1]}}
	       ->{$l[2]}->[0]}->{$l[4]} = $l[3];
	}
	elsif ($l[1] =~ m/^\d+$/)
	{
	    $self->{vsaval}->{$l[1]}->{$self->{vsattr}->{$l[1]}->{$l[2]}
				       ->[0]}->{$l[3]} = $l[4];
	    $self->{rvsaval}->{$l[1]}->{$self->{vsattr}->{$l[1]}->{$l[2]}
					->[0]}->{$l[4]} = $l[3];
	}
	else {
	    warn "Warning: $filename contains vendor value for ",
	    "unknown vendor attribute - ignored ",
	    "\"$l[1]\"\n  $l";
	}
    }
    elsif (lc($l[0]) eq 'packet') {
        my ($name, $value) = @l[1,2];
        $self->{packet}{$name} = $value;
        $self->{rpacket}{$value} = $name;
    }
    else {
      warn "Warning: Weird dictionary line: $l\n";
    }
  }
  close DICT;
}

# Accessors for standard attributes

sub vendor_num	 { $_[0]->{vendors}->{$_[1]};		}
sub attr_num     { $_[0]->{attr}->{$_[1]}->[0];		}
sub attr_type    { $_[0]->{attr}->{$_[1]}->[1];		}
sub attr_name    { $_[0]->{rattr}->{$_[1]}->[0];	}
sub attr_numtype { $_[0]->{rattr}->{$_[1]}->[1];	}
sub attr_has_val { $_[0]->{val}->{$_[1]};		}
sub val_has_name { $_[0]->{rval}->{$_[1]};		}
sub val_num      { $_[0]->{val}->{$_[1]}->{$_[2]};	}
sub val_name     { $_[0]->{rval}->{$_[1]}->{$_[2]};	}
sub val_tag      { $_[0]->{val}->{$_[1]}->{$_[3]}; 	}

# Accessors for Vendor-Specific Attributes

sub vsattr_num      { $_[0]->{vsattr}->{$_[1]}->{$_[2]}->[0];		}
sub vsattr_type     { $_[0]->{vsattr}->{$_[1]}->{$_[2]}->[1];		}
sub vsattr_name     { $_[0]->{rvsattr}->{$_[1]}->{$_[2]}->[0];		}
sub vsattr_numtype  { $_[0]->{rvsattr}->{$_[1]}->{$_[2]}->[1];		}
sub vsattr_has_val  { $_[0]->{vsaval}->{$_[1]}->{$_[2]};		}
sub vsaval_has_name { $_[0]->{rvsaval}->{$_[1]}->{$_[2]};		}
sub vsaval_has_tval { $_[0]->{vsaval}->{$_[1]}->{$_[2]}->[0];		}
sub vsaval_has_tag  { $_[0]->{vsaval}->{$_[1]}->{$_[2]}->[1];		}
sub vsaval_num      { $_[0]->{vsaval}->{$_[1]}->{$_[2]}->{$_[3]};	}
sub vsaval_name     { $_[0]->{rvsaval}->{$_[1]}->{$_[2]}->{$_[3]};	}

# Accessors for packet types. Fall-back to defaults if the case.

# Defaults taken from http://www.iana.org/assignments/radius-types
# as of Oct 21, 2006
my %default_packets = (
    'Access-Request'      => 1, # [RFC2865]
    'Access-Accept'       => 2, # [RFC2865]
    'Access-Reject'       => 3, # [RFC2865]
    'Accounting-Request'  => 4, # [RFC2865]
    'Accounting-Response' => 5, # [RFC2865]
    'Accounting-Status'   => 6, # [RFC2882] (now Interim Accounting)
    'Interim-Accounting'  => 6, # see previous note
    'Password-Request'    => 7, # [RFC2882]
    'Password-Ack'        => 8, # [RFC2882]
    'Password-Reject'     => 9, # [RFC2882]
    'Accounting-Message'  => 10, # [RFC2882]
    'Access-Challenge'    => 11, # [RFC2865]
    'Status-Server'       => 12, # (experimental) [RFC2865]
    'Status-Client'       => 13, # (experimental) [RFC2865]
    'Resource-Free-Request'   => 21, # [RFC2882]
    'Resource-Free-Response'  => 22, # [RFC2882]
    'Resource-Query-Request'  => 23, # [RFC2882]
    'Resource-Query-Response' => 24, # [RFC2882]
    'Alternate-Resource-Reclaim-Request' => 25, # [RFC2882]
    'NAS-Reboot-Request'  => 26, # [RFC2882]
    'NAS-Reboot-Response' => 27, # [RFC2882]
    # 28       Reserved
    'Next-Passcode'       => 29, # [RFC2882]
    'New-Pin'             => 30, # [RFC2882]
    'Terminate-Session'   => 31, # [RFC2882]
    'Password-Expired'    => 32, # [RFC2882]
    'Event-Request'       => 33, # [RFC2882]
    'Event-Response'      => 34, # [RFC2882]
    'Disconnect-Request'  => 40, # [RFC3575]
    'Disconnect-ACK'      => 41, # [RFC3575]
    'Disconnect-NAK'      => 42, # [RFC3575]
    'CoA-Request'         => 43, # [RFC3575]
    'CoA-ACK'             => 44, # [RFC3575]
    'CoA-NAK'             => 45, # [RFC3575]
    'IP-Address-Allocate' => 50, # [RFC2882]
    'IP-Address-Release'  => 51, # [RFC2882]
    # 250-253  Experimental Use
    # 254      Reserved
    # 255      Reserved  [RFC2865]
);

# Reverse defaults. Remember that code #6 has a double mapping, force
# to Interim-Accouting
my %default_rpackets 
    = map { $default_packets{$_} => $_ } keys %default_packets;
$default_rpackets{6} = 'Interim-Accounting';

# Get full hashes
sub packet_numbers { %{ $_[0]->{packet}  || \%default_packets  }  }
sub packet_names   { %{ $_[0]->{rpacket} || \%default_rpackets }; }

# Single resolution, I'm taking care of avoiding auto-vivification
sub packet_hasname {
    my $href = $_[0]->{packet} || \%default_packets;
    my $ok = exists $href->{$_[1]};
    return $ok unless wantarray;
    # return both answer and the resolution
    return ($ok, $ok ? $href->{$_[1]} : undef);
}

sub packet_hasnum {
    my $href = $_[0]->{rpacket} || \%default_rpackets;
    my $ok = exists $href->{$_[1]};
    return $ok unless wantarray;
    # return both answer and the resolution
    return ($ok, $ok ? $href->{$_[1]} : undef);
}

# Note: crossed, as it might not be immediately evident
sub packet_num  { ($_[0]->packet_hasname($_[1]))[1]; }
sub packet_name { ($_[0]->packet_hasnum($_[1]))[1];  }

1;
__END__

=encoding utf8

=head1 NAME

Net::Radius::Dictionary - RADIUS dictionary parser

=head1 SYNOPSIS

  use Net::Radius::Dictionary;

  my $dict = new Net::Radius::Dictionary "/etc/radius/dictionary";
  $dict->readfile("/some/other/file");
  my $num = $dict->attr_num('User-Name');
  my $name = $dict->attr_name(1);
  my $vsa_num = $dict->vsattr_num(9, 'cisco-avpair');
  my $vsa_name = $dict->vsattr_name(9, 1);

=head1 DESCRIPTION

This is a simple module that reads a RADIUS dictionary file and
parses it, allowing conversion between dictionary names and numbers.
Vendor-Specific attributes are supported in a way consistent to the
standards.

A few earlier versions of this module attempted to make dictionaries
case-insensitive. This proved to be a very bad decision. From this
version on, this tendency is reverted: Dictionaries and its contents
are to be case-sensitive to prevent random, hard to debug failures in
production code.

=head2 METHODS

=over

=item B<new($dict_file, ...)>

Returns a new instance of a Net::Radius::Dictionary object. This
object will have no attributes defined, as expected.

If given an (optional) list of filenames, it calls I<readfile> for you
for all of them, in the given order.

=item B<-E<gt>readfile($dict_file)>

Parses a dictionary file and learns the mappings to use. It can be
called multiple times for the same object. The result will be that new
entries will override older ones, thus you could load a default
dictionary and then have a smaller dictionary that override specific
entries.

=item B<-E<gt>vendor_num($vendorname)>

Return the vendor number for the given vendor name.

=item B<-E<gt>attr_num($attrname)>

Returns the number of the named attribute.

=item B<-E<gt>attr_type($attrname)>

Returns the type (I<string>, I<integer>, I<ipaddr>, or I<time>) of the
named attribute.

=item B<-E<gt>attr_name($attrnum)>

Returns the name of the attribute with the given number.

=item B<-E<gt>attr_numtype($attrnum)>

Returns the type of the attribute with the given number.

=item B<-E<gt>attr_has_val($attrnum)>

Returns a true or false value, depending on whether or not the numbered
attribute has any known value constants.

=item B<-E<gt>val_has_name($attrnum)>

Alternate (bad) name for I<attr_has_val>.

=item B<-E<gt>val_num($attrnum, $valname)>

Returns the number of the named value for the attribute number supplied.

=item B<-E<gt>val_name($attrnum, $valnumber)>

Returns the name of the numbered value for the attribute number supplied.

=back

There is an equivalent family of accessor methods for Vendor-Specific
attributes and its values. Those methods are identical to their standard
attributes counterparts with two exceptions. Their names have a
I<vsa> prepended to the accessor name and the first argument to each one
is the vendor code on which they apply.

=head1 CAVEATS

This module is mostly for the internal use of Net::Radius::Packet, and
may otherwise cause insanity and/or blindness if studied.

=head1 AUTHOR

Christopher Masto <chris@netmonger.net>, 
Luis E. Muñoz <luismunoz@cpan.org> contributed the VSA code.

=head1 SEE ALSO

Net::Radius::Packet

=cut