File Coverage

blib/lib/Net/DNS/ZoneFile.pm
Criterion Covered Total %
statement 247 247 100.0
branch 104 104 100.0
condition 23 23 100.0
subroutine 37 37 100.0
pod 8 8 100.0
total 419 419 100.0


line stmt bran cond sub pod time code
1             package Net::DNS::ZoneFile;
2              
3 12     12   4530 use strict;
  12         100  
  12         400  
4 12     12   73 use warnings;
  12         29  
  12         766  
5              
6             our $VERSION = (qw$Id: ZoneFile.pm 1910 2023-03-30 19:16:30Z willem $)[2];
7              
8              
9             =head1 NAME
10              
11             Net::DNS::ZoneFile - DNS zone file
12              
13             =head1 SYNOPSIS
14              
15             use Net::DNS::ZoneFile;
16              
17             $zonefile = Net::DNS::ZoneFile->new( 'named.example' );
18              
19             while ( $rr = $zonefile->read ) {
20             $rr->print;
21             }
22              
23             @zone = $zonefile->read;
24              
25              
26             =head1 DESCRIPTION
27              
28             Each Net::DNS::ZoneFile object instance represents a zone file
29             together with any subordinate files introduced by the $INCLUDE
30             directive. Zone file syntax is defined by RFC1035.
31              
32             A program may have multiple zone file objects, each maintaining
33             its own independent parser state information.
34              
35             The parser supports both the $TTL directive defined by RFC2308
36             and the BIND $GENERATE syntax extension.
37              
38             All RRs in a zone file must have the same class, which may be
39             specified for the first RR encountered and is then propagated
40             automatically to all subsequent records.
41              
42             =cut
43              
44              
45 12     12   581 use integer;
  12         47  
  12         389  
46 12     12   534 use Carp;
  12         35  
  12         908  
47 12     12   86 use IO::File;
  12         34  
  12         2317  
48              
49 12     12   81 use base qw(Exporter);
  12         28  
  12         1813  
50             our @EXPORT = qw(parse read readfh);
51              
52 12     12   92 use constant PERLIO => defined eval { require PerlIO };
  12         26  
  12         24  
  12         2700  
53              
54 12         31 use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6]
55 12         65 require Encode;
56 12         129 Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' );
57 12     12   350 };
  12         22  
58              
59             require Net::DNS::Domain;
60             require Net::DNS::RR;
61              
62              
63             =head1 METHODS
64              
65              
66             =head2 new
67              
68             $zonefile = Net::DNS::ZoneFile->new( 'filename', ['example.com'] );
69              
70             $handle = IO::File->new( 'filename', '<:encoding(ISO8859-7)' );
71             $zonefile = Net::DNS::ZoneFile->new( $handle, ['example.com'] );
72              
73             The new() constructor returns a Net::DNS::ZoneFile object which
74             represents the zone file specified in the argument list.
75              
76             The specified file or file handle is open for reading and closed when
77             exhausted or all references to the ZoneFile object cease to exist.
78              
79             The optional second argument specifies $ORIGIN for the zone file.
80              
81             Zone files are presumed to be UTF-8 encoded where that is supported.
82              
83             Alternative character encodings may be specified indirectly by creating
84             a file handle with the desired encoding layer, which is then passed as
85             an argument to new(). The specified encoding is propagated to files
86             introduced by $INCLUDE directives.
87              
88             =cut
89              
90             sub new {
91 67     67 1 26647 my ( $class, $filename, $origin ) = @_;
92 67         236 my $self = bless {fileopen => {}}, $class;
93              
94 67         1711 $self->_origin($origin);
95              
96 67 100       179 if ( ref($filename) ) {
97 16         43 $self->{filehandle} = $self->{filename} = $filename;
98 16 100       173 return $self if ref($filename) =~ /IO::File|FileHandle|GLOB|Text/;
99 1         119 croak 'argument not a file handle';
100             }
101              
102 51 100       329 croak 'filename argument undefined' unless $filename;
103 50         79 my $discipline = UTF8 ? '<:encoding(UTF-8)' : '<';
104 50 100       210 $self->{filehandle} = IO::File->new( $filename, $discipline ) or croak "$filename: $!";
105 46         10608 $self->{fileopen}->{$filename}++;
106 46         103 $self->{filename} = $filename;
107 46         191 return $self;
108             }
109              
110              
111             =head2 read
112              
113             $rr = $zonefile->read;
114             @rr = $zonefile->read;
115              
116             When invoked in scalar context, read() returns a Net::DNS::RR object
117             representing the next resource record encountered in the zone file,
118             or undefined if end of data has been reached.
119              
120             When invoked in list context, read() returns the list of Net::DNS::RR
121             objects in the order that they appear in the zone file.
122              
123             Comments and blank lines are silently disregarded.
124              
125             $INCLUDE, $ORIGIN, $TTL and $GENERATE directives are processed
126             transparently.
127              
128             =cut
129              
130             sub read {
131 101     101 1 3658 my ($self) = @_;
132              
133 101 100       264 return &_read unless ref $self; # compatibility interface
134              
135 96 100       237 if (wantarray) {
136 9         17 my @zone; # return entire zone
137 9         15 eval {
138 9         34 local $SIG{__DIE__};
139 9         25 while ( my $rr = $self->_getRR ) {
140 183         461 push( @zone, $rr );
141             }
142             };
143 9 100       37 croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@;
144 8         56 return @zone;
145             }
146              
147 87         128 my $rr = eval {
148 87         289 local $SIG{__DIE__};
149 87         211 $self->_getRR; # return single RR
150             };
151 87 100       355 croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@;
152 60         203 return $rr;
153             }
154              
155              
156             =head2 name
157              
158             $filename = $zonefile->name;
159              
160             Returns the name of the current zone file.
161             Embedded $INCLUDE directives will cause this to differ from the
162             filename argument supplied when the object was created.
163              
164             =cut
165              
166             sub name {
167 41     41 1 1027 return shift->{filename};
168             }
169              
170              
171             =head2 line
172              
173             $line = $zonefile->line;
174              
175             Returns the number of the last line read from the current zone file.
176              
177             =cut
178              
179             sub line {
180 92     92 1 783 my $self = shift;
181 92 100       236 return $self->{eom} if defined $self->{eom};
182 90         376 return $self->{filehandle}->input_line_number;
183             }
184              
185              
186             =head2 origin
187              
188             $origin = $zonefile->origin;
189              
190             Returns the fully qualified name of the current origin within the
191             zone file.
192              
193             =cut
194              
195             sub origin {
196 5     5 1 325 my $context = shift->{context};
197 5     5   23 return &$context( sub { Net::DNS::Domain->new('@') } )->string;
  5         22  
198             }
199              
200              
201             =head2 ttl
202              
203             $ttl = $zonefile->ttl;
204              
205             Returns the default TTL as specified by the $TTL directive.
206              
207             =cut
208              
209             sub ttl {
210 2     2 1 9 return shift->{TTL};
211             }
212              
213              
214             =head1 COMPATIBILITY WITH Net::DNS::ZoneFile 1.04
215              
216             Applications which depended on the defunct Net::DNS::ZoneFile 1.04
217             CPAN distribution will continue to operate with minimal change using
218             the compatibility interface described below.
219             New application code should use the object-oriented interface.
220              
221             use Net::DNS::ZoneFile;
222              
223             $listref = Net::DNS::ZoneFile->read( $filename );
224             $listref = Net::DNS::ZoneFile->read( $filename, $include_dir );
225              
226             $listref = Net::DNS::ZoneFile->readfh( $filehandle );
227             $listref = Net::DNS::ZoneFile->readfh( $filehandle, $include_dir );
228              
229             $listref = Net::DNS::ZoneFile->parse( $string );
230             $listref = Net::DNS::ZoneFile->parse( \$string );
231             $listref = Net::DNS::ZoneFile->parse( $string, $include_dir );
232             $listref = Net::DNS::ZoneFile->parse( \$string, $include_dir );
233              
234             $_->print for @$listref;
235              
236             The optional second argument specifies the default path for filenames.
237             The current working directory is used by default.
238              
239             Although not available in the original implementation, the RR list can
240             be obtained directly by calling any of these methods in list context.
241              
242             @rr = Net::DNS::ZoneFile->read( $filename, $include_dir );
243              
244             The partial result is returned if an error is encountered by the parser.
245              
246              
247             =head2 read
248              
249             $listref = Net::DNS::ZoneFile->read( $filename );
250             $listref = Net::DNS::ZoneFile->read( $filename, $include_dir );
251              
252             read() parses the contents of the specified file
253             and returns a reference to the list of Net::DNS::RR objects.
254             The return value is undefined if an error is encountered by the parser.
255              
256             =cut
257              
258             our $include_dir; ## dynamically scoped
259              
260             sub _filename { ## rebase unqualified filename
261 18     18   31 my $name = shift;
262 18 100       51 return $name if ref($name); ## file handle
263 11 100       29 return $name unless $include_dir;
264 3         17 require File::Spec;
265 3 100       31 return $name if File::Spec->file_name_is_absolute($name);
266 2 100       33 return $name if -f $name; ## file in current directory
267 1         25 return File::Spec->catfile( $include_dir, $name );
268             }
269              
270              
271             sub _read {
272 12     12   21 my ($arg1) = @_;
273 12 100 100     55 shift if !ref($arg1) && $arg1 eq __PACKAGE__;
274 12         17 my $filename = shift;
275 12         21 local $include_dir = shift;
276              
277 12         24 my $zonefile = Net::DNS::ZoneFile->new( _filename($filename) );
278 10         20 my @zone;
279 10         16 eval {
280 10         59 local $SIG{__DIE__};
281 10         18 my $rr;
282 10         25 push( @zone, $rr ) while $rr = $zonefile->_getRR;
283             };
284 10 100       100 return wantarray ? @zone : \@zone unless $@;
    100          
285 2         246 carp $@;
286 2 100       24 return wantarray ? @zone : undef;
287             }
288              
289              
290             {
291              
292             package Net::DNS::ZoneFile::Text; ## no critic ProhibitMultiplePackages
293              
294 12     12   17591 use overload ( '<>' => 'readline' );
  12         4669  
  12         97  
295              
296             sub new {
297 7     7   15 my ( $class, $data ) = @_;
298 7         19 my $self = bless {}, $class;
299 7 100       121 $self->{data} = [split /\n/, ref($data) ? $$data : $data];
300 7         26 return $self;
301             }
302              
303             sub readline {
304 40     40   57 my $self = shift;
305 40         68 $self->{line}++;
306 40         52 return shift( @{$self->{data}} );
  40         125  
307             }
308              
309             sub close {
310 5     5   14 shift->{data} = [];
311 5         20 return 1;
312             }
313              
314             sub input_line_number {
315 5     5   16 return shift->{line};
316             }
317              
318             }
319              
320              
321             =head2 readfh
322              
323             $listref = Net::DNS::ZoneFile->readfh( $filehandle );
324             $listref = Net::DNS::ZoneFile->readfh( $filehandle, $include_dir );
325              
326             readfh() parses data from the specified file handle
327             and returns a reference to the list of Net::DNS::RR objects.
328             The return value is undefined if an error is encountered by the parser.
329              
330             =cut
331              
332             sub readfh {
333 7     7 1 15 return &_read;
334             }
335              
336              
337             =head2 parse
338              
339             $listref = Net::DNS::ZoneFile->parse( $string );
340             $listref = Net::DNS::ZoneFile->parse( \$string );
341             $listref = Net::DNS::ZoneFile->parse( $string, $include_dir );
342             $listref = Net::DNS::ZoneFile->parse( \$string, $include_dir );
343              
344             parse() interprets the text in the argument string
345             and returns a reference to the list of Net::DNS::RR objects.
346             The return value is undefined if an error is encountered by the parser.
347              
348             =cut
349              
350             sub parse {
351 7     7 1 4303 my ($arg1) = @_;
352 7 100       44 shift if $arg1 eq __PACKAGE__;
353 7         13 my $string = shift;
354 7         15 my @include = grep {defined} shift;
  7         24  
355 7         26 return &readfh( Net::DNS::ZoneFile::Text->new($string), @include );
356             }
357              
358              
359             ########################################
360              
361              
362             {
363              
364             package Net::DNS::ZoneFile::Generator; ## no critic ProhibitMultiplePackages
365              
366 12     12   5339 use overload ( '<>' => 'readline' );
  12         35  
  12         65  
367              
368             sub new {
369 12     12   306 my ( $class, $range, $template, $line ) = @_;
370 12         26 my $self = bless {}, $class;
371              
372 12         41 my ( $bound, $step ) = split m#[/]#, $range; # initial iterator state
373 12         34 my ( $first, $last ) = split m#[-]#, $bound;
374 12   100     30 $first ||= 0;
375 12   100     30 $last ||= $first;
376 12   100     38 $step ||= 1; # coerce step to match range
377 12 100       40 $step = ( $last < $first ) ? -abs($step) : abs($step);
378 12         62 $self->{count} = int( ( $last - $first ) / $step ) + 1;
379              
380 12         24 for ($template) {
381 12         25 s/\\\$/\\036/g; # disguise escaped dollar
382 12         15 s/\$\$/\\036/g; # disguise escaped dollar
383 12         29 s/^"(.*)"$/$1/s; # unwrap BIND's quoted template
384 12         18 @{$self}{qw(instant step template line)} = ( $first, $step, $_, $line );
  12         46  
385             }
386 12         25 return $self;
387             }
388              
389             sub readline {
390 27     27   41 my $self = shift;
391 27 100       83 return unless $self->{count}-- > 0; # EOF
392              
393 16         23 my $instant = $self->{instant}; # update iterator state
394 16         27 $self->{instant} += $self->{step};
395              
396 16         28 local $_ = $self->{template}; # copy template
397 16         105 while (/\$\{(.*)\}/) { # interpolate ${...}
398 10         48 my $s = _format( $instant, split /\,/, $1 );
399 9         154 s/\$\{$1\}/$s/eg;
  9         49  
400             }
401              
402 15         41 s/\$/$instant/eg; # interpolate $
  6         20  
403 15         31 s/\\036/\$/g; # reinstate escaped $
404 15         53 return $_;
405             }
406              
407             sub close {
408 11     11   17 shift->{count} = 0; # suppress iterator
409 11         15 return 1;
410             }
411              
412             sub input_line_number {
413 12     12   153 return shift->{line}; # fixed: identifies $GENERATE
414             }
415              
416              
417             sub _format { ## convert $GENERATE iteration number to specified format
418 10     10   20 my $number = shift; # per ISC BIND 9.7
419 10   100     29 my $offset = shift || 0;
420 10   100     25 my $length = shift || 0;
421 10   100     24 my $format = shift || 'd';
422              
423 10         19 my $value = $number + $offset;
424 10   100     24 my $digit = $length || 1;
425 10 100       69 return substr sprintf( "%01.$digit$format", $value ), -$length if $format =~ /[doxX]/;
426              
427 3         31 my $nibble = join( '.', split //, sprintf ".%32.32lx", $value );
428 3 100       19 return reverse lc( substr $nibble, -$length ) if $format =~ /[n]/;
429 2 100       13 return reverse uc( substr $nibble, -$length ) if $format =~ /[N]/;
430 1         16 die "unknown $format format";
431             }
432              
433             }
434              
435              
436             sub _generate { ## expand $GENERATE into input stream
437 12     12   25 my ( $self, $range, $template ) = @_;
438              
439 12         26 my $handle = Net::DNS::ZoneFile::Generator->new( $range, $template, $self->line );
440              
441 12         23 delete $self->{latest}; # forget previous owner
442 12         49 $self->{parent} = bless {%$self}, ref($self); # save state, create link
443 12         55 return $self->{filehandle} = $handle;
444             }
445              
446              
447             my $LEX_REGEX = q/("[^"]*"|"[^"]*$)|;[^\n]*|([()])|[ \t\n\r\f]+/;
448              
449             sub _getline { ## get line from current source
450 407     407   566 my $self = shift;
451              
452 407         607 my $fh = $self->{filehandle};
453 407         2621 while (<$fh>) {
454 559 100       2242 next if /^\s*;/; # discard comment line
455 467 100       1600 next unless /\S/; # discard blank line
456              
457 388 100       943 if (/["(]/) {
458 59         134 s/\\\\/\\092/g; # disguise escaped escape
459 59         102 s/\\"/\\034/g; # disguise escaped quote
460 59         104 s/\\\(/\\040/g; # disguise escaped bracket
461 59         93 s/\\\)/\\041/g; # disguise escaped bracket
462 59         99 s/\\;/\\059/g; # disguise escaped semicolon
463 59 100       1178 my @token = grep { defined && length } split /(^\s)|$LEX_REGEX/o;
  959         2305  
464              
465 59         324 while ( $token[-1] =~ /^"[^"]*$/ ) { # multiline quoted string
466 2         12 $_ = pop(@token) . <$fh>; # reparse fragments
467 2         7 s/\\\\/\\092/g; # disguise escaped escape
468 2         6 s/\\"/\\034/g; # disguise escaped quote
469 2         5 s/\\\(/\\040/g; # disguise escaped bracket
470 2         4 s/\\\)/\\041/g; # disguise escaped bracket
471 2         4 s/\\;/\\059/g; # disguise escaped semicolon
472 2 100       53 push @token, grep { defined && length } split /$LEX_REGEX/o;
  11         33  
473 2         12 $_ = join ' ', @token; # reconstitute RR string
474             }
475              
476 59 100       116 if ( grep { $_ eq '(' } @token ) { # concatenate multiline RR
  245         512  
477 24         43 until ( grep { $_ eq ')' } @token ) {
  1891         2770  
478 84         241 $_ = pop(@token) . <$fh>;
479 84         159 s/\\\\/\\092/g; # disguise escaped escape
480 84         115 s/\\"/\\034/g; # disguise escaped quote
481 84         106 s/\\\(/\\040/g; # disguise escaped bracket
482 84         104 s/\\\)/\\041/g; # disguise escaped bracket
483 84         115 s/\\;/\\059/g; # disguise escaped semicolon
484 84 100       940 push @token, grep { defined && length } split /$LEX_REGEX/o;
  1033         2164  
485 84 100       263 chomp $token[-1] unless $token[-1] =~ /^"[^"]*$/;
486             }
487 24         122 $_ = join ' ', @token; # reconstitute RR string
488             }
489             }
490              
491 388 100       1367 return $_ unless /^[\$]/; # RR string
492              
493 36 100       485 my @token = grep { defined && length } split /$LEX_REGEX/o;
  229         659  
494 36 100       187 if (/^\$INCLUDE/) { # directive
    100          
    100          
    100          
495 7         17 my ( $keyword, @argument ) = @token;
496 7 100       27 die '$INCLUDE incomplete' unless @argument;
497 6         18 $fh = $self->_include(@argument);
498              
499             } elsif (/^\$GENERATE/) { # directive
500 13         39 my ( $keyword, $range, @template ) = @token;
501 13 100       38 die '$GENERATE incomplete' unless @template;
502 12         50 $fh = $self->_generate( $range, "@template" );
503              
504             } elsif (/^\$ORIGIN/) { # directive
505 9         20 my ( $keyword, $origin ) = @token;
506 9 100       31 die '$ORIGIN incomplete' unless defined $origin;
507 8         47 $self->_origin($origin);
508              
509             } elsif (/^\$TTL/) { # directive
510 4         10 my ( $keyword, $ttl ) = @token;
511 4 100       20 die '$TTL incomplete' unless defined $ttl;
512 3         12 $self->{TTL} = Net::DNS::RR::ttl( {}, $ttl );
513              
514             } else { # unrecognised
515 3         7 my ($keyword) = @token;
516 3         32 die qq[unknown "$keyword" directive];
517             }
518             }
519              
520 45         176 $self->{eom} = $self->line; # end of file
521 45         842 $fh->close();
522 45   100     805 my $link = $self->{parent} || return; # end of zone
523 14         102 %$self = %$link; # end $INCLUDE
524 14         48 return $self->_getline; # resume input
525             }
526              
527              
528             sub _getRR { ## get RR from current source
529 313     313   487 my $self = shift;
530              
531 313         420 local $_;
532 313 100       565 $self->_getline || return; # line already in $_
533              
534 287         758 my $noname = s/^\s/\@\t/; # placeholder for empty RR name
535              
536             # construct RR object with context specific dynamically scoped $ORIGIN
537 287         467 my $context = $self->{context};
538 287     287   1226 my $rr = &$context( sub { Net::DNS::RR->_new_string($_) } );
  287         800  
539              
540 267         823 my $latest = $self->{latest}; # overwrite placeholder
541 267 100 100     622 $rr->{owner} = $latest->{owner} if $noname && $latest;
542              
543 267 100       578 $self->{class} = $rr->class unless $self->{class}; # propagate RR class
544 267         696 $rr->class( $self->{class} );
545              
546 267 100       591 unless ( defined $self->{TTL} ) {
547 242 100       574 $self->{TTL} = $rr->minimum if $rr->type eq 'SOA'; # default TTL
548             }
549 267 100       621 $rr->{ttl} = $self->{TTL} unless defined $rr->{ttl};
550              
551 267         921 return $self->{latest} = $rr;
552             }
553              
554              
555             sub _include { ## open $INCLUDE file
556 6     6   12 my ( $self, $include, $origin ) = @_;
557              
558 6         12 my $filename = _filename($include);
559 6 100       38 die qq(\$INCLUDE $filename: Unexpected recursion) if $self->{fileopen}->{$filename}++;
560              
561 5         33 my $discipline = PERLIO ? join( ':', '<', PerlIO::get_layers $self->{filehandle} ) : '<';
562 5 100       73 my $filehandle = IO::File->new( $filename, $discipline ) or die qq(\$INCLUDE $filename: $!);
563              
564 4         559 delete $self->{latest}; # forget previous owner
565 4         31 $self->{parent} = bless {%$self}, ref($self); # save state, create link
566 4 100       15 $self->_origin($origin) if $origin;
567 4         8 $self->{filename} = $filename;
568 4         134 return $self->{filehandle} = $filehandle;
569             }
570              
571              
572             sub _origin { ## change $ORIGIN (scope: current file)
573 76     76   152 my ( $self, $name ) = @_;
574 76         188 my $context = $self->{context};
575 76 100       419 $context = Net::DNS::Domain->origin(undef) unless $context;
576 76     76   405 $self->{context} = &$context( sub { Net::DNS::Domain->origin($name) } );
  76         189  
577 76         286 delete $self->{latest}; # forget previous owner
578 76         167 return;
579             }
580              
581              
582             1;
583             __END__