File Coverage

blib/lib/Data/Radius/Encode.pm
Criterion Covered Total %
statement 81 110 73.6
branch 26 48 54.1
condition 10 19 52.6
subroutine 19 22 86.3
pod 0 15 0.0
total 136 214 63.5


line stmt bran cond sub pod time code
1             package Data::Radius::Encode;
2              
3 2     2   71150 use strict;
  2         15  
  2         60  
4 2     2   15 use warnings;
  2         3  
  2         47  
5 2     2   681 use bytes;
  2         17  
  2         8  
6 2     2   1161 use Socket qw(inet_pton AF_INET AF_INET6);
  2         8039  
  2         376  
7              
8             use constant {
9 2         252 MAX_STRING_SIZE => 253,
10             MAX_VSA_STRING_SIZE => 247,
11             ATTR_CISCO_AVPAIR => 'Cisco-AVPair',
12             ATTR_CISCO_AVPAIR_ID => 1,
13             VENDOR_CISCO => 'Cisco',
14 2     2   16 };
  2         4  
15              
16 2     2   14 use Exporter qw(import);
  2         4  
  2         104  
17              
18             our @EXPORT_OK = qw(
19             encode
20              
21             encode_string
22             encode_int
23             encode_byte
24             encode_short
25             encode_signed
26             encode_ipaddr
27             encode_ipv6addr
28             encode_combo_ip
29             encode_octets
30             encode_avpair
31             encode_tlv
32             );
33              
34 2     2   808 use Data::Radius::Util qw(is_enum_type);
  2         10  
  2         2858  
35              
36             # type encoders
37             # $coderef->($value, $attr, $dictionary)
38             my %encode_map = (
39             string => \&encode_string,
40             string_tag => \&encode_string_tag,
41             integer => \&encode_int,
42             integer_tag => \&encode_int_tag,
43             byte => \&encode_byte,
44             short => \&encode_short,
45             signed => \&encode_signed,
46             ipaddr => \&encode_ipaddr,
47             ipv6addr => \&encode_ipv6addr,
48             avpair => \&encode_avpair,
49             'combo-ip' => \&encode_combo_ip,
50             octets => \&encode_octets,
51             tlv => \&encode_tlv,
52             # Unix timestamp
53             date => \&encode_int,
54             #TODO Ascend binary encoding
55             # abinary => ...
56             );
57              
58             if (!defined inet_pton(AF_INET6, '::1')) {
59             require Net::IP;
60             $encode_map{ipv6addr} = \&encode_ipv6addr_pp,
61             }
62              
63             # value limits for numeric types
64             my %limits_map = (
65             integer => [0, 2**32 - 1],
66             integer_tag => [0, 2**24 - 1],
67             byte => [0, 2**8 - 1],
68             short => [0, 2**16 - 1],
69             signed => [-2**31, 2**31 - 1],
70             # unix timestamp
71             date => [0, 2**32 - 1],
72             );
73              
74             sub encode_string {
75 13     13 0 30 my ($value, $attr, $dict) = @_;
76 13 100 66     61 my $max_size = ($attr && $attr->{vendor}) ? MAX_VSA_STRING_SIZE : MAX_STRING_SIZE;
77 13 100       43 if (length($value) > $max_size) {
78 2         21 warn "Too long value of ".$attr->{name};
79 2         17 return undef;
80             }
81 11         25 return $value;
82             }
83              
84             sub encode_string_tag {
85 0     0 0 0 my ($value, $attr, $dict, $tag) = @_;
86 0 0 0     0 my $max_size = ($attr && $attr->{vendor}) ? MAX_VSA_STRING_SIZE : MAX_STRING_SIZE;
87              
88 0 0       0 if (defined $tag) {
89 0 0       0 if ($tag > 31) {
90 0         0 warn sprintf('Too big tag value %d for %s', $tag, $attr->{name});
91             }
92 0         0 $max_size--;
93             }
94              
95 0 0       0 if (length($value) > $max_size) {
96 0         0 warn "Too long value of ".$attr->{name};
97 0         0 return undef;
98             }
99              
100 0 0       0 if (defined $tag) {
101 0         0 $value = pack('C', $tag) . $value;
102             }
103              
104 0         0 return $value;
105             }
106              
107 2     2 0 16 sub encode_int { pack('N', int($_[0])) }
108 2     2 0 9 sub encode_byte { pack('C', int($_[0])) }
109 1     1 0 7 sub encode_short { pack('S>', int($_[0])) }
110 2     2 0 12 sub encode_signed { pack('l>', int($_[0])) }
111              
112             sub encode_int_tag {
113 0     0 0 0 my ($value, $attr, $dict, $tag) = @_;
114 0         0 $value = pack('N', int($value));
115 0 0       0 if (defined $tag) {
116 0 0       0 if ($tag > 31) {
117 0         0 warn sprintf('Too big tag value %d for %s', $tag, $attr->{name});
118             }
119             # tag added to 1st byte, not extending the value length
120 0         0 substr($value, 0, 1, pack('C', $tag) );
121             }
122 0         0 return $value;
123             }
124              
125 3     3 0 17 sub encode_ipaddr { inet_pton(AF_INET, $_[0]) }
126 3     3 0 16 sub encode_ipv6addr { inet_pton(AF_INET6, $_[0]) }
127              
128             sub encode_ipv6addr_pp {
129 0     0 0 0 my $value = shift;
130 0         0 my $expanded_value = Net::IP::ip_expand_address( $value, 6 );
131 0 0       0 return undef if (! $expanded_value);
132 0         0 my $bin_value = Net::IP::ip_iptobin( $expanded_value, 6 );
133 0 0       0 return undef if (! defined $bin_value);
134 0         0 return pack( 'B*', $bin_value );
135             }
136              
137             sub encode_octets {
138 2     2 0 6 my ($value, $attr, $dict) = @_;
139              
140 2 100       16 if ($value !~ /^0x(?:[0-9A-Fa-f]{2})+$/) {
141 1         15 warn 'Invalid octet string for '.$attr->{name};
142 1         8 return undef;
143             }
144              
145 1         6 $value =~ s/^0x//;
146 1         7 return pack("H*", $value);
147             }
148              
149             sub encode_combo_ip {
150 2     2 0 5 my $ip = shift;
151              
152 2 100       12 if ($ip =~ /^\d+\.\d+.\d+.\d+$/) {
153 1         5 return $encode_map{ipaddr}->($ip);
154             }
155              
156 1         5 return $encode_map{ipv6addr}->($ip);
157             }
158              
159             sub encode_avpair {
160 4     4 0 10 my ($value, $attr, $dict) = @_;
161 4 50 50     19 if ( ($attr->{vendor} // '') eq VENDOR_CISCO ) {
162             # Looks like it afects only requests from Cisco NAS
163             # and probably not required in requests to it
164             # Do not applied to Cisco-AVPair attribute itself
165 4 100 66     19 if ($attr->{id} == ATTR_CISCO_AVPAIR_ID && $attr->{name} ne ATTR_CISCO_AVPAIR) {
166 2         8 $value = $attr->{name} . '=' . $value;
167             }
168             }
169              
170 4 100       12 if (length($value) > MAX_VSA_STRING_SIZE) {
171 2         24 warn "Too long value of ".$attr->{name};
172 2         13 return undef;
173             }
174              
175 2         5 return $value;
176             }
177              
178             # TODO continuation field is not supported for WiMAX VSA
179             sub encode_tlv {
180 2     2 0 4 my ($value, $parent, $dict) = @_;
181              
182 2         5 my @list = ();
183 2         4 foreach my $v (@{$value}) {
  2         6  
184 3         11 my $attr = $dict->attribute($v->{Name});
185 3 50       26 if (! $attr) {
186 0         0 warn "Unknown tlv-attribute ".$v->{Name};
187 0         0 next;
188             }
189              
190             # no vendor for sub-attributes
191              
192             # verify that corrent sub-attribute is used
193 3 50 50     18 if ( ($attr->{parent} // '') ne $parent->{name}) {
194 0         0 warn "Attribute $v->{Name} cannot be used with $parent->{name}";
195 0         0 next;
196             }
197              
198             # constant to its value
199 3         6 my $value;
200 3 100       19 if (is_enum_type($attr->{type})) {
201 1   33     6 $value = $dict->value($attr->{name}, $v->{Value}) // $v->{Value};
202             }
203             else {
204 2         5 $value = $v->{Value};
205             }
206              
207 3         40 my $encoded = encode($attr, $value, $dict);
208              
209 3         19 push @list, pack('C C', $attr->{id}, length($encoded) + 2) . $encoded;
210             }
211              
212 2         8 return join('', @list);
213             }
214              
215             # main exported function
216             sub encode {
217 44     44 0 3911 my ($attr, $value, $dict, $tag) = @_;
218              
219 44 100       113 if (! defined $value) {
220 1         11 warn "Value is not defined for " . $attr->{name};
221 1         8 return undef;
222             }
223              
224 43 50       127 my $encoder = $attr->{type} . ($attr->{has_tag} ? '_tag' : '');
225              
226 43         81 my $limits = $limits_map{ $encoder };
227 43 100       103 if ($limits) {
228             # integer types
229 16 100       99 if ($value !~ /^-?\d+$/) {
230 1         15 warn "Value is not number for " . $attr->{name};
231 1         14 return undef;
232             }
233              
234 15         36 my ($min, $max) = @$limits;
235 15 100 100     66 if ($value < $min || $value > $max) {
236 8         66 warn "Value out of range for " . $attr->{name};
237 8         60 return undef;
238             }
239             }
240              
241 34         104 my $encoded = $encode_map{ $encoder }->($value, $attr, $dict, $tag);
242 34         138 return $encoded;
243             }
244              
245             1;