File Coverage

lib/SNMP/MIB/Compiler.pm
Criterion Covered Total %
statement 446 1332 33.4
branch 249 1092 22.8
condition 88 265 33.2
subroutine 27 49 55.1
pod 9 37 24.3
total 819 2775 29.5


line stmt bran cond sub pod time code
1             # -*- Mode: Perl -*-
2              
3             ##########################################################################
4             # MIB Compiler supporting SMI(v1) and SMIv2
5             #
6             # Author: Fabien Tassin
7             # Copyright 1998, 1999 Fabien Tassin
8             ##########################################################################
9             # See Also :
10             # Rec. X.208: Specification of Abstract Syntax Notation (ASN.1)
11             # RFC 1155: Structure and Identification of Management Information
12             # for TCP/IP-based Internets
13             # RFC 1158: Management Information Base for network management of
14             # TCP/IP-based internets: MIB-II
15             # RFC 1212: Concise MIB definitions
16             # RFC 1215: Convention for defining traps for use with the SNMP
17             # RFC 1902: Structure of Management Information for Version 2 of the
18             # Simple Network Management Protocol (SNMPv2)
19             # RFC 1903: Textual Conventions for Version 2 of the Simple Network
20             # Management Protocol (SNMPv2)
21             # RFC 1904: Conformance Statements for Version 2 of the Simple Network
22             # Management Protocol (SNMPv2)
23             ##########################################################################
24             # ABSOLUTELY NO WARRANTY WITH THIS PACKAGE. USE IT AT YOUR OWN RISKS.
25             ##########################################################################
26              
27             # TODO:
28             # - resolve constants (e.g. 'max-bindings' in SNMPv2-PDU)
29             # - check a value against a syntax
30             # - extend the API
31             # - more test scripts
32              
33             package SNMP::MIB::Compiler;
34              
35 7     7   202836 use strict;
  7         18  
  7         486  
36 7     7   89 use vars qw(@ISA @EXPORT $VERSION $DEBUG);
  7         15  
  7         796  
37 7     7   39 use Exporter;
  7         15  
  7         407  
38 7     7   37 use Carp;
  7         12  
  7         572  
39 7     7   11194 use Data::Dumper;
  7         125664  
  7         560  
40 7     7   65 use FileHandle;
  7         14  
  7         56  
41              
42             @ISA = qw(Exporter);
43             @EXPORT = ();
44             $VERSION = 0.06;
45             $DEBUG = 1; # no longer used
46              
47             ######################################################################
48             # ASN1 items. (See Rec. X.208 §8)
49              
50             # Type references (§8.2)
51             my $ITEM_TYPEREFERENCE_PAT = '[A-Z](\-?[A-Za-z0-9])*';
52              
53             # Reserved character sequences (See Table 3/X.208)
54             # and Additional keyword items (See §A.2.9)
55             my @RESERVED_CHAR_SEQ = ('BOOLEAN', 'INTEGER', 'BIT', 'STRING', 'OCTET',
56             'NULL', 'SEQUENCE', 'OF', 'SET', 'IMPLICIT', 'CHOICE',
57             'ANY', 'EXTERNAL', 'OBJECT', 'IDENTIFIER', 'OPTIONAL',
58             'DEFAULT', 'COMPONENTS', 'UNIVERSAL', 'APPLICATION',
59             'PRIVATE', 'TRUE', 'FALSE', 'BEGIN', 'END',
60             'DEFINITIONS', 'EXPLICIT', 'ENUMERATED', 'EXPORTS',
61             'IMPORTS', 'REAL', 'INCLUDES', 'MIN', 'MAX', 'SIZE',
62             'FROM', 'WITH', 'COMPONENT', 'PRESENT', 'ABSENT',
63             'DEFINED', 'BY', 'PLUS-INFINITY', 'MINUS-INFINITY',
64             'TAGS',
65             'MACRO', 'TYPE', 'NOTATION', 'VALUE', # Macro keywords
66             );
67              
68             # my $ITEM_TYPEREFERENCE = '(?!' .
69             # (join '(?!\-?[A-Za-z0-9])|', @RESERVED_CHAR_SEQ) .
70             # '(?!\-?[A-Za-z0-9]))' . $ITEM_TYPEREFERENCE_PAT;
71              
72             my $ITEM_TYPEREFERENCE =
73             '(?!(?:' . (join '|', @RESERVED_CHAR_SEQ) . ')(?!\-?[A-Za-z0-9]))' .
74             $ITEM_TYPEREFERENCE_PAT;
75              
76             # Identifiers (§8.3)
77             my $ITEM_IDENTIFIER = '\b[a-z](?:\-?[A-Za-z0-9])*\b';
78             my $ITEM_IDENTIFIER2 = '\b[a-z](?:[\-_]?[A-Za-z0-9])*\b'; # w/allow_underscore
79              
80             # Number item (§8.8)
81             my $ITEM_NUMBER = '\b(?:0|[1-9][0-9]*)\b';
82              
83             # Binary string item (§8.9) (bstring)
84             my $ITEM_BINARYSTRING = '\'[01]*\'B';
85              
86             # Hexadecimal string item (§8.10) (hstring)
87             my $ITEM_HEXADECIMALSTRING = '\'[A-F0-9]*\'H';
88              
89             # Single character items (§8.13)
90             my $ITEM_SINGLECHARACTER = '[\{\}\<,\.\(\)\[\]\-;]';
91              
92             sub MIBERROR() { 0 };
93             sub MIBWARN() { 1 };
94             sub MIBNOTICE() { 2 };
95              
96             ######################################################################
97             # Tokens
98              
99             my $TOKEN = &create_tokens();
100              
101             my $BSTRING = &add_token ($TOKEN, 'BSTRING');
102             my $HSTRING = &add_token ($TOKEN, 'HSTRING');
103             my $CSTRING = &add_token ($TOKEN, 'CSTRING');
104             my $ASSIGNMENT = &add_token ($TOKEN, 'ASSIGNMENT');
105             my $NUMBER = &add_token ($TOKEN, 'NUMBER');
106             my $IDENTIFIER = &add_token ($TOKEN, 'IDENTIFIER');
107             my $TYPEMODREFERENCE = &add_token ($TOKEN, 'TYPEMODREFERENCE');
108             my $EMPTY = &add_token ($TOKEN, 'EMPTY');
109             my $BOOLEAN = &add_token ($TOKEN, 'BOOLEAN');
110             my $INTEGER = &add_token ($TOKEN, 'INTEGER');
111             my $BIT = &add_token ($TOKEN, 'BIT');
112             my $STRING = &add_token ($TOKEN, 'STRING');
113             my $OCTET = &add_token ($TOKEN, 'OCTET');
114             my $NULL = &add_token ($TOKEN, 'NULL');
115             my $SEQUENCE = &add_token ($TOKEN, 'SEQUENCE');
116             my $OF = &add_token ($TOKEN, 'OF');
117             my $SET = &add_token ($TOKEN, 'SET');
118             my $IMPLICIT = &add_token ($TOKEN, 'IMPLICIT');
119             my $CHOICE = &add_token ($TOKEN, 'CHOICE');
120             my $ANY = &add_token ($TOKEN, 'ANY');
121             my $EXTERNAL = &add_token ($TOKEN, 'EXTERNAL');
122             my $OBJECT = &add_token ($TOKEN, 'OBJECT');
123             my $OPTIONAL = &add_token ($TOKEN, 'OPTIONAL');
124             my $DEFAULT = &add_token ($TOKEN, 'DEFAULT');
125             my $COMPONENTS = &add_token ($TOKEN, 'COMPONENTS');
126             my $UNIVERSAL = &add_token ($TOKEN, 'UNIVERSAL');
127             my $APPLICATION = &add_token ($TOKEN, 'APPLICATION');
128             my $PRIVATE = &add_token ($TOKEN, 'PRIVATE');
129             my $TRUE = &add_token ($TOKEN, 'TRUE');
130             my $FALSE = &add_token ($TOKEN, 'FALSE');
131             my $BEGIN = &add_token ($TOKEN, 'BEGIN');
132             my $END = &add_token ($TOKEN, 'END');
133             my $DEFINITIONS = &add_token ($TOKEN, 'DEFINITIONS');
134             my $EXPLICIT = &add_token ($TOKEN, 'EXPLICIT');
135             my $ENUMERATED = &add_token ($TOKEN, 'ENUMERATED');
136             my $EXPORTS = &add_token ($TOKEN, 'EXPORTS');
137             my $IMPORTS = &add_token ($TOKEN, 'IMPORTS');
138             my $REAL = &add_token ($TOKEN, 'REAL');
139             my $INCLUDES = &add_token ($TOKEN, 'INCLUDES');
140             my $MIN = &add_token ($TOKEN, 'MIN');
141             my $MAX = &add_token ($TOKEN, 'MAX');
142             my $SIZE = &add_token ($TOKEN, 'SIZE');
143             my $FROM = &add_token ($TOKEN, 'FROM');
144             my $WITH = &add_token ($TOKEN, 'WITH');
145             my $COMPONENT = &add_token ($TOKEN, 'COMPONENT');
146             my $PRESENT = &add_token ($TOKEN, 'PRESENT');
147             my $ABSENT = &add_token ($TOKEN, 'ABSENT');
148             my $DEFINED = &add_token ($TOKEN, 'DEFINED');
149             my $BY = &add_token ($TOKEN, 'BY');
150             my $PLUSINFINITY = &add_token ($TOKEN, 'PLUSINFINITY');
151             my $MINUSINFINITY = &add_token ($TOKEN, 'MINUSINFINITY');
152             my $TAGS = &add_token ($TOKEN, 'TAGS');
153             my $MACRO = &add_token ($TOKEN, 'MACRO');
154             my $TYPE = &add_token ($TOKEN, 'TYPE');
155             my $NOTATION = &add_token ($TOKEN, 'NOTATION');
156             my $VALUE = &add_token ($TOKEN, 'VALUE');
157             my $MACROTYPE = &add_token ($TOKEN, 'MACROTYPE');
158             my $MACROVALUE = &add_token ($TOKEN, 'MACROVALUE');
159              
160             my $keywords = {
161             'BOOLEAN' => $BOOLEAN,
162             'INTEGER' => $INTEGER,
163             'BIT' => $BIT,
164             'STRING' => $STRING,
165             'OCTET' => $OCTET,
166             'NULL' => $NULL,
167             'SEQUENCE' => $SEQUENCE,
168             'OF' => $OF,
169             'SET' => $SET,
170             'IMPLICIT' => $IMPLICIT,
171             'CHOICE' => $CHOICE,
172             'ANY' => $ANY,
173             'EXTERNAL' => $EXTERNAL,
174             'OBJECT' => $OBJECT,
175             'IDENTIFIER' => $IDENTIFIER,
176             'OPTIONAL' => $OPTIONAL,
177             'DEFAULT' => $DEFAULT,
178             'COMPONENTS' => $COMPONENTS,
179             'UNIVERSAL' => $UNIVERSAL,
180             'APPLICATION' => $APPLICATION,
181             'PRIVATE' => $PRIVATE,
182             'TRUE' => $TRUE,
183             'FALSE' => $FALSE,
184             'BEGIN' => $BEGIN,
185             'END' => $END,
186             'DEFINITIONS' => $DEFINITIONS,
187             'EXPLICIT' => $EXPLICIT,
188             'ENUMERATED' => $ENUMERATED,
189             'EXPORTS' => $EXPORTS,
190             'IMPORTS' => $IMPORTS,
191             'REAL' => $REAL,
192             'INCLUDES' => $INCLUDES,
193             'MIN' => $MIN,
194             'MAX' => $MAX,
195             'SIZE' => $SIZE,
196             'FROM' => $FROM,
197             'WITH' => $WITH,
198             'COMPONENT' => $COMPONENT,
199             'PRESENT' => $PRESENT,
200             'ABSENT' => $ABSENT,
201             'DEFINED' => $DEFINED,
202             'BY' => $BY,
203             'TAGS' => $TAGS,
204              
205             'MACRO' => $MACRO,
206             'TYPE' => $TYPE,
207             'NOTATION' => $NOTATION,
208             'VALUE' => $VALUE,
209              
210             'MACROTYPE' => $MACROTYPE,
211             'MACROVALUE' => $MACROVALUE,
212             };
213              
214             ######################################################################
215              
216             # Create the standard tokens
217             sub create_tokens {
218 7     7 0 16 my $TOKEN = [];
219 7         36 my $i = -1;
220 7         47 while ($i++ < 255) {
221 1792         4365 $$TOKEN[$i] = chr $i;
222             }
223 7         23 $TOKEN;
224             }
225              
226             # Add a 'specialized' token to the current list of tokens
227             sub add_token {
228 406     406 0 493 my $TOKEN = shift;
229 406         796 my $k = shift;
230 406         718 push @$TOKEN, $k;
231 406         1121 $#$TOKEN;
232             }
233              
234             # The 'heart' of the compiler: the parser
235             # returns the couple token/value or the scalar 0 if something goes wrong.
236             sub yylex {
237 452     452 0 679 my $self = shift;
238              
239 452         590 my $s = $self->{'stream'};
240 452         1337 my $val;
241 452         522 my $c = ' '; # initialization.
242 452   33     2318 CHAR: while ($c ne '' && $c !~ m/^[A-Za-z0-9:=,\{\}<.\(\)\[\]\'\">|]$/o) {
243             # remove useless blanks and comments
244 473   66     898 1 while ($c = $s->getc) eq ' ' || $c eq "\t" || $c eq "\n" || $c eq "\r";
      100        
      66        
245 473 50       956 return 0 if $c eq '';
246 473 100       733 if ($c eq '-') { # The first char of a "comment" (See §8.6)
247 22         48 $c = $s->getc;
248 22 50       75 if ($c eq '') { # a single hyphen followed by EOF
249 0         0 $s->ungetc; # keep EOF for the next yylex call
250 0         0 $c = '-';
251 0         0 last CHAR;
252             }
253 22 100       55 if ($c eq '-') { # it is a real "comment" marker
254 21         33 while (1) {
255 28   66     62 1 while ($c = $s->getc) ne '' && $c ne '-'
      100        
      66        
256             && $c ne "\n" && $c ne "\r";
257 28 50       80 return 0 if $c eq ''; # End of file.
258 28 100       69 if ($c eq '-') {
259 13         30 $c = $s->getc;
260 13 50       48 return 0 if $c eq ''; # End of file.
261 13 100 66     142 next CHAR if $c eq "\n" || $c eq "\r" ||
      100        
262             $c eq '-'; # End of comment.
263             }
264 22 100       141 next CHAR if $c eq "\n"; # End of comment.
265             }
266             }
267             else { # it is NOT a comment but a single hyphen.
268 1         4 $s->ungetc;
269 1         3 $c = '-';
270 1         2 last CHAR;
271             }
272             }
273             else {
274 451         528 last;
275             }
276             }
277             # Here, the current char is a valid ASN.1 char, it can be a hyphen but
278             # not a double hyphen (comment start).
279              
280             # Read a word and return the correspondant token.
281 452 50       783 return 0 if $c eq '';
282 452 100       1516 if ($c =~ m/^$ITEM_SINGLECHARACTER$/o) {
283             # it is a single characters
284 128         388 return (ord ($c), $c);
285             }
286 324 100       691 if ($c =~ m/^[>|]/o) {
287             # it is a single extension characters
288 9         29 return (ord ($c), $c);
289             }
290 315 50       630 if ($c eq '\'') { # it can be a cstring or a hstring.
291 0         0 $val = $c;
292             # while (($c = $s->getc) ne '' && ($c =~ m/[0-9A-F]/o ||
293             # ($self->{'allow_lowcase_hstrings'} && $c =~ m/[a-f]/o))) {
294 0   0     0 while (($c = $s->getc) ne '' && $c =~ m/[0-9A-Fa-f]/o) {
295 0         0 $val .= $c;
296             }
297 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
298             "Unexpected EOF near \"$val\"") if $c eq '';
299 0 0       0 if ($c eq '\'') {
300 0         0 $val .= $c;
301 0         0 $c = $s->getc;
302 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
303             "Unexpected EOF near \"$val\"") if $c eq '';
304 0         0 $val .= $c;
305             # it must be 'B' or 'H'.
306 0 0 0     0 $c = 'B' if $c eq 'b' && $self->{'allow_lowcase_bstrings'};
307 0 0 0     0 if ($c =~ m/[hH]/o && $self->{'allow_lowcase_hstrings'}) {
308 0         0 $c = 'H';
309 0         0 $val = uc $val;
310             }
311 0 0 0     0 if ($c eq 'B' && $val =~ m/^$ITEM_BINARYSTRING$/o) {
312 0         0 return ($BSTRING, $val);
313             }
314 0 0 0     0 if ($c eq 'H' && $val =~ m/^$ITEM_HEXADECIMALSTRING$/o) {
315 0         0 return ($HSTRING, $val);
316             }
317 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
318             "Invalid \"$val\". See 'allow_lowcase_{b|h}strings' switches");
319             }
320 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
321             "Syntax error near \"$val\"");
322             }
323 315 100       575 if ($c eq '"') { # a cstring
324 27         36 $val = $c;
325 27         30 while (1) {
326 27   66     52 while (($c = $s->getc) ne '' && $c ne '"') {
327 1985         4307 $val .= $c;
328             }
329 27 50       70 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
330             "Unexpected EOF near \"$val\"") if $c eq '';
331 27         38 $val .= $c;
332 27         54 $c = $s->getc;
333 27 50 33     134 if ($c eq '' || $c ne '"') {
334 27 50       87 $s->ungetc if $c;
335 27         102 return ($CSTRING, $val);
336             }
337 0         0 $val .= $c;
338             }
339             }
340 288 100       547 if ($c eq ':') { # an assignment item
341 8         17 $val = $c;
342 8         19 $c = $s->getc;
343 8 50       25 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
344             "Unexpected EOF near \"$val\"") if $c eq '';
345 8 50       21 if ($c ne ':') {
346 0 0       0 $s->ungetc if $c;
347             }
348             else {
349 8         14 $val .= $c;
350 8         20 $c = $s->getc;
351 8 50       26 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
352             "Unexpected EOF near \"$val\"") if $c eq '';
353 8 50       25 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
354             "Syntax error near \"$val\"") unless $c eq '=';
355 8         10 $val .= $c;
356 8         28 return ($ASSIGNMENT, $val);
357             }
358             }
359 280 100       615 if ($c =~ m/\d/o) { # it is a number
360 44         62 $val = $c;
361 44   66     90 while (($c = $s->getc) ne '' && $c =~ m/\d/o) {
362 5         13 $val .= $c;
363             }
364 44 50       152 $s->ungetc if $c;
365 44 50       448 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
366             "Syntax error near \"$val\"") unless $val =~ m/^$ITEM_NUMBER$/;
367 44         140 return ($NUMBER, $val);
368             }
369 236 50       660 if ($c =~ m/[a-zA-Z]/o) {
370 236         312 $val = $c;
371 236         219 while (1) {
372 294   66     557 while (($c = $s->getc) ne '' && ($c =~ m/[A-Za-z0-9]/o ||
      33        
373             ($self->{'allow_underscore'} && $c eq '_'))) {
374 2098         4640 $val .= $c;
375             }
376 294 100       619 if ($c eq '-') {
377 61         124 $c = $s->getc;
378             # a hyphen shall not be the last character
379 61 50 33     392 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
      33        
380             "Syntax error near \"$val\"")
381             if $c eq '' || $c eq "\n" || $c eq "\r";
382 61 100       119 if ($c eq '-') { # it is a comment.
383 3         5 COMM: while (1) {
384 4   66     9 1 while ($c = $s->getc) ne '' && $c ne '-' &&
      100        
      66        
385             $c ne "\n" && $c ne "\r";
386 4 100 66     29 last COMM if $c eq '' || # End of file...
      66        
387             $c eq "\n" || $c eq "\r"; # End of comment.
388 2         5 $c = $s->getc;
389 2 100 33     22 last COMM if $c eq '' || # End of file...
      33        
      66        
390             $c eq "\n" || $c eq "\r" || $c eq '-'; # End of comment.
391 1         4 $s->ungetc;
392             }
393             # TypeReference or ModuleReference
394 3 100       204 return ($TYPEMODREFERENCE, $val)
395             if $val =~ m/^$ITEM_TYPEREFERENCE$/o;
396             # Identifier or ValueReference
397 2 100       29 return ($IDENTIFIER, $val) if $val =~ m/^$ITEM_IDENTIFIER$/o;
398 1 50 33     27 return ($IDENTIFIER, $val) if $val =~ m/^$ITEM_IDENTIFIER2$/o &&
399             $self->{'allow_underscore'};
400 1 50       7 return ($PLUSINFINITY, $val) if $val eq 'PLUS-INFINITY';
401 0 0       0 return ($MINUSINFINITY, $val) if $val eq 'MINUS-INFINITY';
402 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
403             "Syntax error near \"$val\"");
404             }
405 58 50       161 $s->ungetc if $c ne '';
406 58         102 $val .= "-";
407             }
408 291 100       749 if ($c !~ m/[A-Za-z0-9]/o) {
409 233 50       602 $s->ungetc if $c;
410              
411             # Is it a known keyword ?
412 233 100       631 return ($$keywords{$val}, $val) if defined $$keywords{$val};
413              
414             # TypeReference/ModuleReference/MacroReference/ProductionReference/
415             # LocalTypeReference
416 200 100       2980 return ($TYPEMODREFERENCE, $val) if $val =~ m/^$ITEM_TYPEREFERENCE$/o;
417             # Identifier/ValueReference/LocalValueReference
418 98 100       963 return ($IDENTIFIER, $val) if $val =~ m/^$ITEM_IDENTIFIER$/o;
419 2 100 66     50 return ($IDENTIFIER, $val) if $val =~ m/^$ITEM_IDENTIFIER2$/o &&
420             $self->{'allow_underscore'};
421 1 50       4 return ($PLUSINFINITY, $val) if $val eq 'PLUS-INFINITY';
422 1 50       8 return ($MINUSINFINITY, $val) if $val eq 'MINUS-INFINITY';
423 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
424             "'$val' unrecognized");
425             }
426             }
427             }
428 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $s->{'lineno'},
429             "'$c' unrecognized");
430             }
431              
432             # Constructor
433             sub new {
434 7     7 1 355 my $this = shift;
435              
436 7   33     62 my $class = ref($this) || $this;
437 7         18 my $self = {};
438 7         24 bless $self, $class;
439 7         38 $self->initialize();
440 7         22 return $self;
441             }
442              
443             # Create the MIB tree with some special nodes.
444             sub initialize {
445 7     7 0 16 my $self = shift;
446              
447 7         70 $self->{'token_list'} = [];
448 7         41 $self->{'srcpath'} = [];
449              
450             # extension of the produced files
451 7         21 $self->{'dumpext'} = ".dump";
452              
453             # '_' is not defined in the ASN.1 charset set but is sometimes found
454             # in SNMP MIBs. This flag can be used to avoid parsing errors on such
455             # mibs.
456 7         20 $self->{'allow_underscore'} = 0;
457              
458             # 'abfc'h is invalid (must be 'ABFC'H) but is sometimes used in SNMP MIBs.
459 7         19 $self->{'allow_lowcase_hstrings'} = 0;
460              
461             # '1001'b is invalid (must be '1001'B) but is sometimes used in SNMP MIBs.
462 7         18 $self->{'allow_lowcase_bstrings'} = 0;
463              
464 7         19 $self->{'allow_keyword_any'} = 1;
465              
466             # Add the 3 roots of the tree.
467             # These nodes cannot be specified using valid ASN.1 clauses.
468 7         42 $self->{'root'}{'ccitt'}{'oid'} = [ 0 ];
469 7         31 $self->{'root'}{'iso'}{'oid'} = [ 1 ];
470 7         29 $self->{'root'}{'joint-iso-ccitt'}{'oid'} = [ 2 ];
471              
472             # debug flags
473 7         20 $self->{'debug_recursive'} = 0;
474 7         18 $self->{'debug_lexer'} = 0;
475              
476 7         33 $self->{'make_dump'} = 1;
477 7         17 $self->{'use_dump'} = 1;
478              
479 7         17 $self->{'accept_smiv1'} = 1;
480 7         18 $self->{'accept_smiv2'} = 1;
481              
482             # should we import dependencies ?
483 7         31 $self->{'do_imports'} = 1;
484             }
485              
486             sub assert {
487 0     0 0 0 my $self = shift;
488 0         0 my $level = shift;
489 0         0 my $file = shift;
490 0         0 my $line = shift;
491 0         0 my $msg = shift;
492              
493 0 0       0 if (defined $level) {
494 0 0       0 $self->{'msg'} = [] unless defined $self->{'msg'};
495 0         0 my ($cpackage, $cfile, $cline) = caller;
496 0         0 push @{$self->{'msg'}}, { 'level' => $level,
  0         0  
497             'file' => $file,
498             'line' => $line,
499             'msg' => sprintf($msg, @_),
500             'cpackage' => $cpackage,
501             'cfile' => $cfile,
502             'cline' => $cline,
503             };
504 0         0 return $level;
505             }
506             else {
507 0 0       0 if (wantarray) {
508 0         0 return $level;
509             }
510             else {
511 0         0 my $s = "";
512 0 0       0 map {
513 0         0 $s .= sprintf "Error %d: %s at %s line %d.%s\n", $$_{'level'},
514             $$_{'msg'}, $$_{'file'}, $$_{'line'},
515             $DEBUG ? sprintf " [%s %d]", $$_{'cfile'}, $$_{'cline'}: "";
516 0 0       0 } @{$self->{'msg'}} if defined $self->{'msg'};
517 0         0 return $s;
518             }
519             }
520             }
521              
522             # Get the next token from the parser
523             sub get_token {
524 501     501 0 12023 my $self = shift;
525 501         523 my $needed = shift;
526              
527 501         461 my ($res, $k);
528 501 100       471 if (@{$self->{'token_list'}}) {
  501         1105  
529 66         66 my $temp = shift @{$self->{'token_list'}};
  66         104  
530 66         158 ($res, $k) = ($$temp[0], $$temp[1]);
531 66         154 $self->{'lineno'} = $$temp[2];
532             }
533             else {
534 435         747 ($res, $k) = $self->yylex();
535 435         1079 $self->{'lineno'} = $self->{'stream'}->lineno;
536 435 50       885 return unless $res;
537             }
538 501 0       1031 warn "DEBUG: token='" . ($res ? $$TOKEN[$res] : $res) . "' value='" .
    0          
    50          
539             (defined $k ? $k : '') . "'\n" if $self->{'debug_lexer'};
540 501 50 66     1654 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
      66        
541             "'$needed' expected")
542             if defined $needed && $res && $$TOKEN[$res] ne $needed;
543 501         746 $self->{'current_token'} = $res;
544 501         643 $self->{'current_value'} = $k;
545 501         2217 ($res, $k);
546             }
547              
548             # Requeue the last token in the incoming queue.
549             # WARNING: only one token can be requeued.
550             sub unget_token {
551 66     66 0 82 my $self = shift;
552              
553 66 50       171 warn "DEBUG: unshift\n" if $self->{'debug_lexer'};
554 66 50       127 if (defined $self->{'current_token'}) {
555 66         67 push @{$self->{'token_list'}}, [ $self->{'current_token'},
  66         247  
556             $self->{'current_value'},
557             $self->{'lineno'} ];
558 66         180 $self->{'current_token'} = $self->{'current_value'} =
559             $self->{'lineno'} = undef;
560             }
561             else {
562 0         0 die "Error: can't unget more than one token. Abort.\n";
563             }
564             }
565              
566             sub create_tree {
567 0     0 0 0 my $self = shift;
568              
569 0         0 for my $node (keys %{$self->{'nodes'}}) {
  0         0  
570 0         0 my $t = $self->{'nodes'}{$node}{'oid'};
571 0         0 $self->{'tree'}{$$t[$#$t - 1]}{$$t[$#$t]} = $node;
572             }
573             }
574              
575             # Compile a MIB file given its name
576             sub compile {
577 0     0 1 0 my $self = shift;
578 0         0 my $file = shift;
579              
580 0 0       0 croak "Error: you MUST specify a file to compile\n" unless $file;
581 0         0 my $outdir = $self->repository;
582 0 0 0     0 croak "Error: you MUST specify a repository\n"
583             if $self->{'make_dump'} && !$outdir;
584 0         0 my $filename;
585 0 0       0 if ($file =~ m|/([^/]+)$|) {
586 0 0       0 croak "Error: can't find $file" unless -e $file;
587 0         0 $filename = $file;
588 0         0 $file = $1;
589             }
590             else {
591 0   0     0 my $dir = $self->{'srcpath'} ||
592             croak "Error: you MUST specify a path using add_path()\n";
593 0   0     0 my $ext = $self->extensions || [ '' ];
594 0         0 my $windir;
595             my $extfile;
596 0         0 my @dirtmp = @$dir;
597 0         0 while (my $d = shift @dirtmp) {
598 0         0 map {
599 0         0 my $e = $_;
600             # warn "testing '$d/$file$e'\n";
601 0 0       0 $windir = $d, $extfile = $e, last if -e "$d/$file$e";
602             } @$ext;
603             }
604 0 0       0 croak "Error: can't find $file" unless $windir;
605 0         0 $filename = "$windir/$file$extfile";
606             }
607             # push @{$self->{'filename'}}, $filename;
608 0         0 $self->{'filename'} = $filename;
609             # my $filename = $ {$self->{'filename'}}[$#{$self->{'filename'}}];
610              
611 0 0 0     0 if ($self->{'use_dump'} && -e "$outdir/$file$self->{'dumpext'}") {
612 0 0       0 if (-M $filename < -M "$outdir/$file$self->{'dumpext'}") {
613 0         0 $self->assert(MIBNOTICE, $self->{'filename'}, $self->{'fileno'},
614             "$outdir/$file$self->{'dumpext'} is older than " .
615             "$filename. Recompiling $filename...");
616             }
617             else {
618 0         0 my $v;
619 0         0 my $fh = new FileHandle "$outdir/$file$self->{'dumpext'}";
620 0 0       0 if (defined $fh) {
621 0         0 local $/ = undef;
622 0         0 $v = eval <$fh>;
623 0 0       0 if ($v) {
624 0         0 map { $self->{'nodes'}{$_} = $$v{'nodes'}{$_} } keys %{$$v{'nodes'}};
  0         0  
  0         0  
625 0         0 map { $self->{'types'}{$_} = $$v{'types'}{$_} } keys %{$$v{'types'}};
  0         0  
  0         0  
626 0         0 for my $node (keys %{$$v{'tree'}}) {
  0         0  
627 0         0 for my $son (keys %{$$v{'tree'}{$node}}) {
  0         0  
628 0         0 $self->{'tree'}{$node}{$son} = $$v{'tree'}{$node}{$son};
629             }
630             }
631 0         0 map { $self->{'traps'}{$_} = $$v{'traps'}{$_} } keys %{$$v{'traps'}};
  0         0  
  0         0  
632 0         0 map { push @{$self->{'macros'}}, $_ } @{$$v{'macros'}};
  0         0  
  0         0  
  0         0  
633             }
634 0         0 $fh->close;
635             }
636 0 0       0 return $self if $v;
637             }
638             }
639              
640             # open the MIB file
641 0         0 my $fh = new FileHandle $filename;
642 0 0       0 unless (defined $fh) {
643 0         0 croak "Error: can't open $filename: $!\n";
644 0         0 return;
645             }
646             # create a new MIB object
647 0         0 my $mib = new SNMP::MIB::Compiler;
648 0         0 $mib->{'filename'} = $filename;
649 0         0 $mib->repository($self->repository);
650 0         0 $mib->extensions($self->extensions);
651 0         0 $mib->{'srcpath'} = $self->{'srcpath'};
652 0 0       0 push @{$mib->{'msg'}}, @{$self->{'msg'}} if defined $self->{'msg'};
  0         0  
  0         0  
653              
654 0         0 $mib->{'make_dump'} = $self->{'make_dump'};
655 0         0 $mib->{'use_dump'} = $self->{'use_dump'};
656 0         0 $mib->{'do_imports'} = $self->{'do_imports'};
657              
658 0         0 $mib->{'allow_underscore'} = $self->{'allow_underscore'};
659 0         0 $mib->{'allow_lowcase_hstrings'} = $self->{'allow_lowcase_hstrings'};
660 0         0 $mib->{'allow_lowcase_bstrings'} = $self->{'allow_lowcase_bstrings'};
661              
662 0 0       0 if ($self->{'debug_recursive'}) {
663 0         0 $mib->{'debug_recursive'} = $self->{'debug_recursive'};
664 0         0 $mib->{'debug_lexer'} = $self->{'debug_lexer'};
665             }
666             # create a stream
667 0         0 my $s = Stream->new($fh);
668 0         0 $mib->{'stream'} = $s;
669             # parse the MIB
670 0         0 my $r = $mib->parse_Module();
671 0 0       0 push @{$self->{'msg'}}, @{$mib->{'msg'}} if defined $mib->{'msg'};
  0         0  
  0         0  
672              
673             # destroy the stream
674 0         0 delete $mib->{'stream'};
675             # close the file
676 0         0 $fh->close;
677 0 0       0 return undef unless $r;
678              
679             # Create the MIB 'tree'
680 0         0 $mib->create_tree();
681              
682 0 0       0 if ($self->{'make_dump'}) {
683 0         0 local $Data::Dumper::Purity = 1;
684 0         0 local $Data::Dumper::Indent = 1;
685 0         0 local $Data::Dumper::Terse = 1;
686              
687 0         0 my $file = $mib->{'name'};
688 0         0 my $fh = new FileHandle "> $outdir/$file$self->{'dumpext'}";
689 0 0       0 if (defined $fh) {
690 0         0 print $fh "## Compiled by SNMP::MIB::Compiler version $VERSION\n" .
691             "## Source: $filename\n" .
692             "## Date: " . (scalar localtime (time)) ."\n\n";
693 0         0 print $fh Dumper { 'nodes' => $mib->{'nodes'},
694             'types' => $mib->{'types'},
695             'macros' => $mib->{'macros'},
696             'tree' => $mib->{'tree'},
697             'traps' => $mib->{'traps'},
698             'version' => $VERSION,
699             };
700 0         0 $fh->close;
701             }
702             else {
703 0         0 croak "Warning: can't create dump $outdir/$file$self->{'dumpext'}" .
704             ": $!\n";
705             }
706             }
707             # insert this MIB into the current object
708 0         0 map { $self->{'nodes'}{$_} = $mib->{'nodes'}{$_} } keys %{$mib->{'nodes'}};
  0         0  
  0         0  
709 0         0 map { $self->{'types'}{$_} = $mib->{'types'}{$_} } keys %{$mib->{'types'}};
  0         0  
  0         0  
710 0         0 map { $self->{'traps'}{$_} = $mib->{'traps'}{$_} } keys %{$mib->{'traps'}};
  0         0  
  0         0  
711 0         0 map { push @{$self->{'macros'}}, $_ } @{$mib->{'macros'}};
  0         0  
  0         0  
  0         0  
712              
713 0         0 for my $node (keys %{$mib->{'tree'}}) {
  0         0  
714 0         0 for my $son (keys %{$self->{'tree'}{$node}}) {
  0         0  
715 0         0 $self->{'tree'}{$node}{$son} = $mib->{'tree'}{$node}{$son};
716             }
717             }
718 0         0 $self->create_tree();
719 0         0 $self;
720             }
721              
722             sub load {
723 0     0 1 0 my $self = shift;
724 0         0 my $file = shift;
725              
726 0 0       0 croak "Error: you MUST specify a MIB to load\n" unless $file;
727 0         0 my $outdir = $self->repository;
728 0 0       0 die "Error: you MUST specify a repository\n" unless $outdir;
729 0 0 0     0 if ($self->{'use_dump'} && -e "$outdir/$file$self->{'dumpext'}") {
730 0         0 my $v;
731 0         0 my $fh = new FileHandle "$outdir/$file$self->{'dumpext'}";
732 0 0       0 if (defined $fh) {
733 0         0 local $/ = undef;
734 0         0 $v = eval <$fh>;
735 0 0       0 if ($v) {
736 0         0 map { $self->{'nodes'}{$_} = $$v{'nodes'}{$_} } keys %{$$v{'nodes'}};
  0         0  
  0         0  
737 0         0 map { $self->{'types'}{$_} = $$v{'types'}{$_} } keys %{$$v{'types'}};
  0         0  
  0         0  
738 0         0 map { $self->{'traps'}{$_} = $$v{'traps'}{$_} } keys %{$$v{'traps'}};
  0         0  
  0         0  
739 0         0 for my $node (keys %{$$v{'tree'}}) {
  0         0  
740 0         0 for my $son (keys %{$$v{'tree'}{$node}}) {
  0         0  
741 0         0 $self->{'tree'}{$node}{$son} = $$v{'tree'}{$node}{$son};
742             }
743             }
744 0         0 map { push @{$self->{'macros'}}, $_ } @{$$v{'macros'}};
  0         0  
  0         0  
  0         0  
745             }
746 0         0 $fh->close;
747             }
748 0         0 1;
749             }
750             else {
751 0 0       0 $self->assert(MIBWARN, $self->{'filename'}, $self->{'lineno'},
752             "can't find precompiled $file. Ignored\n") if $self->{'debug_lexer'};
753 0         0 0;
754             }
755             }
756              
757             sub parse_Module {
758 2     2 0 15 my $self = shift;
759 2         6 my ($token, $mibname, $value);
760             # ModuleIdentifier
761 2 50       16 (($token, $mibname) = $self->get_token('TYPEMODREFERENCE')) || return;
762 2         6 $self->{'name'} = $mibname;
763 2 50       7 $self->get_token('DEFINITIONS') || return;
764 2 50       7 $self->get_token('ASSIGNMENT') || return;
765 2 50       7 $self->get_token('BEGIN') || return;
766 2 50       7 (($token, $value) = $self->get_token()) || return;
767 2   66     18 while ($token && $token != $END) {
768 2 50       15 if ($token == $IMPORTS) {
    50          
    50          
    0          
769 0         0 $self->{'imports'} = $self->parse_imports();
770 0 0       0 $self->import_modules() if $self->{'do_imports'};
771             }
772             elsif ($token == $EXPORTS) {
773 0         0 $self->{'exports'} = $self->parse_exports();
774             }
775             elsif ($token == $IDENTIFIER) {
776 2         5 my $assign = $value;
777 2 50       6 (($token, $value) = $self->get_token()) || return;
778 2 50       9 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
779             "Syntax error") unless $token;
780 2 50       12 if ($token == $OBJECT) { # probably an OBJECT IDENTIFIER
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
781 0 0       0 $self->get_token('IDENTIFIER') || return;
782 0 0       0 $self->get_token('ASSIGNMENT') || return;
783 0         0 my $oid = $self->parse_oid();
784 0         0 $self->{'nodes'}{$assign}{'oid'} = $oid;
785 0         0 $self->{'nodes'}{$assign}{'type'} = 'OBJECT IDENTIFIER';
786             }
787             elsif ($token == $INTEGER) {
788 0 0       0 $self->get_token('ASSIGNMENT') || return;
789 0 0       0 (($token, $value) = $self->get_token()) || return;
790 0         0 $self->{'constants'}{$assign}{'value'} = $value;
791             }
792             elsif ($value eq 'OBJECT-TYPE') {
793 2   50     12 $self->{'nodes'}{$assign} = $self->parse_objecttype() || return;
794             # return undef unless $self->{'nodes'}{$assign};
795 2         15 $self->{'nodes'}{$assign}{'type'} = 'OBJECT-TYPE';
796             }
797             elsif ($value eq 'OBJECT-IDENTITY') {
798 0 0       0 $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
799             "Syntax error at '$value'") unless $self->{'accept_smiv2'};
800 0   0     0 $self->{'nodes'}{$assign} = $self->parse_objectidentity() || return;
801 0         0 $self->{'nodes'}{$assign}{'type'} = 'OBJECT-IDENTITY';
802             }
803             elsif ($value eq 'MODULE-IDENTITY') {
804 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
805             "Syntax error at '$value'")
806             unless $self->{'accept_smiv2'};
807 0         0 $self->{'nodes'}{$assign} = $self->parse_moduleidentity();
808 0         0 $self->{'nodes'}{$assign}{'type'} = 'MODULE-IDENTITY';
809             }
810             elsif ($value eq 'MODULE-COMPLIANCE') {
811 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
812             "Syntax error at '$value'")
813             unless $self->{'accept_smiv2'};
814 0         0 $self->{'nodes'}{$assign} = $self->parse_modulecompliance();
815 0         0 $self->{'nodes'}{$assign}{'type'} = 'MODULE-COMPLIANCE';
816             }
817             elsif ($value eq 'OBJECT-GROUP') {
818 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
819             "Syntax error at '$value'")
820             unless $self->{'accept_smiv2'};
821 0         0 $self->{'nodes'}{$assign} = $self->parse_objectgroup();
822 0         0 $self->{'nodes'}{$assign}{'type'} = 'OBJECT-GROUP';
823             }
824             elsif ($value eq 'NOTIFICATION-GROUP') {
825 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
826             "Syntax error at '$value'")
827             unless $self->{'accept_smiv2'};
828 0         0 $self->{'nodes'}{$assign} = $self->parse_notificationgroup();
829 0         0 $self->{'nodes'}{$assign}{'type'} = 'NOTIFICATION-GROUP';
830             }
831             elsif ($value eq 'AGENT-CAPABILITIES') {
832 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
833             "Syntax error at '$value'")
834             unless $self->{'accept_smiv2'};
835 0         0 $self->{'nodes'}{$assign} = $self->parse_agentcapabilities();
836 0         0 $self->{'nodes'}{$assign}{'type'} = 'AGENT-CAPABILITIES';
837             }
838             elsif ($value eq 'TRAP-TYPE') {
839             # as defined in RFC 1215
840 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
841             "Syntax error at '$value'")
842             unless $self->{'accept_smiv1'};
843 0         0 $self->{'traps'}{$assign} = $self->parse_traptype();
844 0         0 $self->{'traps'}{$assign}{'type'} = 'TRAP-TYPE';
845             }
846             elsif ($value eq 'NOTIFICATION-TYPE') {
847 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
848             "Syntax error at '$value'")
849             unless $self->{'accept_smiv2'};
850 0         0 $self->{'traps'}{$assign} = $self->parse_notificationtype();
851 0         0 $self->{'traps'}{$assign}{'type'} = 'NOTIFICATION-TYPE';
852             }
853             else {
854 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
855             "Syntax error at '$value'");
856             }
857             }
858             elsif ($token == $TYPEMODREFERENCE) {
859 0         0 my $label = $value;
860 0 0       0 (($token, $value) = $self->get_token()) || return;
861 0 0       0 if ($token == $ASSIGNMENT) {
    0          
862 0         0 my $type = $self->parse_type();
863             # warn "Warning: type '$label' already defined"
864             # if defined $self->{'types'}{$label};
865 0         0 $self->{'types'}{$label} = $type;
866             }
867             elsif ($token == $MACRO) {
868             # Skip this beast..
869 0 0       0 (($token, $value) = $self->get_token('ASSIGNMENT')) || return;
870 0   0     0 while ($token && $token != $END) {
871 0 0       0 (($token, $value) = $self->get_token()) || return;
872             }
873 0         0 push @{$self->{'macros'}}, $label;
  0         0  
874             }
875             else {
876 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
877             "unrecognized syntax '$value' ($$TOKEN[$token])...");
878             }
879             }
880             else {
881 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
882             "received an unknown token ($$TOKEN[$token])");
883             }
884 2 50       6 (($token, $value) = $self->get_token()) || return;
885             }
886 2 50       10 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
887             "'END' expected") unless $token == $END;
888             }
889              
890             # Given a type, this will return the corresponding SMI (v2 or v1) type
891             # or the corresponding ASN.1 type.
892             sub resolve_type {
893 0     0 0 0 my $self = shift;
894 0         0 my $type = shift;
895              
896             # a basic ASN.1 type.
897 0 0       0 return $type if $type =~ m/^(SEQUENCE|CHOICE|INTEGER|OCTET\ STRING|
898             OBJECT\ IDENTIFIER|NULL)$/ox;
899             # SMIv1 type
900 0 0       0 return $type if $type =~ m/^(IpAddress|Counter|Gauge|TimeTicks|Opaque)$/o;
901             # SMIv2 type
902 0 0       0 return $type if $type =~ m/^(Integer32|Counter32|Gauge32|Unsigned32|
903             Counter64)$/ox;
904 0 0       0 defined $self->{'types'}{$type} ?
    0          
905             defined $self->{'types'}{$type}{'syntax'} ?
906             $self->{'types'}{$type}{'syntax'}{'type'} :
907             $self->{'types'}{$type}{'type'} : $type;
908             }
909              
910             sub resolve_oid {
911 0     0 1 0 my $self = shift;
912 0         0 my $node = shift;
913              
914 0 0       0 return $node unless defined $node; # no node
915 0         0 return $node unless defined $self->{'nodes'}{$node} &&
916 0         0 scalar keys %{$self->{'nodes'}{$node}} ||
917             defined $self->{'root'}{$node} &&
918 0 0 0     0 scalar keys %{$self->{'root'}{$node}}; # no such node
      0        
      0        
919             # copy the OID if needed
920 0 0 0     0 if (defined $self->{'nodes'}{$node}{'oid'} &&
921             !defined $self->{'nodes'}{$node}{'OID'}) {
922 0         0 $self->{'nodes'}{$node}{'OID'} = [];
923 0         0 @{$self->{'nodes'}{$node}{'OID'}} = @{$self->{'nodes'}{$node}{'oid'}};
  0         0  
  0         0  
924             }
925 0   0     0 my $list = $self->{'nodes'}{$node}{'OID'} ||
926             $self->{'root'}{$node}{'oid'};
927 0   0     0 while (defined $self->{'nodes'}{$$list[0]} ||
928             defined $self->{'root'}{$$list[0]}) {
929             # copy the OID if needed
930 0 0 0     0 if (defined $self->{'nodes'}{$$list[0]} &&
      0        
931             defined $self->{'nodes'}{$$list[0]}{'oid'} &&
932             !defined $self->{'nodes'}{$$list[0]}{'OID'}) {
933 0         0 $self->{'nodes'}{$$list[0]}{'OID'} = [];
934 0         0 @{$self->{'nodes'}{$$list[0]}{'OID'}} =
  0         0  
935 0         0 @{$self->{'nodes'}{$$list[0]}{'oid'}};
936             }
937 0         0 my @l = @$list;
938 0 0       0 if (defined $self->{'nodes'}{$$list[0]}) {
939 0         0 my $eq = 1;
940 0 0       0 if ($#{$self->{'nodes'}{$$list[0]}{'OID'}} ==
  0         0  
  0         0  
941             $#{$self->{'nodes'}{$$list[0]}{'oid'}}) {
942 0         0 my $i = -1;
943 0         0 for (@{$self->{'nodes'}{$$list[0]}{'OID'}}) {
  0         0  
944 0         0 $i++;
945 0         0 $eq = 0, last unless $ {$self->{'nodes'}{$$list[0]}{'OID'}}[$i]
  0         0  
946 0 0       0 eq $ {$self->{'nodes'}{$$list[0]}{'oid'}}[$i];
947             }
948 0 0       0 unless ($eq) {
949 0         0 my @a = @{$self->{'nodes'}{$$list[0]}{'oid'}};
  0         0  
950 0         0 my @l = @{$self->{'nodes'}{$$list[0]}{'OID'}};
  0         0  
951 0         0 shift @l;
952 0         0 my $last = pop @l;
953 0         0 for my $elem (@l) {
954 0 0       0 last unless $elem =~ m/^\d+$/o;
955 0         0 my $o = shift @a;
956 0         0 $self->{'tree'}{$o}{$elem} = $a[0];
957             }
958 0 0       0 $self->{'tree'}{$a[0]}{$last} = $node if scalar @a == 1;
959             }
960             }
961             }
962             splice @$list, 0, 1, defined $self->{'nodes'}{$$list[0]} &&
963 0         0 scalar keys %{$self->{'nodes'}{$$list[0]}} ?
964 0         0 @{$self->{'nodes'}{$$list[0]}{'OID'}} :
965 0 0 0     0 @{$self->{'root'}{$$list[0]}{'oid'}};
966             }
967 0         0 for my $l (@$list) {
968 0 0       0 if (defined $self->{'nodes'}{$l}) {
969             # copy the OID if needed
970 0 0 0     0 if (defined $self->{'nodes'}{$l} &&
      0        
971             defined $self->{'nodes'}{$l}{'oid'} &&
972             !defined $self->{'nodes'}{$l}{'OID'}) {
973 0         0 $self->{'nodes'}{$l}{'OID'} = [];
974 0         0 @{$self->{'nodes'}{$l}{'OID'}} = @{$self->{'nodes'}{$l}{'oid'}};
  0         0  
  0         0  
975             }
976 0         0 my @t = @{$self->{'nodes'}{$l}{'OID'}};
  0         0  
977 0         0 $l = $t[$#t];
978             }
979 0 0       0 if (defined $self->{'root'}{$l}) {
980 0         0 my @t = @{$self->{'root'}{$l}{'OID'}};
  0         0  
981 0         0 $l = $t[$#t];
982             }
983             }
984 0         0 join '.', @$list;
985             }
986              
987             sub convert_oid {
988 0     0 1 0 my $self = shift;
989 0         0 my $oid = shift;
990              
991 0         0 my @l = split /\./, $oid;
992 0         0 my @r;
993 0         0 my $node = $l[0];
994 0         0 for my $id (keys %{$self->{'root'}}) {
  0         0  
995 0 0       0 last unless $l[0] =~ m/^\d+$/o;
996 0 0       0 $node = $id, last if $l[0] == $self->{'root'}{$id}{'oid'}[0];
997             }
998 0         0 shift @l;
999 0         0 push @r, $node;
1000 0         0 while (my $elem = shift @l) {
1001 0 0       0 push (@r, $elem), last unless defined $self->{'tree'}{$node}{$elem};
1002 0         0 push @r, $self->{'tree'}{$node}{$elem};
1003 0         0 $node = $self->{'tree'}{$node}{$elem};
1004             }
1005 0         0 join '.', @r, @l;
1006             }
1007              
1008             sub parse_one {
1009 30     30 0 36 my $self = shift;
1010              
1011 30 50       74 warn "DEBUG: Parsing one item...\n" if $self->{'debug_lexer'};
1012             # 1
1013             # -1..3
1014             # foo
1015             # foo..bar
1016 30 50       50 (my ($token, $value) = $self->get_token()) || return;
1017 30 50       77 if ($value eq '-') { # a negative value ?
1018 0 0       0 (($token, $value) = $self->get_token()) || return;
1019 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1020             "\"$value\" must be an integer") unless $token == $NUMBER;
1021 0         0 $value = "-$value";
1022             }
1023 30         37 my $val = $value;
1024 30 50       67 (($token, $value) = $self->get_token()) || return;
1025 30 100       68 if ($value eq '.') {
1026 8 50       29 $self->get_token('.') || return; # range
1027 8 50       22 (($token, $value) = $self->get_token()) || return;
1028 8 50       27 if ($value eq '-') { # a negative value ?
1029 0 0       0 (($token, $value) = $self->get_token()) || return;
1030 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1031             "\"$value\" must be an integer") unless $token == $NUMBER;
1032 0         0 $value = "-$value";
1033             }
1034 8         38 $val = { 'range' => { 'min' => $val, 'max' => $value } };
1035             }
1036             else {
1037 22         51 $self->unget_token();
1038             }
1039 30         67 $val;
1040             }
1041              
1042             sub parse_subtype {
1043 33     33 0 2551 my $self = shift;
1044              
1045 33 50       79 warn "DEBUG: Parsing a sub-type...\n" if $self->{'debug_lexer'};
1046 33 50       92 (my ($token, $value) = $self->get_token()) || return;
1047 33 100 66     185 if ($token && $value eq '(') {
    100 66        
1048 22 50       50 (($token, $value) = $self->get_token()) || return;
1049 22 100       53 if ($token == $SIZE) {
1050 1         7 my $subtype = $self->parse_subtype();
1051 1 50       4 return unless $subtype;
1052 1 50       3 $self->get_token(')') || return;
1053 1         6 return { 'size' => $subtype };
1054             }
1055             else {
1056 21         48 $self->unget_token();
1057 21         24 my $list;
1058 21         56 while ($value ne ')') {
1059 30         70 my $v = $self->parse_one();
1060 30 50       67 return unless defined $v;
1061 30         57 push @$list, $v;
1062 30 50       65 (($token, $value) = $self->get_token()) || return;
1063 30 50 66     149 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1064             "\"$value\" must be ')' or '|'")
1065             unless $value eq ')' || $value eq '|';
1066             }
1067             # return scalar @$list == 1 ? { 'value' => $$list[0] } :
1068             # { 'choice' => $list };
1069 21 100       94 return scalar @$list == 1 ? $$list[0] : { 'choice' => $list };
1070             }
1071             }
1072             elsif ($token && $value eq '{') {
1073 8         15 my $list = {};
1074 8         339 while ($value ne '}') {
1075 11 50       30 (($token, $value) = $self->get_token()) || return;
1076 11 50       26 if ($token == $IDENTIFIER) {
1077 11         48 my $res = $self->parse_subtype();
1078 11 50       29 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1079             "must have a subtype") unless defined $res;
1080 11         41 $$list{$res} = $value;
1081             }
1082             else {
1083 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1084             "should be an identifier");
1085             }
1086 11 50       27 (($token, $value) = $self->get_token()) || return;
1087 11 50 66     53 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1088             "must be a '}' or a ',' instead of '$value'")
1089             unless $value eq '}' || $value eq ',';
1090             }
1091 8         38 return { 'values' => $list };
1092             }
1093             else {
1094 3         9 $self->unget_token();
1095             }
1096             }
1097              
1098             # parse a type (SYNTAX field of an OBJECT-TYPE, TC)
1099             sub parse_type {
1100 10     10 0 15 my $self = shift;
1101              
1102 10 50       31 warn "DEBUG: Parsing a type...\n" if $self->{'debug_lexer'};
1103 10 50       26 (my ($token, $value) = $self->get_token()) || return;
1104 10 50 0     37 if ($token == $IMPLICIT) { # implicit types
    50 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1105 0         0 my $type = $self->parse_type();
1106 0         0 my $ref = ref $type;
1107 0 0 0     0 if (defined $ref && $ref eq 'HASH') {
1108 0         0 $$type{'implicit'} = 'true';
1109 0         0 return $type;
1110             }
1111             else {
1112 0         0 return { 'implicit' => 'true',
1113             'type' => $type };
1114             }
1115             }
1116             elsif ($token == $INTEGER) { # integers
1117 10         17 my $type = "INTEGER";
1118 10         35 my $subtype = $self->parse_subtype(); # what if parse_subtype failed ???
1119 10         25 my $ref = ref $subtype;
1120 10 100 66     62 if (defined $ref && $ref eq 'HASH') {
1121 9         22 $$subtype{'type'} = $type;
1122 9         22 return $subtype;
1123             }
1124             else {
1125 1 50       4 if (defined $subtype) {
1126 0         0 return { 'values' => $subtype,
1127             'type' => $type };
1128             }
1129             else {
1130 1         4 return { 'type' => $type };
1131             }
1132             }
1133             }
1134             elsif ($token == $OCTET) { # octet strings
1135 0 0       0 (($token, $value) = $self->get_token()) || return;
1136 0 0       0 if ($token == $STRING) {
1137 0         0 my $type = "OCTET STRING";
1138 0         0 my $subtype = $self->parse_subtype();
1139 0         0 $$subtype{'type'} = $type;
1140 0         0 return $subtype;
1141             }
1142             else {
1143 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1144             "parse error");
1145             }
1146             }
1147             elsif ($token == $OBJECT) { # object types
1148 0 0       0 (($token, $value) = $self->get_token()) || return;
1149 0 0       0 if ($token == $IDENTIFIER) {
1150 0         0 my $type = "OBJECT IDENTIFIER";
1151 0         0 my $subtype = $self->parse_subtype();
1152 0         0 $$subtype{'type'} = $type;
1153 0         0 return $subtype;
1154             }
1155             else {
1156 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1157             "parse error");
1158             }
1159             }
1160             elsif ($token == $NULL) {
1161 0         0 return { 'type' => "NULL" };
1162             }
1163             elsif ($token == $ANY && $self->{'allow_keyword_any'}) {
1164             # ANY is only valid in ASN.1.. but nor in SMI, nor SMIv2.
1165             # As it is used in RFC 1157, we must allow it :(
1166 0         0 return { 'type' => "ANY" };
1167             }
1168             elsif ($token == $CHOICE) { # choices
1169             # CHOICE { va ta, vb tb, vc tc }
1170 0 0       0 (($token, $value) = $self->get_token('{')) || return;
1171 0         0 my $list = {};
1172 0         0 while ($value ne '}') {
1173 0 0       0 (($token, $value) = $self->get_token()) || return;
1174 0         0 my $res = $self->parse_type();
1175 0         0 my $ref = ref $res;
1176 0 0 0     0 if (defined $ref && $ref eq 'HASH') {
1177 0         0 $$list{$value} = $res;
1178             }
1179             else {
1180 0         0 $$list{$value} = { 'type' => $res };
1181             }
1182 0 0       0 (($token, $value) = $self->get_token()) || return;
1183 0 0 0     0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1184             "must be a '}' or a ',' instead of '$value'")
1185             unless $value eq '}' || $value eq ',';
1186             }
1187 0         0 return { 'type' => 'CHOICE',
1188             'items' => $list };
1189             }
1190             elsif ($token == $SEQUENCE) { # sequence (of)
1191 0         0 my $list = {}; # Should we keep the order of the items (and then
1192             # use an array instead of a hash) ??
1193 0         0 my $subtype;
1194 0 0       0 (($token, $value) = $self->get_token()) || return;
1195 0 0       0 if ($value eq '(') {
1196 0         0 $self->unget_token();
1197 0         0 $subtype = $self->parse_subtype();
1198 0 0       0 (($token, $value) = $self->get_token()) || return;
1199             }
1200 0 0       0 if ($token == $OF) {
1201             # Small hack to obtain a name for this unique (?) item
1202 0 0       0 (my ($t1, $t2) = $self->get_token()) || return;
1203 0         0 $self->unget_token();
1204 0         0 $t2 = lc $t2;
1205              
1206 0         0 my $res = $self->parse_type();
1207 0         0 my $r = { 'type' => 'SEQUENCE' };
1208 0         0 $$r{'items'} = { $t2 => $res };
1209 0 0       0 if (defined $subtype) {
1210 0         0 map { $$r{$_} = $$subtype{$_} } keys %$subtype;
  0         0  
1211             }
1212 0         0 return $r;
1213             }
1214 0 0       0 if ($value eq '{') {
1215 0         0 my $list = {};
1216 0         0 while ($value ne '}') {
1217 0 0       0 (($token, $value) = $self->get_token()) || return;
1218 0         0 my $res;
1219 0 0       0 if ($token == $CHOICE) {
1220 0         0 $self->unget_token();
1221 0         0 $res = $self->parse_type();
1222             }
1223             else {
1224 0         0 $res = $self->parse_type();
1225             }
1226 0         0 my $ref = ref $res;
1227 0 0 0     0 if (defined $ref && $ref eq 'HASH') {
1228 0         0 $$list{$value} = $res;
1229             }
1230             else {
1231 0         0 return $self->assert(MIBERROR, $self->{'filename'},
1232             $self->{'lineno'}, "FATAL ERROR (please report)");
1233 0         0 $$list{$value} = { 'type' => $res };
1234             }
1235 0 0       0 (($token, $value) = $self->get_token()) || return;
1236 0 0 0     0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1237             "must be a '}' or a ',' instead of '$value'")
1238             unless $value eq '}' || $value eq ',';
1239             }
1240 0         0 return { 'type' => 'SEQUENCE',
1241             'items' => $list };
1242             }
1243             else {
1244 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1245             "fatal error");
1246             }
1247             }
1248             elsif ($value eq '[') { # tagged types
1249 0         0 my $list = [];
1250 0         0 while ($value ne ']') { # read the tag
1251 0 0       0 (($token, $value) = $self->get_token()) || return;
1252 0 0       0 push @$list, $value unless $value eq ']';
1253             }
1254 0         0 my $type = $self->parse_type();
1255 0         0 $$type{'tag'} = $list;
1256 0         0 return $type;
1257             }
1258             elsif ($value eq 'TEXTUAL-CONVENTION') { # textual convention
1259 0         0 return $self->parse_textualconvention();
1260             }
1261             elsif ($token == $IDENTIFIER || $token == $TYPEMODREFERENCE) {
1262 0         0 my $type = $value;
1263 0         0 my $subtype = $self->parse_subtype();
1264 0         0 $$subtype{'type'} = $type;
1265 0         0 return $subtype;
1266             }
1267             else {
1268 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1269             "Syntax error at '$value'");
1270             }
1271             }
1272              
1273             sub parse_textualconvention {
1274 0     0 0 0 my $self = shift;
1275 0         0 my $data;
1276              
1277 0 0       0 (my ($token, $value) = $self->get_token()) || return;
1278 0 0       0 if ($value eq 'DISPLAY-HINT') {
1279 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1280 0         0 $$data{'display-hint'} = $value;
1281 0 0       0 (($token, $value) = $self->get_token()) || return;
1282             }
1283 0 0       0 if ($value eq 'STATUS') {
1284 0 0       0 (($token, $value) = $self->get_token()) || return;
1285 0 0       0 if ($value =~ m/^(current|deprecated|obsolete)$/o) {
1286 0         0 $$data{'status'} = $value;
1287             }
1288             else {
1289 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1290             "unknown status ($value) for TEXTUAL-CONVENTION");
1291             }
1292 0 0       0 (($token, $value) = $self->get_token()) || return;
1293             }
1294             else {
1295 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1296             "Syntax error in TC: 'STATUS' requiered");
1297             }
1298 0 0       0 if ($value eq 'DESCRIPTION') {
1299 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1300 0         0 $$data{'description'} = $value;
1301 0 0       0 (($token, $value) = $self->get_token()) || return;
1302             }
1303             else {
1304 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1305             "Syntax error in TC: 'DESCRIPTION' requiered");
1306             }
1307 0 0       0 if ($value eq 'REFERENCE') {
1308 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1309 0         0 $$data{'reference'} = $value;
1310 0 0       0 (($token, $value) = $self->get_token()) || return;
1311             }
1312 0 0       0 if ($value eq 'SYNTAX') {
1313 0         0 my $type;
1314 0 0       0 (($token, $value) = $self->get_token()) || return;
1315 0 0       0 if ($value eq 'BITS') {
1316 0         0 $$type{'type'} = $value;
1317 0 0       0 $self->get_token('{') || return;
1318 0         0 while ($value ne '}') {
1319 0 0       0 (($token, $value) = $self->get_token()) || return;
1320 0         0 my $identifier = $value;
1321 0 0       0 $self->get_token('(') || return;
1322 0 0       0 (($token, $value) = $self->get_token('NUMBER')) || return;
1323 0         0 $$type{'values'}{$value} = $identifier;
1324 0 0       0 $self->get_token(')') || return;
1325             # should be ',' or ')'
1326 0 0       0 (($token, $value) = $self->get_token()) || return;
1327             }
1328             }
1329             else {
1330 0         0 $self->unget_token();
1331 0         0 $type = $self->parse_type;
1332             }
1333 0         0 $$data{'syntax'} = $type;
1334             }
1335             else {
1336 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1337             "Syntax error in TC: 'SYNTAX' requiered");
1338             }
1339 0         0 $data;
1340             }
1341              
1342             sub parse_objectidentity {
1343 0     0 0 0 my $self = shift;
1344 0         0 my $data;
1345              
1346 0         0 my ($token, $value);
1347 0 0       0 (($token, $value) = $self->get_token()) || return;
1348 0 0       0 if ($value eq 'STATUS') {
1349 0 0       0 (($token, $value) = $self->get_token()) || return;
1350 0 0       0 if ($value =~ m/^(current|deprecated|obsolete)$/o) {
1351 0         0 $$data{'status'} = $value;
1352             }
1353             else {
1354 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1355             "unknown status ($value) for OBJECT-IDENTITY");
1356             }
1357 0 0       0 (($token, $value) = $self->get_token()) || return;
1358             }
1359             else {
1360 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1361             "Syntax error. 'STATUS' needed");
1362             }
1363 0 0       0 if ($value eq 'DESCRIPTION') {
1364 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1365 0         0 $$data{'description'} = $value;
1366 0 0       0 (($token, $value) = $self->get_token()) || return;
1367             }
1368             else {
1369 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1370             "Syntax error. 'DESCRIPTION' needed");
1371             }
1372 0 0       0 if ($value eq 'REFERENCE') {
1373 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1374 0         0 $$data{'reference'} = $value;
1375 0 0       0 (($token, $value) = $self->get_token()) || return;
1376             }
1377 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1378             "Syntax error. '::=' needed") unless $token == $ASSIGNMENT;
1379 0         0 $$data{'oid'} = $self->parse_oid();
1380 0         0 $data;
1381             }
1382              
1383             # parse MODULE-IDENTITY macro (see RFC 1902)
1384             sub parse_moduleidentity {
1385 0     0 0 0 my $self = shift;
1386 0         0 my $data;
1387              
1388 0         0 my ($token, $value);
1389 0 0       0 (($token, $value) = $self->get_token()) || return;
1390 0 0       0 if ($value eq 'LAST-UPDATED') {
1391 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1392 0         0 $$data{'last-updated'} = $value;
1393 0 0       0 (($token, $value) = $self->get_token()) || return;
1394             }
1395             else {
1396 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1397             "Syntax error. 'LAST-UPDATED' needed");
1398             }
1399 0 0       0 if ($value eq 'ORGANIZATION') {
1400 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1401 0         0 $$data{'organization'} = $value;
1402 0 0       0 (($token, $value) = $self->get_token()) || return;
1403             }
1404             else {
1405 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1406             "Syntax error. 'ORGANIZATION' needed");
1407             }
1408 0 0       0 if ($value eq 'CONTACT-INFO') {
1409 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1410 0         0 $$data{'contact-info'} = $value;
1411 0 0       0 (($token, $value) = $self->get_token()) || return;
1412             }
1413             else {
1414 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1415             "Syntax error. 'CONTACT-INFO' needed");
1416             }
1417 0 0       0 if ($value eq 'DESCRIPTION') {
1418 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1419 0         0 $$data{'description'} = $value;
1420 0 0       0 (($token, $value) = $self->get_token()) || return;
1421             }
1422             else {
1423 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1424             "Syntax error. 'DESCRIPTION' needed");
1425             }
1426 0         0 while ($value eq 'REVISION') {
1427 0 0       0 $$data{'revision'} = [] unless defined $$data{'revision'};
1428 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1429 0         0 my $val = $value;
1430 0 0       0 (($token, $value) = $self->get_token()) || return;
1431 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1432             "Syntax error: found '$value', need 'DESCRIPTION'")
1433             unless $value eq 'DESCRIPTION';
1434 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1435 0         0 push @{$$data{'revision'}}, { 'revision' => $val,
  0         0  
1436             'description' => $value };
1437 0 0       0 (($token, $value) = $self->get_token()) || return;
1438             }
1439 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1440             "Syntax error. '::=' needed") unless $token == $ASSIGNMENT;
1441 0         0 $$data{'oid'} = $self->parse_oid();
1442 0         0 $data;
1443             }
1444              
1445             # parse NOTIFICATION-TYPE macro (see RFC 1902)
1446             sub parse_notificationtype {
1447 0     0 0 0 my $self = shift;
1448 0         0 my $data;
1449              
1450 0         0 my ($token, $value);
1451 0 0       0 (($token, $value) = $self->get_token()) || return;
1452 0 0       0 if ($value eq 'OBJECTS') {
1453 0         0 my $list = [];
1454 0 0       0 (($token, $value) = $self->get_token('{')) || return;
1455 0         0 while ($value ne '}') {
1456 0 0       0 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1457 0         0 push @$list, $value;
1458             # shoud be a ',' or a '}'
1459 0 0       0 (($token, $value) = $self->get_token()) || return;
1460             }
1461 0         0 $$data{'objects'} = $list;
1462 0 0       0 (($token, $value) = $self->get_token()) || return;
1463             }
1464 0 0       0 if ($value eq 'STATUS') {
1465 0 0       0 (($token, $value) = $self->get_token()) || return;
1466 0 0       0 if ($value =~ m/^(current|deprecated|obsolete)$/o) {
1467 0         0 $$data{'status'} = $value;
1468             }
1469             else {
1470 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1471             "unknown status ($value) for NOTIFICATION-TYPE");
1472             }
1473 0 0       0 (($token, $value) = $self->get_token()) || return;
1474             }
1475             else {
1476 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1477             "Syntax error. 'STATUS' needed");
1478             }
1479 0 0       0 if ($value eq 'DESCRIPTION') {
1480 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1481 0         0 $$data{'description'} = $value;
1482 0 0       0 (($token, $value) = $self->get_token()) || return;
1483             }
1484             else {
1485 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1486             "Syntax error. 'DESCRIPTION' needed");
1487             }
1488 0 0       0 if ($value eq 'REFERENCE') {
1489 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1490 0         0 $$data{'reference'} = $value;
1491 0 0       0 (($token, $value) = $self->get_token()) || return;
1492             }
1493 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1494             "Syntax error. '::=' needed") unless $token == $ASSIGNMENT;
1495 0         0 $$data{'oid'} = $self->parse_oid();
1496 0         0 $data;
1497             }
1498              
1499             # parse MODULE-COMPLIANCE macro (see RFC 1904)
1500             sub parse_modulecompliance {
1501 3     3 0 74 my $self = shift;
1502 3         7 my $data;
1503              
1504 3         6 my ($token, $value);
1505 3 50       7 (($token, $value) = $self->get_token()) || return;
1506 3         8 my $name = 'this';
1507 3 50       8 if ($value eq 'STATUS') {
1508 3 50       7 (($token, $value) = $self->get_token()) || return;
1509 3 50       22 if ($value =~ m/^(current|deprecated|obsolete)$/o) {
1510 3         8 $$data{'status'} = $value;
1511             }
1512             else {
1513 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1514             "unknown status ($value) for MODULE-COMPLIANCE");
1515             }
1516 3 50       10 (($token, $value) = $self->get_token()) || return;
1517             }
1518             else {
1519 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1520             "Syntax error. 'STATUS' needed");
1521             }
1522 3 50       11 if ($value eq 'DESCRIPTION') {
1523 3 50       10 (($token, $value) = $self->get_token('CSTRING')) || return;
1524 3         8 $$data{'description'} = $value;
1525 3 50       7 (($token, $value) = $self->get_token()) || return;
1526             }
1527             else {
1528 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1529             "Syntax error. 'DESCRIPTION' needed");
1530             }
1531 3 50       10 if ($value eq 'REFERENCE') {
1532 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1533 0         0 $$data{'reference'} = $value;
1534 0 0       0 (($token, $value) = $self->get_token()) || return;
1535             }
1536 3         9 while ($value eq 'MODULE') {
1537 5         7 $name = 'this';
1538 5 50       16 (($token, $value) = $self->get_token()) || return;
1539 5   100     55 while ($value ne 'MODULE' && $token != $ASSIGNMENT) {
1540 19 100       68 if ($value eq 'MANDATORY-GROUPS') {
    100          
    100          
    50          
1541 5         7 my $list = [];
1542 5 50       13 (($token, $value) = $self->get_token('{')) || return;
1543 5         16 while ($value ne '}') {
1544 9 50       21 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1545 9         15 push @$list, $value;
1546             # shoud be a ',' or a '}'
1547 9 50       19 (($token, $value) = $self->get_token()) || return;
1548             }
1549 5         25 $$data{'module'}{$name}{'mandatory-groups'} = $list;
1550             }
1551             elsif ($value eq 'GROUP') {
1552 2 50       4 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1553 2         2 my $val = $value;
1554 2 50       6 (($token, $value) = $self->get_token()) || return;
1555 2 50       7 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1556             "Syntax error: found '$value', need 'DESCRIPTION'")
1557             unless $value eq 'DESCRIPTION';
1558 2 50       12 (($token, $value) = $self->get_token('CSTRING')) || return;
1559 2         11 $$data{'module'}{$name}{'group'}{$val} = $value;
1560             }
1561             elsif ($value eq 'OBJECT') {
1562 10 50       23 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1563 10         16 my $val = $value;
1564 10 50       23 (($token, $value) = $self->get_token()) || return;
1565 10 100       25 if ($value eq 'SYNTAX') {
1566 5         16 my $type = $self->parse_type();
1567 5         23 $$data{'module'}{$name}{'object'}{$val}{'syntax'} = $type;
1568 5 50       12 (($token, $value) = $self->get_token()) || return;
1569             }
1570 10 50       25 if ($value eq 'WRITE-SYNTAX') {
1571 0         0 my $type = $self->parse_type();
1572 0         0 $$data{'module'}{$name}{'object'}{$val}{'write-syntax'} = $type;
1573 0 0       0 (($token, $value) = $self->get_token()) || return;
1574             }
1575 10 50       18 if ($value eq 'MIN-ACCESS') {
1576 10 50       21 (($token, $value) = $self->get_token()) || return;
1577 10 50       52 if ($value =~ m/^(read-(only|write|create)|not-accessible|
1578             accessible-for-notify)$/ox) {
1579 10         51 $$data{'module'}{$name}{'object'}{$val}{'min-access'} = $value;
1580             }
1581             else {
1582 0         0 return $self->assert(MIBERROR, $self->{'filename'},
1583             $self->{'lineno'}, "Unknown MIN-ACCESS type ($value)");
1584             }
1585 10 50       23 (($token, $value) = $self->get_token()) || return;
1586             }
1587 10 50       28 if ($value eq 'DESCRIPTION') {
1588 10 50       32 (($token, $value) = $self->get_token('CSTRING')) || return;
1589 10         39 $$data{'module'}{$name}{'object'}{$val}{'description'} = $value;
1590 10 50       21 (($token, $value) = $self->get_token()) || return;
1591             }
1592 10         27 $self->unget_token();
1593             }
1594             elsif ($token == $TYPEMODREFERENCE) {
1595             # Modulename
1596 2         4 $name = $value;
1597 2 50       8 (($token, $value) = $self->get_token()) || return;
1598 2 50       9 if ($token == $IDENTIFIER) { # ModuleIdentifier
1599 0         0 $$data{'module'}{$name}{'identifier'} = $value;
1600             }
1601             else {
1602 2         8 $self->unget_token();
1603             }
1604             }
1605             else {
1606 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1607             "Syntax error at '$value'");
1608             }
1609 19 50       42 (($token, $value) = $self->get_token()) || return;
1610             }
1611             }
1612 3 50       10 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1613             "Syntax error. '::=' needed") unless $token == $ASSIGNMENT;
1614 3         14 $$data{'oid'} = $self->parse_oid();
1615 3         15 $data;
1616             }
1617              
1618             # parse OBJECT-GROUP macro (see RFC 1904)
1619             sub parse_objectgroup {
1620 0     0 0 0 my $self = shift;
1621 0         0 my $data;
1622              
1623 0         0 my ($token, $value);
1624 0 0       0 (($token, $value)= $self->get_token()) || return;
1625 0 0       0 if ($value eq 'OBJECTS') {
1626 0         0 my $list = [];
1627 0         0 (($token, $value) = $self->get_token('{'));
1628 0         0 while ($value ne '}') {
1629 0 0       0 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1630 0         0 push @$list, $value;
1631             # shoud be a ',' or a '}'
1632 0 0       0 (($token, $value) = $self->get_token()) || return;
1633             }
1634 0         0 $$data{'objects'} = $list;
1635 0 0       0 (($token, $value) = $self->get_token()) || return;
1636             }
1637             else {
1638 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1639             "Syntax error. 'OBJECTS' needed");
1640             }
1641 0 0       0 if ($value eq 'STATUS') {
1642 0 0       0 (($token, $value) = $self->get_token()) || return;
1643 0 0       0 if ($value =~ m/^(current|deprecated|obsolete)$/o) {
1644 0         0 $$data{'status'} = $value;
1645             }
1646             else {
1647 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1648             "unknown status ($value) for OBJECT-GROUP");
1649             }
1650 0 0       0 (($token, $value) = $self->get_token()) || return;
1651             }
1652             else {
1653 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1654             "Syntax error. 'STATUS' needed");
1655             }
1656 0 0       0 if ($value eq 'DESCRIPTION') {
1657 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1658 0         0 $$data{'description'} = $value;
1659 0 0       0 (($token, $value) = $self->get_token()) || return;
1660             }
1661             else {
1662 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1663             "Syntax error. 'DESCRIPTION' needed");
1664             }
1665 0 0       0 if ($value eq 'REFERENCE') {
1666 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1667 0         0 $$data{'reference'} = $value;
1668 0 0       0 (($token, $value) = $self->get_token()) || return;
1669             }
1670 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1671             "Syntax error. '::=' needed") unless $token == $ASSIGNMENT;
1672 0         0 $$data{'oid'} = $self->parse_oid();
1673 0         0 $data;
1674             }
1675              
1676             # parse NOTIFICATION-GROUP macro (see RFC 1904)
1677             sub parse_notificationgroup {
1678 0     0 0 0 my $self = shift;
1679 0         0 my $data;
1680              
1681 0         0 my ($token, $value);
1682 0 0       0 (($token, $value) = $self->get_token()) || return;
1683 0 0       0 if ($value eq 'NOTIFICATIONS') {
1684 0         0 my $list = [];
1685 0 0       0 (($token, $value) = $self->get_token('{')) || return;
1686 0         0 while ($value ne '}') {
1687 0 0       0 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1688 0         0 push @$list, $value;
1689             # shoud be a ',' or a '}'
1690 0 0       0 (($token, $value) = $self->get_token()) || return;
1691             }
1692 0         0 $$data{'NOTIFICATIONS'} = $list;
1693 0 0       0 (($token, $value) = $self->get_token()) || return;
1694             }
1695             else {
1696 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1697             "Syntax error. 'NOTIFICATIONS' needed");
1698             }
1699 0 0       0 if ($value eq 'STATUS') {
1700 0 0       0 (($token, $value) = $self->get_token()) || return;
1701 0 0       0 if ($value =~ m/^(current|deprecated|obsolete)$/o) {
1702 0         0 $$data{'status'} = $value;
1703             }
1704             else {
1705 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1706             "unknown status ($value) for NOTIFICATION-GROUP");
1707             }
1708 0 0       0 (($token, $value) = $self->get_token()) || return;
1709             }
1710             else {
1711 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1712             "Syntax error. 'STATUS' needed");
1713             }
1714 0 0       0 if ($value eq 'DESCRIPTION') {
1715 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1716 0         0 $$data{'description'} = $value;
1717 0 0       0 (($token, $value) = $self->get_token()) || return;
1718             }
1719             else {
1720 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1721             "Syntax error. 'DESCRIPTION' needed");
1722             }
1723 0 0       0 if ($value eq 'REFERENCE') {
1724 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1725 0         0 $$data{'reference'} = $value;
1726 0 0       0 (($token, $value) = $self->get_token()) || return;
1727             }
1728 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1729             "Syntax error. '::=' needed") unless $token == $ASSIGNMENT;
1730 0         0 $$data{'oid'} = $self->parse_oid();
1731 0         0 $data;
1732             }
1733              
1734             sub parse_agentcapabilities {
1735 1     1 0 8 my $self = shift;
1736 1         2 my $data;
1737              
1738 1         2 my $name = 'this';
1739 1         2 my ($token, $value);
1740 1         3 (($token, $value) = $self->get_token());
1741 1 50       5 return unless $token;
1742             # "PRODUCT-RELEASE" Text
1743 1 50       3 if ($value eq 'PRODUCT-RELEASE') {
1744 1 50       4 (($token, $value) = $self->get_token('CSTRING')) || return;
1745 1         4 $$data{'product-release'} = $value;
1746 1 50       4 (($token, $value) = $self->get_token()) || return;
1747             }
1748             else {
1749 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1750             "Syntax error. 'PRODUCT-RELEASE' needed");
1751             }
1752             # "STATUS" Status
1753 1 50       8 if ($value eq 'STATUS') {
1754 1 50       4 (($token, $value) = $self->get_token()) || return;
1755 1 50       7 if ($value =~ m/^(current|obsolete)$/o) {
1756 1         4 $$data{'status'} = $value;
1757 1 50       4 (($token, $value) = $self->get_token()) || return;
1758             }
1759             else {
1760 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1761             "unknown status ($value) for AGENT-CAPABILITIES");
1762             }
1763             }
1764             else {
1765 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1766             "Syntax error. 'STATUS' needed");
1767             }
1768             # "DESCRIPTION" Text
1769 1 50       4 if ($value eq 'DESCRIPTION') {
1770 1 50       4 (($token, $value) = $self->get_token('CSTRING')) || return;
1771 1         4 $$data{'description'} = $value;
1772 1 50       3 (($token, $value) = $self->get_token()) || return;
1773             }
1774             else {
1775 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1776             "Syntax error. 'DESCRIPTION' needed");
1777             }
1778             # ReferPart
1779 1 50       4 if ($value eq 'REFERENCE') {
1780 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1781 0         0 $$data{'reference'} = $value;
1782 0 0       0 (($token, $value) = $self->get_token()) || return;
1783             }
1784             # ModulePart
1785 1   66     10 while (defined $token && $token != $ASSIGNMENT) {
1786 7   66     47 while (defined $token && $value ne 'SUPPORTS' && $token != $ASSIGNMENT) {
      100        
1787 6 50       15 if ($value eq 'INCLUDES') {
1788 6         8 my $list = [];
1789 6 50       14 (($token, $value) = $self->get_token('{')) || return;
1790 6         16 while ($value ne '}') {
1791 12 50       25 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1792 12         23 push @$list, $value;
1793             # shoud be a ',' or a '}'
1794 12 50       33 (($token, $value) = $self->get_token()) || return;
1795             }
1796 6         23 $$data{'supports'}{$name}{'includes'} = $list;
1797 6 50       42 (($token, $value) = $self->get_token()) || return
1798             }
1799 6         20 while ($value eq 'VARIATION') {
1800 8 50       18 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1801 8         11 my $val = $value; # ObjectName or NotificationName
1802 8 50       18 (($token, $value) = $self->get_token()) || return;
1803 8 100       21 if ($value eq 'SYNTAX') {
1804 3         19 my $type = $self->parse_type();
1805 3         14 $$data{'supports'}{$name}{'variation'}{$val}{'syntax'} = $type;
1806 3 50       6 (($token, $value) = $self->get_token()) || return;
1807             }
1808 8 50       18 if ($value eq 'WRITE-SYNTAX') {
1809 0         0 my $type = $self->parse_type();
1810 0         0 $$data{'supports'}{$name}{'variation'}{$val}{'write-syntax'} = $type;
1811 0 0       0 (($token, $value) = $self->get_token()) || return;
1812             }
1813 8 100       18 if ($value eq 'ACCESS') {
1814 2 50       34 (($token, $value) = $self->get_token()) || return;
1815 2 50       15 if ($value =~ m/^(not-implemented|accessible-for-notify|
1816             read-(only|write|create)|write-only)$/ox) {
1817 2         12 $$data{'supports'}{$name}{'variation'}{$val}{'access'} = $value;
1818             }
1819             else {
1820 0         0 return $self->assert(MIBERROR, $self->{'filename'},
1821             $self->{'lineno'}, "Unknown ACCESS type ($value)");
1822             }
1823 2 50       7 (($token, $value) = $self->get_token()) || return;
1824             }
1825 8 100       20 if ($value eq 'CREATION-REQUIRES') {
1826 2         4 my $list = [];
1827 2 50       7 (($token, $value) = $self->get_token('{')) || return;
1828 2         8 while ($value ne '}') {
1829 2 50       6 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1830 2         5 push @$list, $value;
1831             # shoud be a ',' or a '}'
1832 2 50       6 (($token, $value) = $self->get_token()) || return;
1833             }
1834 2         11 $$data{'supports'}{$name}{'variation'}{$val}{'creation-requires'} =
1835             $list;
1836 2 50       5 (($token, $value) = $self->get_token()) || return;
1837             }
1838 8 50       16 if ($value eq 'DEFVAL') {
1839 0 0       0 (($token, $value) = $self->get_token('{')) || return;
1840 0 0       0 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1841 0         0 $$data{'supports'}{$name}{'variation'}{$val}{'defval'} = $value;
1842 0 0       0 (($token, $value) = $self->get_token('}')) || return;
1843 0 0       0 (($token, $value) = $self->get_token()) || return;
1844             }
1845 8 50       19 if ($value eq 'DESCRIPTION') {
1846 8 50       18 (($token, $value) = $self->get_token('CSTRING')) || return;
1847 8         34 $$data{'supports'}{$name}{'variation'}{$val}{'description'} = $value;
1848 8 50       17 (($token, $value) = $self->get_token()) || return;
1849             }
1850             else {
1851 0         0 return $self->assert(MIBERROR, $self->{'filename'},
1852             $self->{'lineno'}, "Syntax error. 'DESCRIPTION' needed");
1853             }
1854             }
1855             }
1856 7 100       17 if ($value eq 'SUPPORTS') {
1857             # Modulename
1858 6 50       13 (($token, $value) = $self->get_token()) || return;
1859 6         9 $name = $value;
1860 6 50       16 (($token, $value) = $self->get_token()) || return;
1861 6 50       14 if ($token == $IDENTIFIER) { # ModuleIdentifier
1862 0         0 $$data{'module'}{$name}{'identifier'} = $value;
1863             }
1864             else {
1865 6         16 $self->unget_token();
1866             }
1867             }
1868 7 100 50     24 (($token, $value) = $self->get_token()) || return
1869             unless $token == $ASSIGNMENT;
1870             }
1871 1         7 $$data{'oid'} = $self->parse_oid();
1872 1         7 $data;
1873             }
1874              
1875             # Parse TRAP-TYPE macro (see RFC 1215)
1876             sub parse_traptype {
1877 0     0 0 0 my $self = shift;
1878 0         0 my $data;
1879              
1880 0         0 my ($token, $value);
1881 0 0       0 (($token, $value) = $self->get_token()) || return;
1882 0 0       0 if ($value eq 'ENTERPRISE') {
1883 0 0       0 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1884 0         0 $$data{'enterprise'} = $value;
1885 0 0       0 (($token, $value) = $self->get_token()) || return;
1886             }
1887             else {
1888 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1889             "Syntax error. 'ENTERPRISE' needed");
1890             }
1891 0 0       0 if ($value eq 'VARIABLES') {
1892 0         0 my $list = [];
1893 0 0       0 (($token, $value) = $self->get_token('{')) || return;
1894 0         0 while ($value ne '}') {
1895 0 0       0 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
1896 0         0 push @$list, $value;
1897             # shoud be a ',' or a '}'
1898 0 0       0 (($token, $value) = $self->get_token()) || return;
1899             }
1900 0         0 $$data{'variables'} = $list;
1901 0 0       0 (($token, $value) = $self->get_token()) || return;
1902             }
1903 0 0       0 if ($value eq 'DESCRIPTION') {
1904 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1905 0         0 $$data{'description'} = $value;
1906 0 0       0 (($token, $value) = $self->get_token()) || return;
1907             }
1908 0 0       0 if ($value eq 'REFERENCE') {
1909 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1910 0         0 $$data{'reference'} = $value;
1911 0 0       0 (($token, $value) = $self->get_token()) || return;
1912             }
1913 0 0       0 if ($token == $ASSIGNMENT) {
1914 0 0       0 (my $value = $self->get_token('NUMBER')) || return;
1915 0         0 $$data{'value'} = $value;
1916             }
1917             else {
1918 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1919             "Should be '::='instead of '$value'");
1920             }
1921 0         0 $data;
1922             }
1923              
1924             # parse OBJECT-TYPE macro (see RFC 1902)
1925             sub parse_objecttype {
1926 2     2 0 4 my $self = shift;
1927 2         3 my $data;
1928              
1929 2         4 my ($token, $value);
1930 2 50       5 (($token, $value) = $self->get_token()) || return;
1931 2 50       8 if ($value eq 'SYNTAX') {
1932 2         3 my $syntax = {};
1933 2         4 my $type;
1934 2 50       6 (($token, $value) = $self->get_token()) || return;
1935 2 50 33     13 if ($self->{'accept_smiv2'} && $value eq 'BITS') {
1936 0         0 $$type{'type'} = $value;
1937 0 0       0 $self->get_token('{') || return;
1938 0         0 while ($value ne '}') {
1939 0 0       0 (($token, $value) = $self->get_token()) || return;
1940 0         0 my $identifier = $value;
1941 0 0       0 $self->get_token('(') || return;
1942 0 0       0 (($token, $value) = $self->get_token('NUMBER')) || return;
1943 0         0 $$type{'values'}{$value} = $identifier;
1944 0 0       0 $self->get_token(')') || return;
1945             # should be ',' or ')'
1946 0 0       0 (($token, $value) = $self->get_token()) || return;
1947             }
1948             }
1949             else {
1950 2         7 $self->unget_token();
1951 2         9 $type = $self->parse_type;
1952             }
1953 2         6 my $subtype = $self->parse_subtype();
1954 2         7 my $ref = ref $type;
1955 2 50 33     13 if (defined $ref && $ref eq 'HASH') {
1956 2         9 for my $key (keys %$type) {
1957 3         10 $$syntax{$key} = $$type{$key};
1958             }
1959             }
1960             else { # should not happen
1961 0         0 $$syntax{'type'} = $type;
1962             }
1963 2 50       6 if ($subtype) {
1964 0         0 for my $key (keys %$subtype) {
1965 0         0 $$syntax{$key} = $$subtype{$key};
1966             }
1967             }
1968 2         6 $$data{'syntax'} = $syntax;
1969 2 50       6 (($token, $value) = $self->get_token()) || return;
1970             }
1971             else {
1972 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1973             "'SYNTAX' needed");
1974             }
1975 2 50 33     29 if ($self->{'accept_smiv2'} && $value eq 'UNITS') {
1976 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
1977 0         0 $$data{'units'} = $value;
1978 0 0       0 (($token, $value) = $self->get_token()) || return;
1979             }
1980 2 50 33     11 if ($value eq 'ACCESS' || $value eq 'MAX-ACCESS') {
1981 2 50       6 if ($value eq 'MAX-ACCESS') {
1982 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1983             "Syntax error at $value") unless $self->{'accept_smiv2'};
1984 0 0       0 (($token, $value) = $self->get_token()) || return;
1985 0 0       0 if ($value =~ m/^(read-(only|write)|not-accessible|
1986             accessible-for-notify|read-create)$/ox) {
1987             # Valid SMIv2 acces type (rfc 1902, draft-ops-smiv2-smi-01)
1988 0         0 $$data{'access'} = $value;
1989             }
1990             else {
1991 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1992             "Unknown acces type ($value)");
1993             }
1994             }
1995             else { # 'ACCESS'
1996 2 50       7 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
1997             "Syntax error at $value") unless $self->{'accept_smiv1'};
1998 2 50       5 (($token, $value) = $self->get_token()) || return;
1999 2 50       16 if ($value =~ m/^(read-(only|write)|write-only|not-accessible)$/o) {
2000             # Valid SMIv1 acces type (rfc 1155, rfc 1212)
2001 2         7 $$data{'access'} = $value;
2002             }
2003             else {
2004 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2005             "Unknown acces type ($value)");
2006             }
2007             }
2008 2 50       6 (($token, $value) = $self->get_token()) || return;
2009             }
2010             else {
2011 0 0 0     0 if ($self->{'accept_smiv1'} && !$self->{'accept_smiv2'}) {
    0 0        
2012 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2013             "Syntax error. 'ACCESS' needed");
2014             }
2015             elsif (!$self->{'accept_smiv1'} && $self->{'accept_smiv2'}) {
2016 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2017             "Syntax error. 'MAX-ACCESS' needed");
2018             }
2019             else {
2020 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2021             "Syntax error. 'ACCESS' or 'MAX-ACCESS' needed");
2022             }
2023             }
2024 2 50       7 if ($value eq 'STATUS') {
2025 2 50       5 (($token, $value) = $self->get_token()) || return;
2026 2 50 33     21 if ($self->{'accept_smiv1'} &&
    0 0        
2027             $value =~ m/^(mandatory|optional|obsolete|deprecated)$/o) {
2028             # Valid SMIv1 status (rfc 1155)
2029             # add 'deprecated' (rfc 1158, rfc 1212)
2030 2         5 $$data{'status'} = $value;
2031             }
2032             elsif ($self->{'accept_smiv2'} &&
2033             $value =~ m/^(current|obsolete|deprecated)$/o) {
2034             # Valid SMIv2 status (rfc 1902, draft-ops-smiv2-smi-01)
2035 0         0 $$data{'status'} = $value;
2036             }
2037             else {
2038 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2039             "Unknown status ($value)");
2040             }
2041 2 50       6 (($token, $value) = $self->get_token()) || return;
2042             }
2043             else {
2044 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2045             "Syntax error. 'STATUS' needed");
2046             }
2047 2 50       7 if ($value eq 'DESCRIPTION') {
2048 2 50       7 (($token, $value) = $self->get_token('CSTRING')) || return;
2049 2         6 $$data{'description'} = $value;
2050 2 50       13 (($token, $value) = $self->get_token()) || return;
2051             }
2052             else {
2053 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2054             "Syntax error. 'STATUS' needed") unless $self->{'accept_smiv1'};
2055             }
2056 2 50       8 if ($value eq 'REFERENCE') {
2057 0 0       0 (($token, $value) = $self->get_token('CSTRING')) || return;
2058 0         0 $$data{'reference'} = $value;
2059 0 0       0 (($token, $value) = $self->get_token()) || return;
2060             }
2061 2 50       5 if ($value eq 'INDEX') {
2062 0         0 my $list = [];
2063 0 0       0 (($token, $value) = $self->get_token('{')) || return;
2064 0         0 while ($value ne '}') {
2065 0 0       0 (($token, $value) = $self->get_token()) || return;
2066 0         0 my $implied = 0;
2067 0 0       0 if ($value eq 'IMPLIED') {
2068 0         0 $implied++;
2069 0         0 (($token, $value) = $self->get_token('IDENTIFIER'));
2070             }
2071 0         0 push @$list, { 'value' => $value, 'implied' => $implied };
2072             # shoud be a ',' or a '}'
2073 0 0       0 (($token, $value) = $self->get_token()) || return;
2074             }
2075 0         0 $$data{'index'} = $list;
2076 0 0       0 (($token, $value) = $self->get_token()) || return;
2077             }
2078 2 50 33     9 if ($value eq 'AUGMENTS' && $self->{'accept_smiv2'}) {
2079 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2080             "Can't define both 'INDEX' and 'AUGMENTS'") if defined $$data{'index'};
2081 0 0       0 $self->get_token('{') || return;
2082 0 0       0 (($token, $value) = $self->get_token('IDENTIFIER')) || return;
2083 0         0 $$data{'augments'} = $value;
2084 0 0       0 $self->get_token('}') || return;
2085 0 0       0 (($token, $value) = $self->get_token()) || return;
2086             }
2087 2 50       6 if ($value eq 'DEFVAL') {
2088             # SMIv1: rfc 1212
2089             # SMIv2: rfc 1902
2090 0 0       0 $self->get_token('{') || return;
2091 0 0       0 (($token, $value) = $self->get_token()) || return;
2092 0 0       0 if ($value eq '-') {
2093 0 0       0 (($token, $value) = $self->get_token()) || return;
2094 0         0 $value = "-" . $value;
2095             }
2096 0 0       0 $self->get_token('}') || return;
2097 0         0 $$data{'defval'} = $value;
2098 0 0       0 (($token, $value) = $self->get_token()) || return;
2099             }
2100 2 50       8 if ($token == $ASSIGNMENT) {
2101 2         8 my $oid = $self->parse_oid();
2102 2         11 $$data{'oid'} = $oid;
2103             }
2104             else {
2105 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2106             "should be ::=");
2107             }
2108 2         11 $data;
2109             }
2110              
2111             # parse an OBJECT IDENTIFIER clause
2112             # note: everything except the value has already been parsed.
2113             sub parse_oid {
2114 6     6 0 16 my $self = shift;
2115             #
2116             # internet OBJECT IDENTIFIER ::= { iso org(3) dod(6) 1 }
2117             # mgmt OBJECT IDENTIFIER ::= { internet 2 }
2118             # ^^^^^^^^^^^^^^^^^^^^^^^
2119             #
2120 6         10 my ($list, $old, $old2);
2121 6 50       18 $self->get_token('{') || return;
2122 6         13 my ($token, $value);
2123 6 50       14 (($token, $value) = $self->get_token()) || return;
2124 6   66     46 while (defined $token && $value ne '}') {
2125 12 50 66     51 if ($token == $IDENTIFIER ||
    0          
2126             $token == $NUMBER) {
2127 12         31 push @$list, $value;
2128 12         14 $old2 = $old;
2129 12         19 $old = $value;
2130             }
2131             elsif ($value eq '(') {
2132 0 0 0     0 if ($old2 && $old) {
2133 0 0       0 (($token, $value) = $self->get_token('NUMBER')) || return;
2134 0 0       0 $self->get_token(')') || return;
2135             # Add this to the tree
2136 0         0 $self->{'nodes'}{$old}{'oid'} = [ $old2, $value ];
2137             }
2138             else {
2139             # These syntaxes are incorrect:
2140             # { iso(1) ...}
2141             # { (1) ... }
2142 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2143             "Syntax error");
2144             }
2145             }
2146             else {
2147 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2148             "Syntax error");
2149             }
2150 12 50       47 (($token, $value) = $self->get_token()) || return;
2151             }
2152 6         22 $list;
2153             }
2154              
2155             # parse an IMPORTS clause.
2156             # note: the 'IMPORTS' keyword has already been parsed.
2157             sub parse_imports {
2158 0     0 0 0 my $self = shift;
2159             #
2160             # IMPORT a, b, c FROM mib-foo
2161             # d, e, f, g FROM mib-bar;
2162             #
2163 0         0 my ($list, $data);
2164 0         0 my $elem = 0;
2165 0         0 my ($token, $value);
2166 0 0       0 (($token, $value) = $self->get_token()) || return;
2167 0   0     0 while (defined $token && $value ne ';') {
2168 0 0 0     0 if ($token == $IDENTIFIER ||
    0          
    0          
2169             $token == $TYPEMODREFERENCE) {
2170 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2171             "two values must be separated by a comma") if $elem;
2172 0         0 push @$list, $value;
2173 0         0 $elem = 1;
2174             }
2175             elsif ($value eq ',') {
2176 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2177             "value expected. ',' found") unless $elem;
2178 0         0 $elem = 0;
2179             }
2180             elsif ($token == $FROM) {
2181 0         0 $elem = 0;
2182 0         0 my $oldvalue = $value;
2183 0 0       0 (($token, $value) = $self->get_token()) || return;
2184 0 0 0     0 if ($token == $IDENTIFIER ||
2185             $token == $TYPEMODREFERENCE) {
2186 0         0 my @l;
2187 0 0       0 @l = @{$$data{$value}} if defined $$data{$value};
  0         0  
2188 0         0 push @l, @$list;
2189 0         0 $$data{$value} = \@l;
2190 0         0 undef $list;
2191             }
2192             else {
2193 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2194             "identifier expected after '$oldvalue'");
2195             }
2196              
2197             }
2198             else {
2199 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2200             "syntax error while parsing IMPORTS clause");
2201             }
2202 0 0       0 (($token, $value) = $self->get_token()) || return;
2203             }
2204 0         0 $data;
2205             }
2206              
2207             # parse an EXPORTS clause.
2208             # note: the 'EXPORTS' keyword has already been parsed.
2209             sub parse_exports {
2210 0     0 0 0 my $self = shift;
2211             #
2212             # EXPORTS a, b, c;
2213             #
2214 0         0 my $list;
2215 0         0 my $elem = 0;
2216 0         0 my ($token, $value);
2217 0 0       0 (($token, $value) = $self->get_token()) || return;
2218 0   0     0 while (defined $token && $value ne ';') {
2219 0 0 0     0 if ($token == $IDENTIFIER ||
    0          
2220             $token == $TYPEMODREFERENCE) {
2221 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2222             "two values must be separated by a comma") if $elem;
2223 0         0 push @$list, $value;
2224 0         0 $elem = 1;
2225             }
2226             elsif ($value eq ',') {
2227 0 0       0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2228             "value expected. ',' found") unless $elem;
2229 0         0 $elem = 0;
2230             }
2231             else {
2232 0         0 return $self->assert(MIBERROR, $self->{'filename'}, $self->{'lineno'},
2233             "syntax error while parsing EXPORTS clause");
2234             }
2235 0 0       0 (($token, $value) = $self->get_token()) || return;
2236             }
2237 0         0 $list;
2238             }
2239              
2240             sub import_modules {
2241 0     0 0 0 my $self = shift;
2242              
2243 0         0 for my $k (keys %{$self->{'imports'}}) {
  0         0  
2244 0 0       0 warn "DEBUG: importing $k...\n" if $self->{'debug_lexer'};
2245 0         0 my $mib = new SNMP::MIB::Compiler();
2246 0         0 $mib->repository($self->repository);
2247 0         0 $mib->extensions($self->extensions);
2248 0         0 $mib->{'srcpath'} = $self->{'srcpath'};
2249              
2250 0         0 $mib->{'make_dump'} = $self->{'make_dump'};
2251 0         0 $mib->{'use_dump'} = $self->{'use_dump'};
2252 0         0 $mib->{'do_imports'} = $self->{'do_imports'};
2253              
2254 0         0 $mib->{'allow_underscore'} = $self->{'allow_underscore'};
2255 0         0 $mib->{'allow_lowcase_hstrings'} = $self->{'allow_lowcase_hstrings'};
2256 0         0 $mib->{'allow_lowcase_bstrings'} = $self->{'allow_lowcase_bstrings'};
2257              
2258 0 0       0 if ($self->{'debug_recursive'}) {
2259 0         0 $mib->{'debug_recursive'} = $self->{'debug_recursive'};
2260 0         0 $mib->{'debug_lexer'} = $self->{'debug_lexer'};
2261             }
2262 0 0       0 $mib->load($k) || $mib->compile($k);
2263 0         0 for my $item (@{$self->{'imports'}{$k}}) {
  0         0  
2264 0 0       0 warn "DEBUG: importing symbol $item from $k for $self->{'name'}...\n"
2265             if $self->{'debug_lexer'};
2266 0 0       0 if (defined $mib->{'nodes'}{$item}) {
    0          
2267             # resolve OID to break the dependencies
2268 0         0 my @a = split /\./, $mib->convert_oid($mib->resolve_oid($item));
2269 0         0 my @l = @{$mib->{'nodes'}{$item}{'OID'}};
  0         0  
2270 0         0 $a[$#a] = $l[$#l];
2271 0         0 @{$mib->{'nodes'}{$item}{'oid'}} = @a;
  0         0  
2272 0         0 shift @l;
2273 0         0 my $last = pop @l;
2274 0         0 for my $elem (@l) {
2275 0 0       0 last unless $elem =~ m/^\d+$/o;
2276 0         0 my $o = shift @a;
2277 0         0 $self->{'tree'}{$o}{$elem} = $a[0];
2278             }
2279 0 0       0 $self->{'tree'}{$a[0]}{$last} = $item if scalar @a == 1;
2280 0         0 $self->{'nodes'}{$item} = $mib->{'nodes'}{$item};
2281             }
2282             elsif (defined $mib->{'types'}{$item}) {
2283 0         0 $self->{'types'}{$item} = $mib->{'types'}{$item};
2284             }
2285             else {
2286 0         0 my $found = 0;
2287 0         0 for my $macro (@{$mib->{'macros'}}) {
  0         0  
2288 0 0       0 $found++, push (@{$self->{'macros'}}, $item) if $macro eq $item;
  0         0  
2289             }
2290 0 0       0 $self->assert(MIBWARN, $self->{'filename'}, $self->{'lineno'},
2291             "can't find '$item' in $k") unless $found;
2292             }
2293             }
2294 0 0       0 warn "DEBUG: $k imported.\n" if $self->{'debug_lexer'};
2295             }
2296             }
2297              
2298             # Where the MIBs are stored
2299             sub repository {
2300 0     0 1 0 my $self = shift;
2301 0         0 my $dir = shift;
2302              
2303 0 0       0 $self->{'repository'} = $dir if defined $dir;
2304 0         0 return $self->{'repository'};
2305             }
2306              
2307             # Add some paths to the list of possible MIB locations
2308             sub add_path {
2309 0     0 1 0 my $self = shift;
2310              
2311 0 0       0 croak "Usage: Compiler::addpath(path1[,path2[,path3]])" if $#_ == -1;
2312 0         0 while (defined (my $path = shift)) {
2313 0         0 push @{$self->{'srcpath'}}, $path;
  0         0  
2314             }
2315 0         0 @{$self->{'srcpath'}};
  0         0  
2316             }
2317              
2318             # List of possible MIB filename extensions
2319             sub extensions {
2320 0     0 0 0 my $self = shift;
2321 0         0 my $ext = shift;
2322              
2323 0 0       0 $self->{'extensions'} = $ext if defined $ext;
2324 0         0 return $self->{'extensions'};
2325             }
2326              
2327             # Add some possible MIB filename extensions
2328             sub add_extension {
2329 0     0 1 0 my $self = shift;
2330              
2331 0 0       0 croak "Usage: Compiler::extension(ext1[,ext2[,ext3]])" if $#_ == -1;
2332 0         0 while (defined (my $ext = shift)) {
2333 0         0 push @{$self->{'extensions'}}, $ext;
  0         0  
2334             }
2335             }
2336              
2337             my $treemodes = {'read-only' => '-r-',
2338             'read-write' => '-rw',
2339             'read-create' => 'cr-',
2340             'write-only' => '--w',
2341             'not-accessible' => '---',
2342             'accessible-for-notify' => 'n--',
2343             'not-implemented' => 'i--',
2344             };
2345              
2346             my $treetypes = {'SEQUENCE' => '',
2347             'CHOICE' => '',
2348             'INTEGER' => 'Integer',
2349             'OCTET STRING' => 'String',
2350             'OBJECT IDENTIFIER' => 'ObjectID',
2351             'NULL' => 'Null',
2352             'IpAddress' => 'IPAddr',
2353             'Counter' => 'Counter',
2354             'Gauge' => 'Gauge',
2355             'TimeTicks' => 'TimeTcks',
2356             'Opaque' => 'Opaque',
2357             'Integer32' => 'Int32',
2358             'Counter32' => 'Count32',
2359             'Gauge32' => 'Gauge32',
2360             'Unsigned32' => 'UInt32',
2361             'Counter64' => 'Count64',
2362             };
2363              
2364             # return an ASCII driagram showing the tree under the given node
2365             sub tree {
2366 0     0 1 0 my $self = shift;
2367 0         0 my $node = shift;
2368 0         0 my $level = shift;
2369 0         0 my $inc = shift;
2370 0         0 my $s = shift;
2371              
2372 0 0       0 $level = 0 unless defined $level;
2373 0 0       0 $inc = 4 unless defined $inc;
2374              
2375 0 0       0 return $level ? $s : "$node\n" unless defined $self->{'tree'}{$node};
    0          
2376 0 0       0 unless ($level) {
2377 0         0 $s .= $node . "\n";
2378 0         0 $s .= " |\n";
2379             }
2380 0         0 for my $n (sort { $a <=> $b } keys %{$self->{'tree'}{$node}}) {
  0         0  
  0         0  
2381 0         0 my $new = $self->{'tree'}{$node}{$n};
2382 0         0 $s .= " ";
2383 0         0 $s .= " " x ($inc * $level) . "+-- ";
2384 0         0 my $access = "";
2385 0 0 0     0 $access = $$treemodes{$self->{'nodes'}{$new}{'access'}} || "???"
2386             if defined $self->{'nodes'}{$new}{'access'};
2387 0 0       0 $access .= " " if $access;
2388 0         0 my $type = "";
2389 0 0 0     0 $type = $self->{'nodes'}{$new}{'syntax'}{'type'} if
2390             defined $self->{'nodes'}{$new}{'syntax'} &&
2391             defined $self->{'nodes'}{$new}{'syntax'}{'type'};
2392 0 0       0 if ($type) {
2393 0         0 $type = $self->resolve_type($type);
2394 0 0       0 $type = sprintf "%-8.8s ", defined $$treetypes{$type} ?
2395             $$treetypes{$type} : $type;
2396 0 0       0 $type = "" if $type =~ m/^\s+$/o;
2397             }
2398 0         0 $s .= $access . $type . $new . '(' . $n . ")\n";
2399 0 0       0 if (defined $self->{'tree'}{$new}) {
2400 0         0 $s .= " ";
2401 0         0 $s .= " " x ($inc * ($level + 1)) . "|\n";
2402 0         0 $s = $self->tree($new, $level + 1, $inc, $s);
2403             }
2404             }
2405 0         0 $s;
2406             }
2407              
2408             ###########################################################################
2409             package Stream;
2410              
2411 7     7   174908 use strict;
  7         24  
  7         490  
2412 7     7   45 use vars qw($VERSION);
  7         17  
  7         4133  
2413              
2414             $VERSION = 1.00;
2415              
2416             sub new {
2417 7     7   112 my $this = shift;
2418 7         27 my $fh = shift;
2419 7   33     116 my $class = ref($this) || $this;
2420 7         26 my $self = {};
2421 7         15 bless $self, $class;
2422 7         61 $self->{'fh'} = $fh;
2423 7         25 $self->{'lineno'} = 1;
2424 7         18 $self->{'saved'} = 0;
2425 7         29 $self;
2426             }
2427              
2428             sub getc {
2429 7675     7675   8597 my $self = shift;
2430              
2431 7675         7495 my $char;
2432 7675 100       24652 if ($self->{'saved'}) {
    50          
2433 360         517 $char = $self->{'save'};
2434 360         449 $self->{'saved'} = 0;
2435 360 100       751 $self->{'lineno'}++ if $char eq "\n";
2436             }
2437             elsif (defined ($char = getc $self->{'fh'})) {
2438 7315         8907 $self->{'save'} = $char;
2439 7315 100       15551 $self->{'lineno'}++ if $char eq "\n";
2440             }
2441             else {
2442 0         0 $char = '';
2443             }
2444 7675         41413 $char;
2445             }
2446              
2447             sub ungetc {
2448 364     364   395 my $self = shift;
2449              
2450 364         448 $self->{'saved'} = 1;
2451 364 100       992 $self->{'lineno'}-- if $self->{'save'} eq "\n";
2452             }
2453              
2454             sub lineno {
2455 435     435   517 my $self = shift;
2456              
2457 435         784 $self->{'lineno'};
2458             }
2459              
2460             1;
2461              
2462             =head1 NAME
2463              
2464             SNMP::MIB::Compiler - a MIB Compiler supporting SMIv1 and SMIv2
2465              
2466             =head1 SYNOPSIS
2467              
2468             use SNMP::MIB::Compiler;
2469              
2470             my $mib = new SNMP::MIB::Compiler;
2471              
2472             # search MIBs there...
2473             $mib->add_path('./mibs', '/foo/bar/mibs');
2474              
2475             # possibly using these extensions...
2476             $mib->add_extension('', '.mib', '.my');
2477              
2478             # store the compiled MIBs there..
2479             $mib->repository('./out');
2480              
2481             # only accept SMIv2 MIBs
2482             $mib->{'accept_smiv1'} = 0;
2483             $mib->{'accept_smiv2'} = 1;
2484              
2485             # no debug
2486             $mib->{'debug_lexer'} = 0;
2487             $mib->{'debug_recursive'} = 0;
2488              
2489             # store compiled MIBs into files
2490             $mib->{'make_dump'} = 1;
2491             # read compiled MIBs
2492             $mib->{'use_dump'} = 1;
2493             # follow IMPORTS clause while compiling
2494             $mib->{'do_imports'} = 1;
2495              
2496             # load a precompiled MIB
2497             $mib->load('SNMPv2-MIB');
2498              
2499             # compile a new MIB
2500             $mib->compile('IF-MIB');
2501              
2502             print $mib->resolve_oid('ifInOctets'), "\n";
2503             print $mib->convert_oid('1.3.6.1.2.1.31.1.1.1.10'), "\n";
2504             print $mib->tree('ifMIB');
2505              
2506             =head1 DESCRIPTION
2507              
2508             SNMP::MIB::Compiler is a MIB compiler that fully supports
2509             both SMI(v1) and SMIv2. This module can be use to compile
2510             MIBs (recursively or not) or load already compiled MIBs for
2511             later use.
2512             Some tasks can be performed by the resulting object such as :
2513              
2514             - resolution of object names into object identifiers (OIDs).
2515             e.g. ifInOctets => 1.3.6.1.2.1.2.2.1.10
2516              
2517             - convertion of OIDs.
2518             e.g. 1.3.6.1.2.1.2.1 =>
2519             iso.org.dod.internet.mgmt.mib-2.interfaces.ifNumber
2520              
2521             - drawing MIB trees.
2522             e.g. ifTestTable => ifTestTable
2523             |
2524             +-- --- ifTestEntry(1)
2525             |
2526             +-- -rw Integer ifTestId(1)
2527             +-- -rw Integer ifTestStatus(2)
2528             +-- -rw ObjectID ifTestType(3)
2529             +-- -r- Integer ifTestResult(4)
2530             +-- -r- ObjectID ifTestCode(5)
2531             +-- -rw String ifTestOwner(6)
2532              
2533              
2534             The MIB to be compiled requires no modification. Everything legal
2535             according to SMIs is accepted, including MACRO definitions (which
2536             are parsed but ignored).
2537              
2538             This module is shipped with the basic MIBs usually needed by IMPORTS
2539             clauses. A lot of IETF MIBs has been successfully tested as well as
2540             some private ones.
2541              
2542             =head1 Methods
2543              
2544             =over 5
2545              
2546             =item C
2547              
2548             C I
2549              
2550             To create a new MIB, send a new() message to the SNMP::MIB::Compiler
2551             class. For example:
2552              
2553             my $mib = new SNMP::MIB::Compiler;
2554              
2555             This will create an empty MIB ready to accept both SMIv1 and SMIv2
2556             MIBs. A lot of attributes can be (des)activated to obtain a more
2557             or less strict and verbose compiler.
2558             The created object is returned.
2559              
2560             =item C
2561              
2562             C I
2563              
2564             Add one or more directories to the search path. This path is used to
2565             locate a MIB file when the 'compile' method is invoqued.
2566             The current list of paths is returned.
2567              
2568             Example:
2569              
2570             # search MIBs in the "mibs" directory (relative
2571             # to cwd) and in "/foo/bar/mibs" (absolute path)
2572             $mib->add_path('./mibs', '/foo/bar/mibs');
2573              
2574             =item C
2575              
2576             C I
2577              
2578             Add one or more extensions to the extension list. These extensions are
2579             used to locate a MIB file when the 'compile' method is invoqued. All
2580             extensions are tested for each directory specified by the add_path()
2581             method until one match.
2582             The current list of extensions is returned.
2583              
2584             Example:
2585              
2586             $mib->add_path('./mibs', '/foo/bar/mibs');
2587             $mib->add_extension('', '.mib');
2588             $mib->compile('FOO');
2589              
2590             The order is "./mibs/FOO", "./mibs/FOO.mib", "/foo/bar/mibs/FOO"
2591             and "/foo/bar/mibs/FOO.mib".
2592              
2593             =item C
2594              
2595             C I
2596              
2597             If 'dir' is defined, set the directory where compiled MIBs will be
2598             stored (using the compile() method) or loaded (using the load() method).
2599             The repository MUST be initialized before a MIB can be compiled or loaded.
2600             The current repository is returned.
2601              
2602             Example:
2603              
2604             $mib->repository('./out');
2605             print "Current repository is ", $mib->repository, "\n";
2606              
2607             =item C
2608              
2609             C I
2610              
2611             Compile a MIB given its name. All information contained in
2612             this MIB is inserted into the current object and is stored
2613             into a file in the repository (see the 'make_dump' attribute).
2614             The choosen name is the same as the real MIB name (defined
2615             in the MIB itself). If a precompiled MIB already exists in
2616             the repository and is newer than the given file, it is used
2617             instead of a real compilation (see the 'use_dump' attribute).
2618             The compiler can be recursive if IMPORTS clauses are followed
2619             (see the 'do_imports' attribute) and in that case, uncompiled
2620             MIB names must be explict according to paths and extensions
2621             critaeria (see add_path() and add_extensions() methods).
2622             The current object is returned.
2623              
2624             =item C
2625              
2626             C I
2627              
2628             Load a precompiled MIB given its name. All information contained in
2629             this MIB is inserted into the current object. The file is searched in the
2630             repository which MUST be initialized. In case of success, returns 1
2631             else returns 0.
2632              
2633             Example:
2634              
2635             $mib->load('SNMPv2-SMI');
2636             $mib->load('SNMPv2-MIB');
2637              
2638             =item C
2639              
2640             C I
2641              
2642             Example:
2643              
2644             print $mib->resolve_oid('ifInOctets'), "\n";
2645              
2646             =item C
2647              
2648             C I
2649              
2650             Example:
2651              
2652             print $mib->convert_oid('1.3.6.1.2.1.31.1.1.1.10'), "\n";
2653              
2654             =item C
2655              
2656             C I
2657              
2658             Example:
2659              
2660             print $mib->tree('ifMIB');
2661              
2662             =back
2663              
2664             =head1 Attributes
2665              
2666             =over 5
2667              
2668             =item C
2669              
2670             =item C
2671              
2672             =item C
2673              
2674             =item C
2675              
2676             =item C
2677              
2678             =item C
2679              
2680             =item C
2681              
2682             =item C
2683              
2684             =item C
2685              
2686             =item C
2687              
2688             =item C
2689              
2690             =back
2691              
2692             =head1 BUGS
2693              
2694             Currently, it is more a TODO list than a bug list.
2695              
2696             - not enough documentation
2697              
2698             - not enough methods
2699              
2700             - not enough test scripts
2701              
2702             - find a better name for compiled MIBs than 'dump's.. even if they are
2703             no more than dumps.
2704              
2705             If your MIBs can't be compiled by this module, please, double check
2706             their syntax. If you really think that they are correct, send them
2707             to me including their "uncommon" dependencies.
2708              
2709             =head1 AUTHOR
2710              
2711             Fabien Tassin (fta@oleane.net)
2712              
2713             =head1 COPYRIGHT
2714              
2715             Copyright 1998, 1999, Fabien Tassin. All rights reserved.
2716             It may be used and modified freely, but I do request that
2717             this copyright notice remain attached to the file. You may
2718             modify this module as you wish, but if you redistribute a
2719             modified version, please attach a note listing the modifications
2720             you have made.
2721              
2722             =cut