File Coverage

blib/lib/Data/Radius/DictionaryParser.pm
Criterion Covered Total %
statement 110 124 88.7
branch 39 50 78.0
condition 8 13 61.5
subroutine 14 14 100.0
pod 0 4 0.0
total 171 205 83.4


line stmt bran cond sub pod time code
1             package Data::Radius::DictionaryParser;
2              
3 6     6   65 use v5.10;
  6         19  
4 6     6   40 use strict;
  6         11  
  6         129  
5 6     6   27 use warnings;
  6         7  
  6         168  
6              
7 6     6   1292 use IO::File ();
  6         16281  
  6         177  
8 6     6   38 use File::Spec ();
  6         11  
  6         91  
9 6     6   29 use File::Basename ();
  6         8  
  6         98  
10              
11 6     6   25 use Digest::MD5 qw(md5_hex);
  6         11  
  6         5984  
12              
13             # parser state
14             my $begin_vendor = undef;
15             my $begin_tlv = undef;
16             # map id to name, {vendor => {id => name}}
17             my %dict_id = ();
18             # map name to id
19             my %dict_attr = ();
20             my %dict_const_name = ();
21             my %dict_const_value = ();
22             my %dict_vendor_name = ();
23             my %dict_vendor_id = ();
24              
25             my %included_files = ();
26              
27             sub new {
28 8     8 0 21 my $class = shift;
29 8         33 cleanup();
30 8         33 return bless {}, $class;
31             }
32              
33             sub _create_dict_from_current_state {
34 8     8   20 my ($self) = @_;
35              
36 8         7539 return Data::Radius::Dictionary->new(
37             attr_id => { %dict_id },
38             attr_name => { %dict_attr },
39             const_name => { %dict_const_name },
40             const_value => { %dict_const_value },
41             vnd_name => { %dict_vendor_name },
42             vnd_id => { %dict_vendor_id },
43             );
44             }
45              
46             sub parse_str_array {
47 1     1 0 3 my ($self, $str_array) = @_;
48              
49 1         3 my $synthetic_fname = md5_hex( @{$str_array} );
  1         8  
50 1 50       4 return if ( $included_files{$synthetic_fname} );
51 1         3 $included_files{$synthetic_fname} = 1;
52              
53             # since it's not file on disk, all $INCLUDEs are built relative to CWD
54 1   50     4 my $include_dir = $ENV{PWD} // '/';
55              
56 1         2 for my $line ( @{$str_array} ) {
  1         3  
57 2         6 $self->_parse_line($line, $include_dir);
58             }
59              
60 1         4 return $self->_create_dict_from_current_state;
61             }
62              
63             sub parse_file {
64 7     7 0 20 my ($self, $file) = @_;
65 7         25 $self->_load_file($file);
66 7         77 return $self->_create_dict_from_current_state;
67             }
68              
69             sub _load_file {
70 149     149   354 my ($self, $file) = @_;
71              
72 149 50       388 return undef if ( $included_files{$file} );
73              
74 149   33     815 my $fh = IO::File->new($file)
75             || warn sprintf('Failed to open file "%s": %s', $file, $!);
76              
77 149         13266 $included_files{$file} = 1;
78              
79             # INCLUDEs must be treated relatively to current file
80 149         5142 my $include_dir = File::Basename::dirname($file);
81              
82 149         2860 while ( my $line = $fh->getline ) {
83 20902         404893 $self->_parse_line($line, $include_dir);
84             }
85              
86 149         4941 $fh->close;
87              
88 149         3125 return 1;
89             }
90              
91             sub cleanup {
92 8     8 0 17 my ($self) = @_;
93              
94 8         16 $begin_vendor = undef;
95 8         15 $begin_tlv = undef;
96              
97 8         25 %dict_id = ();
98 8         208 %dict_attr = ();
99 8         35 %dict_const_name = ();
100 8         23 %dict_const_value = ();
101 8         19 %dict_vendor_name = ();
102 8         13 %dict_vendor_id = ();
103 8         26 %included_files = ();
104              
105 8         15 return undef;
106             }
107              
108             sub _parse_line {
109 20904     20904   32357 my ($self, $line, $include_dir) = @_;
110 20904   33     30923 $include_dir //= $ENV{PWD};
111              
112 20904         24229 my ($cmd, $name, $id, $type, $vendor, $has_tag, $has_options, $encrypt);
113              
114 20904         31057 $line =~ s/#.*$//;
115 20904 100       98749 return undef if ( $line =~ /^\s*$/ );
116 16416         22827 chomp $line;
117              
118 16416         61032 ($cmd, $name, $id, $type, $vendor) = split(/\s+/, $line);
119 16416         26856 $cmd = lc($cmd);
120 16416         18305 $has_options = 0;
121 16416         17048 $has_tag = 0;
122 16416         18313 $encrypt = undef;
123              
124 16416 100       27948 if ($cmd eq 'attribute') {
    100          
    100          
    100          
    100          
    100          
    100          
    50          
125             # 'vendor' part can be an options - in FreeRADIUS dictionary format
126 7722 100       11556 if ($vendor) {
127             # there could be combination of both options:
128 2116 100       3677 if ($vendor =~ /has_tag/) {
129 234         284 $has_tag = 1;
130 234         267 $has_options = 1;
131             }
132 2116 100       3101 if ($vendor =~ /encrypt=(\d)/) {
133             #TODO encryption methods not supported now
134 120         211 $encrypt = $1;
135 120         175 $has_options = 1;
136             }
137              
138 2116 100       2980 if ($has_options) {
139 348         437 $vendor = undef;
140             }
141             }
142              
143 7722   100     19751 $vendor ||= $begin_vendor;
144              
145 7722 50       13332 if (exists $dict_attr{ $name }) {
146 0         0 warn "Duplicated attribute name $name";
147             }
148              
149 7722         27148 my $a_info = {
150             id => $id,
151             name => $name,
152             type => $type,
153             vendor => $vendor,
154             has_tag => $has_tag,
155             encrypt => $encrypt,
156             };
157              
158 7722         16624 $dict_attr{ $name } = $a_info;
159              
160 7722 100       10560 if ($begin_tlv) {
161 318         506 $a_info->{parent} = $begin_tlv;
162              
163 318         398 my $parent = $dict_attr{ $begin_tlv };
164 318         548 $parent->{tlv_attr_name}{ $name } = $a_info;
165 318         651 $parent->{tlv_attr_id}{ $id } = $a_info;
166             }
167             else {
168 7404   100     21707 $dict_id{ $vendor // '' }{ $id } = $a_info;
169             }
170             }
171             elsif ($cmd eq 'value') {
172             # VALUE NAS-Port-Type Ethernet 15
173 8268         20137 my ($v_name, $v_val) = ($id, $type);
174              
175 8268 50       13819 if (! exists $dict_attr{ $name }) {
176 0         0 warn "Value for unknown attribute $name";
177 0         0 next;
178             }
179              
180 8268         17332 $dict_const_name{$name}{$v_val} = $v_name;
181 8268         22713 $dict_const_value{$name}{$v_name} = $v_val;
182             }
183             elsif ($cmd eq 'vendor') {
184             # VENDOR Mikrotik 14988
185 104         319 $dict_vendor_name{ $name } = $id;
186 104         242 $dict_vendor_id{ $id } = $name;
187             }
188             elsif ($cmd eq 'begin-vendor') {
189             # BEGIN-VENDOR Huawei
190 54 50       144 if (! exists $dict_vendor_name{ $name }) {
191 0         0 warn "BEGIN-VENDOR $name - vendor id is unknown";
192             }
193             # set default vendor for all attributes below
194 54         94 $begin_vendor = $name;
195             }
196             elsif ($cmd eq 'end-vendor') {
197             # END-VENDOR Laurel
198 54 50       198 if (! $begin_vendor) {
199 0         0 warn "END-VENDOR found without BEGIN-VENDOR";
200 0         0 next;
201             }
202 54         77 $begin_vendor = undef;
203             }
204             elsif ($cmd eq 'begin-tlv') {
205 36 50       80 if ($begin_tlv) {
206             # no support for 2nd level
207 0         0 warn "Nested BEGIN-TLV found";
208             }
209              
210             # BEGIN-TLV WiMAX-PPAC
211             # must be defined attribute with type 'tlv' first
212 36 50       82 if (! exists $dict_attr{ $name }) {
213 0         0 warn "Begin-tlv for unknown attribute $name";
214 0         0 next;
215             }
216 36 50       146 if ($dict_attr{ $name }{type} ne 'tlv') {
217 0         0 warn "Begin-tlv for attribute $name of non-tlv type";
218 0         0 next;
219             }
220 36         62 $begin_tlv = $name;
221             }
222             elsif ($cmd eq 'end-tlv') {
223             # END-TLV WiMAX-PPAC
224 36 50       76 if (! $begin_tlv) {
225 0         0 warn "END-TLV found without BEGIN-TLV";
226 0         0 next;
227             }
228 36         52 $begin_tlv = undef;
229             }
230             elsif ($cmd eq '$include') {
231             # $INCLUDE mikrotik
232             # $INCLUDE /absolute/path/to/mikrotik
233              
234             # clear modifiers
235 142         213 ($begin_vendor, $begin_tlv) = ();
236              
237 142 100       1234 if (File::Spec->file_name_is_absolute($name)) {
238 4         10 $self->_load_file($name);
239             }
240             else {
241 138         1543 $self->_load_file( File::Spec->catfile($include_dir, $name) );
242             }
243             }
244             else {
245 0         0 warn "Unknown command: $cmd";
246             }
247              
248 16416         250729 return undef;
249             }
250              
251              
252             1;