This file is indexed.

/usr/share/perl5/Authen/Radius.pm is in libauthen-radius-perl 0.24-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
#############################################################################
#                                                                           #
# Radius Client module for Perl 5                                           #
#                                                                           #
# Written by Carl Declerck <carl@miskatonic.inbe.net>, (c)1997              #
# All Rights Reserved. See the Perl Artistic License 2.0                    #
# for copying & usage policy.                                               #
#                                                                           #
# Modified by Olexander Kapitanenko, Andrew Zhilenko                        #
#             and the rest of PortaOne team (c) 2002-2013                   #
#             Current maintainer's contact: perl-radius@portaone.com        #
#                                                                           #
# See the file 'Changes' in the distribution archive.                       #
#                                                                           #
#############################################################################

package Authen::Radius;

use strict;
use FileHandle;
use IO::Socket;
use IO::Select;
use Digest::MD5;
use Data::Dumper;
use Time::HiRes qw(time);

use vars qw($VERSION @ISA @EXPORT);

require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(ACCESS_REQUEST ACCESS_ACCEPT ACCESS_REJECT ACCESS_CHALLENGE
			ACCOUNTING_REQUEST ACCOUNTING_RESPONSE ACCOUNTING_STATUS
			DISCONNECT_REQUEST DISCONNECT_ACCEPT DISCONNECT_REJECT
			COA_REQUEST COA_ACCEPT COA_REJECT COA_ACK COA_NAK);

$VERSION = '0.24';

my (%dict_id, %dict_name, %dict_val, %dict_vendor_id, %dict_vendor_name );
my ($request_id) = $$ & 0xff;	# probably better than starting from 0
my ($radius_error, $error_comment) = ('ENONE', '');
my $debug = 0;

use constant WIMAX_VENDOR => '24757';
use constant WIMAX_CONTINUATION_BIT => 0b10000000;

#
# we'll need to predefine these attr types so we can do simple password
# verification without having to load a dictionary
#

$dict_id{'not defined'}{1}{'type'} = 'string';	# set 'Username' attr type to string
$dict_id{'not defined'}{2}{'type'} = 'string';	# set 'Password' attr type to string
$dict_id{'not defined'}{4}{'type'} = 'ipaddr';	# set 'NAS-IP-Address' attr type to string

use constant ACCESS_REQUEST               => 1;
use constant ACCESS_ACCEPT                => 2;
use constant ACCESS_REJECT                => 3;
use constant ACCOUNTING_REQUEST           => 4;
use constant ACCOUNTING_RESPONSE          => 5;
use constant ACCOUNTING_STATUS            => 6;
use constant ACCESS_CHALLENGE             => 11;
use constant DISCONNECT_REQUEST           => 40;
use constant DISCONNECT_ACCEPT            => 41;
use constant DISCONNECT_REJECT            => 42;
use constant COA_REQUEST                  => 43;
use constant COA_ACCEPT                   => 44;
use constant COA_ACK                      => 44;
use constant COA_REJECT                   => 45;
use constant COA_NAK                      => 45;

my $HMAC_MD5_BLCKSZ = 64;
my $RFC3579_MSG_AUTH_ATTR_ID = 80;
my $RFC3579_MSG_AUTH_ATTR_LEN = 18;
my %SERVICES = ( 'radius' => 1812,
                 'radacct' => 1813,
                 'radius-acct' => 1813 );

sub new {
	my $class = shift;
	my %h = @_;
	my ($host, $port, $service);
	my $self = {};

	bless $self, $class;

	$self->set_error;
	$debug = $h{'Debug'};

    if (!$h{'Host'} && !$h{'NodeList'}) {
	    return $self->set_error('ENOHOST');
    }

	$service = $h{'Service'} ? $h{'Service'} : 'radius';
	my $serv_port = getservbyname($service, 'udp');
	if (!$serv_port && !exists($SERVICES{$service})) {
		return $self->set_error('EBADSERV');
	} elsif (!$serv_port) {
		$serv_port = $SERVICES{$service};
	}

	($host, $port) = split(/:/, $h{'Host'});
	if (!$port) {
		$port = $serv_port;
	}

	$self->{'timeout'} = $h{'TimeOut'} ? $h{'TimeOut'} : 5;
	$self->{'localaddr'} = $h{'LocalAddr'};
	$self->{'secret'} = $h{'Secret'};
	$self->{'message_auth'}  = $h{'Rfc3579MessageAuth'};
	print STDERR "Using Radius server $host:$port\n" if $debug;
	my %io_sock_args = (
				Type => SOCK_DGRAM,
				Proto => 'udp',
				Timeout => $self->{'timeout'},
				LocalAddr => $self->{'localaddr'},
	);
	if ($h{'NodeList'}) {
		# contains resolved node list in text representation
		$self->{'node_list_a'} = {};
		foreach my $node_a (@{$h{'NodeList'}}) {
			my ($n_host, $n_port) = split(/:/, $node_a);
			if (!$n_port) {
				$n_port = $serv_port;
			}
			my @hostinfo = gethostbyname($n_host);
			if (!scalar(@hostinfo)) {
				print STDERR "Can't resolve node hostname '$n_host': $! - skipping it!\n" if $debug;
				next;
			}
			print STDERR "Adding ".inet_ntoa($hostinfo[4]).':'.$n_port." to node list.\n" if $debug;
			# store split address to avoid additional parsing later
			$self->{'node_list_a'}->{inet_ntoa($hostinfo[4]).':'.$n_port} =
                    [inet_ntoa($hostinfo[4]), $n_port];
		}
		if (!scalar(keys %{$self->{'node_list_a'}})) {
			return $self->set_error('ESOCKETFAIL', 'Empty node list.');
		}
		if ($host) {
			my @hostinfo = gethostbyname($host);
			if (scalar(@hostinfo)) {
				my $act_addr_a = inet_ntoa($hostinfo[4]).':'.$port;
				if (exists($self->{'node_list_a'}->{$act_addr_a})) {
					$self->{'node_addr_a'} = $act_addr_a;
				} else {
					print STDERR "'$host' doesn't exist in node list - ignoring it!\n" if $debug;
				}
			} else {
				print STDERR "Can't resolve active node hostname '$host': $! - ignoring it!\n" if $debug;
			}
		}
	} else {
		my @hostinfo = gethostbyname($host);
		if (!scalar(@hostinfo)) {
			return $self->set_error('ESOCKETFAIL', "Can't resolve hostname '".$host."'.");
		}
		$self->{'node_addr_a'} = inet_ntoa($hostinfo[4]).':'.$port;
	}
	if ($host) {
		$io_sock_args{'PeerAddr'} = $host;
		$io_sock_args{'PeerPort'} = $port;
		$self->{'sock'} = IO::Socket::INET->new(%io_sock_args)
			or return $self->set_error('ESOCKETFAIL', $@);
	}
	$self;
}

sub send_packet {
	my ($self, $type, $retransmit) = @_;
	my ($data);
	my $length = 20 + length($self->{'attributes'});

	if (!$retransmit) {
		$request_id = ($request_id + 1) & 0xff;
	}
	$self->set_error;
	if ($type == ACCOUNTING_REQUEST || $type == DISCONNECT_REQUEST
		|| $type == COA_REQUEST) {
		$self->{'authenticator'} = "\0" x 16;
		$self->{'authenticator'} =
		$self->calc_authenticator($type, $request_id, $length)
	} else {
		$self->gen_authenticator unless defined $self->{'authenticator'};
	}

	if ($self->{'message_auth'} && ($type == ACCESS_REQUEST)) {
		$length += $RFC3579_MSG_AUTH_ATTR_LEN;
		$data = pack('C C n', $type, $request_id, $length)
				. $self->{'authenticator'}
				. $self->{'attributes'}
				. pack('C C', $RFC3579_MSG_AUTH_ATTR_ID, $RFC3579_MSG_AUTH_ATTR_LEN)
				. "\0" x ($RFC3579_MSG_AUTH_ATTR_LEN - 2);

		my $msg_authenticator = $self->hmac_md5($data, $self->{'secret'});
		$data = pack('C C n', $type, $request_id, $length)
				. $self->{'authenticator'}
				. $self->{'attributes'}
				. pack('C C', $RFC3579_MSG_AUTH_ATTR_ID, $RFC3579_MSG_AUTH_ATTR_LEN)
				. $msg_authenticator;
		if ($debug) {
			print STDERR "RFC3579 Message-Authenticator: "._ascii_to_hex($msg_authenticator).
					" was added to request.\n";
		}
	} else {
		$data = pack('C C n', $type, $request_id, $length)
				. $self->{'authenticator'} . $self->{'attributes'};
	}

	if ($debug) {
		print STDERR "Sending request:\n";
		print STDERR Dumper($data);
	}
	my $res;
	if (!defined($self->{'node_list_a'})) {
		if ($debug) { print STDERR 'Sending request to: '.$self->{'node_addr_a'}."\n"; }
		$res = $self->{'sock'}->send($data) || $self->set_error('ESENDFAIL', $!);
	} else {
		if (!$retransmit && defined($self->{'sock'})) {
			if ($debug) { print STDERR 'Sending request to active node: '.$self->{'node_addr_a'}."\n"; }
			$res = $self->{'sock'}->send($data) || $self->set_error('ESENDFAIL', $!);
		} else {
			if ($debug) { print STDERR "ReSending request to all cluster nodes.\n"; }
			$self->{'sock'} = undef;
			$self->{'sock_list'} = [];
			my %io_sock_args = (
						Type => SOCK_DGRAM,
						Proto => 'udp',
						Timeout => $self->{'timeout'},
						LocalAddr => $self->{'localaddr'},
			);
			foreach my $node (keys %{$self->{'node_list_a'}}) {
				if ($debug) { print STDERR 'Sending request to: '.$node."\n"; }
				$io_sock_args{'PeerAddr'} = $self->{'node_list_a'}->{$node}->[0];
				$io_sock_args{'PeerPort'} = $self->{'node_list_a'}->{$node}->[1];
				my $new_sock = IO::Socket::INET->new(%io_sock_args)
					or return $self->set_error('ESOCKETFAIL', $@);
				$res = $new_sock->send($data) || $self->set_error('ESENDFAIL', $!);
				if ($res) {
					push @{$self->{'sock_list'}}, $new_sock;
				}
				$res ||= $res;
			}
		}
	}
    return $res;
}

sub recv_packet {
	my ($self, $detect_bad_id) = @_;
	my ($data, $type, $id, $length, $auth, $sh, $resp_attributes);

	$self->set_error;

	if (defined($self->{'sock_list'}) && scalar(@{$self->{'sock_list'}})) {
		$sh = IO::Select->new(@{$self->{'sock_list'}}) or return $self->set_error('ESELECTFAIL');
	} elsif (defined($self->{'sock'})) {
		$sh = IO::Select->new($self->{'sock'}) or return $self->set_error('ESELECTFAIL');
	} else {
		return $self->set_error('ESELECTFAIL');
	}
	my $timeout = $self->{'timeout'};
	my @ready;
	my $from_addr_n;
	my ($start_time, $end_time);
	while ($timeout > 0){
		$start_time = time();
		@ready = $sh->can_read($timeout) or return $self->set_error('ETIMEOUT', $!);
		$end_time = time();
		$timeout -= $end_time - $start_time;
		$from_addr_n = $ready[0]->recv($data, 65536);
		if (defined($from_addr_n)) {
			last;
		}
		if (!defined($from_addr_n) && !defined($self->{'sock_list'})) {
			return $self->set_error('ERECVFAIL', $!);
		}elsif ($debug) {
			print STDERR "Received error/event from one peer:".$!."\n";
		}
	}

	if ($debug) {
		print STDERR "Received response:\n";
		print STDERR Dumper($data);
	}

	if (defined($self->{'sock_list'})) {
		# the sending attempt was 'broadcast' to all cluster nodes
		# switching to single active node
		$self->{'sock'} = $ready[0];
		$self->{'sock_list'} = undef;
		my ($node_port, $node_iaddr) = sockaddr_in($from_addr_n);
		$self->{'node_addr_a'} = inet_ntoa($node_iaddr).':'.$node_port;
		if ($debug) {  print STDERR "Registering new active peeer:".$self->{'node_addr_a'}."\n"; }
	}

	($type, $id, $length, $auth, $resp_attributes ) = unpack('C C n a16 a*', $data);
	if ($detect_bad_id && defined($id) && ($id != $request_id) ) {
		return $self->set_error('EBADID');
	}

	if ($auth ne $self->calc_authenticator($type, $id, $length, $resp_attributes)) {
		return $self->set_error('EBADAUTH');
	}
	# rewrite attributes only in case of a valid response
	$self->{'attributes'} = $resp_attributes;
	my $rfc3579_msg_auth;
	foreach my $a ($self->get_attributes()) {
		if ($a->{Code} == $RFC3579_MSG_AUTH_ATTR_ID) {
			$rfc3579_msg_auth = $a->{Value};
			last;
		}
	}
	if (defined($rfc3579_msg_auth)) {
		$self->replace_attr_value($RFC3579_MSG_AUTH_ATTR_ID,
				"\0" x ($RFC3579_MSG_AUTH_ATTR_LEN - 2));
		my $hmac_data = pack('C C n', $type, $id, $length)
						. $self->{'authenticator'}
						. $self->{'attributes'};
		my $calc_hmac = $self->hmac_md5($hmac_data, $self->{'secret'});
		if ($calc_hmac ne $rfc3579_msg_auth) {
			if ($debug) {
				print STDERR "Received response with INVALID RFC3579 Message-Authenticator.\n";
				print STDERR 'Received   '._ascii_to_hex($rfc3579_msg_auth)."\n";
				print STDERR 'Calculated '._ascii_to_hex($calc_hmac)."\n";
			}
			return $self->set_error('EBADAUTH');
		} elsif ($debug) {
			print STDERR "Received response with VALID RFC3579 Message-Authenticator.\n";
		}
	}

	return $type;
}

sub check_pwd {
	my ($self, $name, $pwd, $nas) = @_;

	$nas = eval { $self->{'sock'}->sockhost() } unless defined($nas);
	$self->clear_attributes;
	$self->add_attributes (
		{ Name => 1, Value => $name, Type => 'string' },
		{ Name => 2, Value => $pwd, Type => 'string' },
		{ Name => 4, Value => $nas || '127.0.0.1', Type => 'ipaddr' }
	);

	$self->send_packet(ACCESS_REQUEST);
	my $rcv = $self->recv_packet();
	return (defined($rcv) and $rcv == ACCESS_ACCEPT);
}

sub clear_attributes {
	my ($self) = @_;

	$self->set_error;

	delete $self->{'attributes'};
    delete $self->{'authenticator'};

	1;
}

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

	$self->set_error;
	my $vendor_specific = $dict_name{'Vendor-Specific'}{'id'};

	while (length($attrs)) {
		($id, $length, $attrs) = unpack('C C a*', $attrs);
		($rawvalue, $attrs) = unpack('a' . ($length - 2) . ' a*', $attrs);
		if ( defined($vendor_specific) and $id == $vendor_specific ) {
			($vendor_id, $id, $length, $rawvalue) = unpack('N C C a*', $rawvalue);
			$vendor = defined $dict_vendor_id{$vendor_id}{'name'} ? $dict_vendor_id{$vendor_id}{'name'} : $vendor_id;
		} else {
			$vendor = 'not defined';
		}
		$name = defined $dict_id{$vendor}{$id}{'name'} ? $dict_id{$vendor}{$id}{'name'} : $id;
		$type = $dict_id{$vendor}{$id}{'type'} || '';
		$value = undef;
		if ($type eq "string") {
			if ($id == 2 && $vendor eq 'not defined' ) {
				$value = '<encrypted>';
			} else {
				$value = $rawvalue;
			}
		} elsif ($type eq "integer") {
			$value = unpack('N', $rawvalue);
		} elsif ($type eq "ipaddr") {
			$value = inet_ntoa($rawvalue);
		} elsif ($type eq "avpair") {
			$value = $rawvalue;
			$value =~ s/^.*=//;
		} elsif ($type eq 'sublist') {
			# never got a chance to test it, since it seems that Digest attributes only come from clients
			my ($subid, $subvalue, $sublength, @values);
			$value = ''; my $subrawvalue = $rawvalue;
			while (length($subrawvalue)) {
				($subid, $sublength, $subrawvalue) = unpack('C C a*', $subrawvalue);
				($subvalue, $subrawvalue) = unpack('a' . ($sublength - 2) . ' a*', $subrawvalue);
				my $subname = $dict_val{$name}->{$subid}->{'name'};
				push @values, "$subname = \"$subvalue\"";
			}
			$value = join("; ", @values);
		} elsif ($type ne '') {
			print STDERR "Unsupported type '$type' for attribute with id:'$id'.\n" if $debug;
		} else {
			print STDERR "Unknown type for attribute with id:'$id'. Check Radius dictionaries!\n" if $debug;
		}

		if (defined $value) {
			$value = $dict_val{$name}{$value}{'name'} if defined $dict_val{$name}{$value};
		}

		push (@a, {	'Name' => $name,
					'Code' => $id,
					'Value' => $value,
					'RawValue' => $rawvalue,
					'Vendor' => $vendor }
		);
	}

	return @a;
}
# it used to be
# $vendor = defined $a->{'Vendor'} ?
#    ( defined $dict_vendor_name{ $a->{'Vendor'} }{'id'} ? $dict_vendor_name{ $a->{'Vendor'} }{'id'} : int($a->{'Vendor'}) )
#    : ( defined $dict_name{$a->{'Name'}}{'vendor'}
#	? $dict_vendor_name{ $dict_name{$a->{'Name'}}{'vendor'} }{'id'} : 'not defined' );

sub vendorID ($) {
    my ($attr) = @_;
    if (defined $attr->{'Vendor'}) {
	return defined $dict_vendor_name{ $attr->{'Vendor'} }{'id'} ? $dict_vendor_name{ $attr->{'Vendor'} }{'id'} : int($attr->{'Vendor'});
    } else {
	# look up vendor by attribute name
	my $vendor_name = $dict_name{$attr->{'Name'}}{'vendor'};
	my $vendor_id = defined ($dict_vendor_name{$vendor_name}{'id'}) ?
	    $dict_vendor_name{$vendor_name}{'id'} : 'not defined';
	return $vendor_id;
    }
}

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

    my ($new_value, $enc_value);
    if (defined $dict_val{$name}{$value}) {
        $enc_value = $dict_val{$name}{$value}{'id'};
    } else {
        $enc_value = $value;
    }
    $type = '' unless defined $type;
    if ($type eq "string") {
        $new_value = $value;
        if ($id == 2 && $vendor eq 'not defined' ) {
            $self->gen_authenticator();
            $new_value = $self->encrypt_pwd($value);
        }
        $new_value = substr($new_value, 0, 253);
        #       if ($vendor eq WIMAX_VENDOR) {
        # add the "continuation" byte
        # but no support for attribute splitting for now
        #           $value = pack('C', 0). substr($value, 0, 246);
        #       }
    } elsif ($type eq "integer") {
        $new_value = pack('N', int($enc_value));
    } elsif ($type eq "byte") {
        $new_value = pack('C', int($enc_value));
    } elsif ($type eq "short") {
        $new_value = pack('S', int($enc_value));
    } elsif ($type eq "signed") {
        # there should be something else, since it is signed
        $new_value = pack('N', $value);
    } elsif ($type eq "ipaddr") {
        $new_value = inet_aton($value);
    } elsif ($type eq "avpair") {
        $new_value = $name.'='.$value;
        $new_value = substr($new_value, 0, 253);
# WiMAX
    } elsif ($type eq "combo-ip") {
        if ($value =~ m/^\d+\.\d+\.\d+.\d+/) {
            # IPv4 address
            $new_value = inet_aton($value);
        } else {
            # currently unsupported, use IPv4
            $new_value = inet_aton($value);
        }
    } elsif ($type eq "octets") {
        $new_value = '';
        foreach my $c (split('', $value)) {
            $new_value .= pack('C',ord($c));
        }
    } elsif ($type eq 'tlv' and ref($value)) {
        $new_value = '';
        foreach my $sub_attr (sort { $a->{'TLV_ID'} <=> $b->{'TLV_ID'} } @{$value}) {
            my $sub_attr_name = $sub_attr->{'Name'};
            my $sub_attr_type = defined $sub_attr->{'Type'} ? $sub_attr->{'Type'} : $dict_name{$sub_attr_name}{'type'};
            my $sub_attr_id = defined $dict_name{$sub_attr_name}{'id'} ? $dict_name{$sub_attr_name}{'id'} : int($sub_attr_name);
            my $sub_value = $self->encodeValue($vendor, $sub_attr_id, $sub_attr_type, $sub_attr->{'Name'}, $sub_attr->{'Value'});

            if (defined($sub_value)) {
                $new_value .= pack('C C', $sub_attr_id, length($sub_value)+2).$sub_value;
            }
        }
    } elsif ($type eq 'sublist') {
        # Digest attributes look like:
        # Digest-Attributes                = 'Method = "REGISTER"'
        my $digest = $value;
        my @pairs;
        if (ref($digest)) {
            next unless ref($digest) eq 'HASH';
            foreach my $key (keys %{$digest}) {
                push @pairs, [ $key => $digest->{$key} ];
            }
        } else {
            # string
            foreach my $z (split(/\"\; /, $digest)) {
                my ($subname, $subvalue) = split(/\s+=\s+\"/, $z, 2);
                $subvalue =~ s/\"$//;
                push @pairs, [ $subname => $subvalue ];
            }
        }
        $new_value = '';
        foreach my $da (@pairs) {
            my ($subname, $subvalue) = @{$da};
            my $subid = $dict_val{$id}->{$subname}->{'id'};
            next unless defined($subid);
            $new_value .= pack('C C', $subid, length($subvalue) + 2) . $subvalue;
        }
    } else {
        return;
    }
    return $new_value;
}


sub add_attributes {
	my ($self, @attr) = @_;
	my ($a, $vendor, $id, $type, $value);
	my @a = ();
	$self->set_error;

	# scan for WiMAX TLV
	my %request_tlvs;
	for my $attr (@attr) {
	    my $attr_name = $attr->{'Name'};
	    $id = defined $dict_name{$attr_name}{'id'} ? $dict_name{$attr_name}{'id'} : int($attr_name);
	    $vendor = vendorID($attr);
	    if (exists($dict_name{$attr_name}{'tlv'})) {
		# this is a TLV attribute
		my $tlv = $dict_name{$attr_name}{'tlv'};
		# insert TLV type so we can order them by type inside of the container attribute
		$attr->{'TLV_ID'} = $id;

		unless (exists($request_tlvs{$tlv})) {
		    # this is a first attribute of this TLV in the request
		    my $new_attr = {
			Name => $tlv, Type => 'tlv',
			Value => [ $attr ]
		    };
		    $request_tlvs{$tlv} = $new_attr;
		    push @a, $new_attr;
		} else {
		    my $tlv_list = $request_tlvs{$tlv}->{'Value'};
		    next unless ref($tlv_list); # should not happen
		    push @{$tlv_list}, $attr;
		}
	    } else {
		# normal attribute, just copy over
		push @a, $attr;
	    }
	}

	for $a (@a) {
		$id = defined $dict_name{$a->{'Name'}}{'id'} ? $dict_name{$a->{'Name'}}{'id'} : int($a->{'Name'});
		$type = defined $a->{'Type'} ? $a->{'Type'} : $dict_name{$a->{'Name'}}{'type'};
		$vendor = vendorID($a);

		if ($vendor eq WIMAX_VENDOR) {
		    # WiMAX uses non-standard VSAs - include the continuation byte
		}

		unless (defined($value = $self->encodeValue($vendor, $id, $type, $a->{'Name'}, $a->{'Value'}))) {
			print STDERR "Unable to encode attribute $a->{Name} ($id, $type, $vendor) with value '$a->{Value}'\n" if $debug;
		    next;
		}
		print STDERR "Adding attribute $a->{Name} ($id, $type, $vendor) with value '$a->{Value}'\n" if $debug;
		if ( $vendor eq 'not defined' ) {
			$self->{'attributes'} .= pack('C C', $id, length($value) + 2) . $value;
		} else {
		    # VSA
		    # pack vendor-ID + vendor-type + vendor-length
		    if ($vendor eq WIMAX_VENDOR) {
			# add continuation byte
			$value = pack('N C C C', $vendor, $id, length($value) + 3, 0) . $value;
		    } else {
			$value = pack('N C C', $vendor, $id, length($value) + 2) . $value;
		    }
		    # add the normal RADIUS attribute header: type + length
		    $self->{'attributes'} .= pack('C C', $dict_name{'Vendor-Specific'}{'id'}, length($value) + 2) . $value;
		}
	}
	return 1;
}

sub replace_attr_value {
	my ($self, $id, $value) = @_;
	my $length = length($self->{'attributes'});
	my $done = 0;
	my $cur_pos = 0;
	while ($cur_pos < $length) {
		my ($cur_id, $cur_len) = unpack('C C', substr($self->{'attributes'}, $cur_pos, 2));
		if ($cur_id == $id) {
			if (length($value) != ($cur_len - 2)) {
				if ($debug) {
					print STDERR "Trying to replace attribute ($id) with value which has different length\n";
				}
				last;
			}
			substr($self->{'attributes'}, $cur_pos + 2, $cur_len - 2, $value);
			$done = 1;
			last;
		}
		$cur_pos += $cur_len;
	}
	return $done;
}

sub calc_authenticator {
	my ($self, $type, $id, $length, $attributes) = @_;
	my ($hdr, $ct);

	$self->set_error;

	$hdr = pack('C C n', $type, $id, $length);
	$ct = Digest::MD5->new;
	$ct->add ($hdr, $self->{'authenticator'},
				(defined($attributes)) ? $attributes : $self->{'attributes'},
				$self->{'secret'});
	$ct->digest();
}

sub gen_authenticator {
	my ($self) = @_;
	my ($ct);

	$self->set_error;
	sub rint { int rand(2 ** 32 - 1) };
	$self->{'authenticator'} =
		pack "L4", rint(), rint(), rint(), rint();
}

sub encrypt_pwd {
	my ($self, $pwd) = @_;
	my ($i, $ct, @pwdp, @encrypted);

	$self->set_error;
	$ct = Digest::MD5->new();

	my $non_16 = length($pwd) % 16;
	$pwd .= "\0" x (16 - $non_16) if $non_16;
	@pwdp = unpack('a16' x (length($pwd) / 16), $pwd);
	for $i (0..$#pwdp) {
		my $authent = $i == 0 ? $self->{'authenticator'} : $encrypted[$i - 1];
		$ct->add($self->{'secret'},  $authent);
		$encrypted[$i] = $pwdp[$i] ^ $ct->digest();
	}
	return join('',@encrypted);
}
use vars qw(%included_files);

sub load_dictionary {
	shift;
	my ($file) = @_;
	my ($fh, $cmd, $name, $id, $type, $vendor, $dict_def_vendor, $tlv);

	$dict_def_vendor = 'not defined';
	undef($tlv);

	unless ($file) {
		$file = "/etc/raddb/dictionary";
	}
	# prevent infinite loop in the include files
	return undef if exists($included_files{$file});
	$included_files{$file} = 1;
	$fh = new FileHandle($file) or die "Can't open dictionary '$file' ($!)\n";
	print STDERR "Loading dictionary $file\n" if $debug;

	while (<$fh>) {
		chomp;
		($cmd, $name, $id, $type, $vendor) = split(/\s+/);
		next if (!$cmd || $cmd =~ /^#/);
		$cmd = lc($cmd);
		if ($cmd eq 'attribute') {
			if ( !$vendor ) {
			    if ( defined($dict_def_vendor)) {
				# Vendor was previously defined via BEGIN-VENDOR
				$vendor = $dict_def_vendor;
			    } else {
				$vendor = 'not defined';
			    }
			}

			$dict_name{$name}{'id'} = $id;
			$dict_name{$name}{'vendor'} = $vendor if $vendor;
			$dict_name{$name}{'type'} = $type;

			if (defined($tlv)) {
			    # inside of a TLV definition
			    $dict_id{$vendor}{$id}{'tlv'} = $tlv;
			    $dict_name{$name}{'tlv'} = $tlv;
			    # IDs of TLVs are only unique within the master attribute, not in the dictionary
			    # so we have to use a composite key
			    $dict_id{$vendor}{$tlv.'/'.$id}{'name'} = $name;
			    $dict_id{$vendor}{$tlv.'/'.$id}{'type'} = $type;
			} else {
			    $dict_id{$vendor}{$id}{'name'} = $name;
			    $dict_id{$vendor}{$id}{'type'} = $type;
			}
		} elsif ($cmd eq 'value') {
			next unless exists($dict_name{$name});
			$dict_val{$name}->{$type}->{'name'} = $id;
			$dict_val{$name}->{$id}->{'id'} = $type;
		} elsif ($cmd eq 'vendor') {
			$dict_vendor_name{$name}{'id'} = $id;
			$dict_vendor_id{$id}{'name'} = $name;
		} elsif ($cmd eq 'begin-vendor') {
			$dict_def_vendor = $name;
		} elsif ($cmd eq 'end-vendor') {
		    $dict_def_vendor = 'not defined';
		} elsif ($cmd eq 'begin-tlv') {
		    # FreeRADIUS dictionary syntax for defining WiMAX TLV
		    if (exists($dict_name{$name}) and $dict_name{$name}{'type'} eq 'tlv') {
			# This name was previously defined as an attribute with TLV type
			$tlv = $name;
		    }
		} elsif ($cmd eq 'end-tlv') {
		    undef($tlv);
		} elsif ($cmd eq '$include') {
			my @path = split("/", $file);
			pop @path; # remove the filename at the end
			my $path = ( $name =~ /^\// ) ? $name : join("/", @path, $name);
			load_dictionary('', $path);
		}
	}
	$fh->close;
#	print Dumper(\%dict_name);
	1;
}

sub set_timeout {
	my ($self, $timeout) = @_;

	$self->{'timeout'} = $timeout;
	$self->{'sock'}->timeout($timeout) if (defined $self->{'sock'});
	if (defined $self->{'sock_list'}) {
		foreach my $sock (@{$self->{'sock_list'}}) {
			$sock->timeout($timeout);
		}
	}

	1;
}

sub set_error {
	my ($self, $error, $comment) = @_;
	$@ = undef;
	$radius_error = $self->{'error'} = (defined($error) ? $error : 'ENONE');
	$error_comment = $self->{'error_comment'} = (defined($comment) ? $comment : '');
	undef;
}

sub get_error {
	my ($self) = @_;

	if (!ref($self)) {
		return $radius_error;
	} else {
		return $self->{'error'};
	}
}

sub strerror {
	my ($self, $error) = @_;

	my %errors = (
		'ENONE',	'none',
		'ESELECTFAIL',	'select creation failed',
		'ETIMEOUT',	'timed out waiting for packet',
		'ESOCKETFAIL',	'socket creation failed',
		'ENOHOST',	'no host specified',
		'EBADAUTH',	'bad response authenticator',
		'ESENDFAIL',	'send failed',
		'ERECVFAIL',	'receive failed',
		'EBADSERV',	'unrecognized service',
		'EBADID',	'response to unknown request'
	);

	if (!ref($self)) {
	    return $errors{$radius_error};
	}
	return $errors{ (defined($error) ? $error : $self->{'error'} ) };
}

sub error_comment {
	my ($self) = @_;

	if (!ref($self)) {
		return $error_comment;
	} else {
		return $self->{'error_comment'};
	}
}

sub get_active_node {
	my ($self) = @_;
	return $self->{'node_addr_a'};
}

sub hmac_md5 {
	my ($self, $data, $key) = @_;
	my $ct = Digest::MD5->new;

	if (length($key) > $HMAC_MD5_BLCKSZ) {
		$ct->add($key);
		$key = $ct->digest();
	}
	my $ipad = $key ^ ("\x36" x $HMAC_MD5_BLCKSZ);
	my $opad = $key ^ ("\x5c" x $HMAC_MD5_BLCKSZ);
	$ct->reset();
	$ct->add($ipad, $data);
	my $digest1 = $ct->digest();
	$ct->reset();
	$ct->add($opad, $digest1);
	return $ct->digest();
}

sub _ascii_to_hex {
	my  ($string) = @_;
	my $hex_res = '';
	foreach my $cur_chr (unpack('C*',$string)) {
		$hex_res .= sprintf("%02X ", $cur_chr);
	}
	return $hex_res;
}


1;
__END__

=head1 NAME

Authen::Radius - provide simple Radius client facilities

=head1 SYNOPSIS

  use Authen::Radius;

  $r = new Authen::Radius(Host => 'myserver', Secret => 'mysecret');
  print "auth result=", $r->check_pwd('myname', 'mypwd'), "\n";

  $r = new Authen::Radius(Host => 'myserver', Secret => 'mysecret');
  Authen::Radius->load_dictionary();
  $r->add_attributes (
  		{ Name => 'User-Name', Value => 'myname' },
  		{ Name => 'Password', Value => 'mypwd' },
# RFC 2865 http://www.ietf.org/rfc/rfc2865.txt calls this attribute
# User-Password. Check your local RADIUS dictionary to find
# out which name is used on your system
#  		{ Name => 'User-Password', Value => 'mypwd' },
  		{ Name => 'h323-return-code', Value => '0' }, # Cisco AV pair
		{ Name => 'Digest-Attributes', Value => { Method => 'REGISTER' } }
  );
  $r->send_packet(ACCESS_REQUEST) and $type = $r->recv_packet();
  print "server response type = $type\n";
  for $a ($r->get_attributes()) {
  	print "attr: name=$a->{'Name'} value=$a->{'Value'}\n";
  }

=head1  DESCRIPTION

The C<Authen::Radius> module provides a simple class that allows you to
send/receive Radius requests/responses to/from a Radius server.

=head1 CONSTRUCTOR

=over 4

=item new ( Host => HOST, Secret => SECRET [, TimeOut => TIMEOUT]
	[,Service => SERVICE] [, Debug => Bool] [, LocalAddr => hostname[:port]]
	[,Rfc3579MessageAuth => Bool] [,NodeList= NodeListArrayRef])

Creates & returns a blessed reference to a Radius object, or undef on
failure.  Error status may be retrieved with C<Authen::Radius::get_error>
(errorcode) or C<Authen::Radius::strerror> (verbose error string).

The default C<Service> is C<radius>, the alternative is C<radius-acct>.
If you do not specify port in the C<Host> as a C<hostname:port>, then port
specified in your F</etc/services> will be used. If there is nothing
there, and you did not specify port either then default is 1812 for
C<radius> and 1813 for C<radius-acct>.

Optional parameter C<Debug> with a Perl "true" value turns on debugging
(verbose mode).

Optional parameter C<LocalAddr> may contain local IP/host bind address from
which RADIUS packets are sent.

Optional parameter C<Rfc3579MessageAuth> with a Perl "true" value turns on generating
of Message-Authenticator for Access-Request (RFC3579, section 3.2).

Optional parameter C<NodeList> may contain a Perl reference to an array, containing a list of
Radius Cluster nodes. Each nodes in the list can be specified using a hostname or IP (with an optional
port number), i.e. 'radius1.mytel.com' or 'radius.myhost.com:1812'. Radius Cluster contains a set of Radius
servers, at any given moment of time only one server is considered to be "active"
(so requests are send to this server).
How the active node is determined? Initially in addition to the C<NodeList>
parameter you may supply the C<Host> parameter and specify which server should
become the first active node. If this parameter is absent, or the current
active node does not reply anymore, the process of "discovery" will be
performed: a request will be sent to all nodes and the consecutive communication
continues with the node, which will be the first to reply.

=back

=head1 METHODS

=over 4

=item load_dictionary ( [ DICTIONARY ] )

Loads the definitions in the specified Radius dictionary file (standard
Livingston radiusd format). Tries to load 'C</etc/raddb/dictionary>' when no
argument is specified, or dies. NOTE: you need to load valid dictionary
if you plan to send RADIUS requests with attributes other than just
C<User-Name>/C<Password>.

=item check_pwd ( USERNAME, PASSWORD [,NASIPADDRESS] )

Checks with the RADIUS server if the specified C<PASSWORD> is valid for user
C<USERNAME>. Unless C<NASIPADDRESS> is specified, the script will attempt
to determine it's local IP address (IP address for the RADIUS socket) and
this value will be placed in the NAS-IP-Address attribute.
This method is actually a wrapper for subsequent calls to
C<clear_attributes>, C<add_attributes>, C<send_packet> and C<recv_packet>. It
returns 1 if the C<PASSWORD> is correct, or undef otherwise.

=item add_attributes ( { Name => NAME, Value => VALUE [, Type => TYPE] [, Vendor => VENDOR] }, ... )

Adds any number of Radius attributes to the current Radius object. Attributes
are specified as a list of anon hashes. They may be C<Name>d with their
dictionary name (provided a dictionary has been loaded first), or with
their raw Radius attribute-type values. The C<Type> pair should be specified
when adding attributes that are not in the dictionary (or when no dictionary
was loaded). Values for C<TYPE> can be 'C<string>', 'C<integer>', 'C<ipaddr>' or 'C<avpair>'.

=item get_attributes

Returns a list of references to anon hashes with the following key/value
pairs : { Name => NAME, Code => RAWTYPE, Value => VALUE, RawValue =>
RAWVALUE, Vendor => VENDOR }. Each hash represents an attribute in the current object. The
C<Name> and C<Value> pairs will contain values as translated by the
dictionary (if one was loaded). The C<Code> and C<RawValue> pairs always
contain the raw attribute type & value as received from the server.
If some attribute doesn't exist in dictionary or type of attribute not specified
then corresponding C<Value> undefined and C<Name> set to attribute ID (C<Code>
value).

=item clear_attributes

Clears all attributes for the current object.

=item send_packet ( REQUEST_TYPE, RETRANSMIT )

Packs up a Radius packet based on the current secret & attributes and
sends it to the server with a Request type of C<REQUEST_TYPE>. Exported
C<REQUEST_TYPE> methods are 'C<ACCESS_REQUEST>', 'C<ACCESS_ACCEPT>' ,
'C<ACCESS_REJECT>', 'C<ACCOUNTING_REQUEST>', 'C<ACCOUNTING_RESPONSE>',
'C<DISCONNECT_REQUEST>' and 'C<COA_REQUEST>'.
Returns the number of bytes sent, or undef on failure.

If the RETRANSMIT parameter is provided and contains a non-zero value, then
it is considered that we are re-sending the request, which was already sent
previously. In this case the previous value of packet identifier is used.

=item recv_packet ( DETECT_BAD_ID )

Receives a Radius reply packet. Returns the Radius Reply type (see possible
values for C<REQUEST_TYPE> in method C<send_packet>) or undef on failure. Note
that failure may be due to a failed recv() or a bad Radius response
authenticator. Use C<get_error> to find out.

If the DETECT_BAD_ID parameter is supplied and contains a non-zero value, then
calculation of the packet identifier is performed before authenticator check
and EBADID error returned in case when packet identifier from the response
doesn't match to the request. If the DETECT_BAD_ID is not provided or contains zero value then
EBADAUTH returned in such case.

=item set_timeout ( TIMEOUT )

Sets socket I/O activity timeout. C<TIMEOUT> should be specified in floating seconds
since the epoch.

=item get_error

Returns the last C<ERRORCODE> for the current object. Errorcodes are one-word
strings always beginning with an 'C<E>'.

=item strerror ( [ ERRORCODE ] )

Returns a verbose error string for the last error for the current object, or
for the specified C<ERRORCODE>.

=item error_comment

Returns the last error explanation for the current object. Error explanation
is generated by system call.

=item get_active_node

Returns currently active radius node in standard numbers-and-dots notation with
port delimited by colon.

=back

=head1 AUTHOR

Carl Declerck <carl@miskatonic.inbe.net> - original design
Alexander Kapitanenko <kapitan at portaone.com> and Andrew
Zhilenko <andrew at portaone.com> - later modifications.

PortaOne Development Team <perl-radius at portaone.com> is
the current module's maintainer at CPAN.

=cut