File Coverage

blib/lib/Net/DNS/ZoneFile/Fast.pm
Criterion Covered Total %
statement 335 614 54.5
branch 221 480 46.0
condition 27 65 41.5
subroutine 17 23 73.9
pod 2 16 12.5
total 602 1198 50.2


line stmt bran cond sub pod time code
1             # ----------------------------------------------------------------------------
2             # "THE BEER-WARE LICENSE" (Revision 42)
3             # wrote this file. As long as you retain this notice you
4             # can do whatever you want with this stuff. If we meet some day, and you think
5             # this stuff is worth it, you can buy me a beer in return. Anton Berezin
6             # ----------------------------------------------------------------------------
7             # Copyright (c) 2005-2013 SPARTA, Inc.
8             # All rights reserved.
9             #
10             # Redistribution and use in source and binary forms, with or without
11             # modification, are permitted provided that the following conditions are met:
12             #
13             # * Redistributions of source code must retain the above copyright notice,
14             # this list of conditions and the following disclaimer.
15             #
16             # * Redistributions in binary form must reproduce the above copyright
17             # notice, this list of conditions and the following disclaimer in the
18             # documentation and/or other materials provided with the distribution.
19             #
20             # * Neither the name of SPARTA, Inc nor the names of its contributors may
21             # be used to endorse or promote products derived from this software
22             # without specific prior written permission.
23             #
24             # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
25             # IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
26             # THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
27             # PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
28             # CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
29             # EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
30             # PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
31             # OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
32             # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
33             # OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
34             # ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35             # ----------------------------------------------------------------------------
36             # Copyright (c) 2013-2013 PARSONS, Inc.
37             # All rights reserved.
38             #
39             # Redistribution and use in source and binary forms, with or without
40             # modification, are permitted provided that the following conditions are met:
41             #
42             # * Redistributions of source code must retain the above copyright notice,
43             # this list of conditions and the following disclaimer.
44             #
45             # * Redistributions in binary form must reproduce the above copyright
46             # notice, this list of conditions and the following disclaimer in the
47             # documentation and/or other materials provided with the distribution.
48             #
49             # * Neither the name of SPARTA, Inc nor the names of its contributors may
50             # be used to endorse or promote products derived from this software
51             # without specific prior written permission.
52             #
53             # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
54             # IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
55             # THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
56             # PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
57             # CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
58             # EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
59             # PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
60             # OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
61             # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
62             # OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
63             # ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
64             #
65             # $Id: Fast.pm 8304 2014-09-05 17:20:49Z hardaker $
66             #
67             package Net::DNS::ZoneFile::Fast;
68             # documentation at the __END__ of the file
69              
70 15     15   8436511 use strict;
  15         32  
  15         632  
71 15     15   366 use 5.005;
  15         45  
  15         642  
72 15     15   108 use vars qw($VERSION);
  15         33  
  15         4077  
73 15     15   12715 use IO::File;
  15         13886083  
  15         2271  
74 15     15   23126 use Net::DNS;
  15         17217448  
  15         2668  
75 15     15   147 use Net::DNS::RR;
  15         29  
  15         296  
76 15     15   22134 use MIME::Base64;
  15         18252  
  15         330156  
77              
78             $VERSION = '1.24';
79              
80             my $MAXIMUM_TTL = 0x7fffffff;
81              
82             my $pat_ttl = qr{\d+[\dwdhms]*}i;
83             my $pat_skip = qr{\s*(?:;.*)?};
84             my $pat_name = qr{(?:[-\*\w\$\d\/*]|\\[0-2]\d\d)+(?:\.(?:[-\*\w\$\d\/]|\\[0-2]\d\d)+)*};
85             my $pat_maybefullnameorroot = qr{(?:\.|(?:[-\w\$\d\/*]|\\[0-2]\d\d)+(?:\.(?:[-\w\$\d\/]|\\[0-2]\d\d)+)*\.?)};
86              
87             #
88             # Added the ability to have a backslash in the SOA username. This is to
89             # provide for the RFC-allowed "Joe\.Jones.example.com" construct to allow
90             # dots in usernames. Keeping the original version here for easy reference.
91             #
92             # my $pat_maybefullname = qr{[-\w\$\d\/*]+(?:\.[-\w\$\d\/]+)*\.?};
93             my $pat_maybefullname = qr{(?:[-\+\w\$\d\/*\\]|\\[0-2]\d\d)+(?:\.(?:[-\+\w\$\d\/]|\\[0-2]\d\d)+)*\.?};
94              
95             my $debug;
96             my $domain;
97             my $parse;
98             my $ln;
99             my $default_ttl;
100             my $minimum;
101             my $origin;
102             my $ttl;
103             my @zone;
104             my $soa;
105             my $rrsig;
106             my $sshfp;
107             my $key;
108             my $dnskey;
109             my $ds;
110             my $nsec3;
111             my $tlsa;
112             my $on_error;
113             my $quiet;
114             my $soft_errors;
115             my $fh;
116             my @fhs;
117             my @lns;
118             my $includes_root;
119             my $globalerror;
120             my $nsec3capable;
121              
122             # boot strap optional DNSSEC module functions
123             # (not optional if trying to parse a signed zone, but we don't need
124             # these modules unless we are.
125             $nsec3capable = eval {
126             require Net::DNS::RR::NSEC;
127             require Net::DNS::RR::DNSKEY;
128             require Net::DNS::RR::NSEC3;
129             require Net::DNS::RR::NSEC3PARAM;
130             require MIME::Base32;
131             };
132              
133             sub parse
134             {
135 160     160 1 123841 my %param;
136             my $text;
137              
138 160         273 $on_error = undef;
139 160         395 $parse = \&parse_line;
140 160         235 $ln = 0;
141 160         275 $domain = ".";
142 160         198 $default_ttl = -1;
143 160         228 $minimum = -1;
144 160         505 @zone = ();
145              
146 160 100       430 if (@_ == 1) {
147 129         204 $text = shift;
148             } else {
149 31         157 %param = @_;
150 31 100       99 if (defined $param{text}) {
    100          
    50          
151 26         51 $text = $param{text};
152             } elsif (defined $param{fh}) {
153 2         6 $fh = $param{fh};
154             } elsif (defined $param{file}) {
155 3         20 $fh = IO::File->new($param{file}, "r");
156 3 50       261 error("cannot open $param{file}: $!") unless defined $fh;
157             } else {
158 0         0 error("want zone text, or file, or fh");
159             }
160             }
161              
162 160         277 $debug = $param{debug};
163 160         230 $quiet = $param{quiet};
164 160         226 $origin = $param{origin};
165 160 50       472 $origin = "." unless defined $origin;
166 160 50       664 $origin = ".$origin" unless $origin =~ /^\./;
167 160 50       591 $origin = "$origin." unless $origin =~ /\.$/;
168 160   100     804 $on_error = $param{on_error} || undef;
169 160 100 66     466 $param{soft_errors} = 1 if $on_error && !exists $param{soft_errors};
170 160 50 66     846 $quiet = 1 if $on_error && !exists $param{quiet};
171 160         231 $soft_errors = $param{soft_errors};
172 160         231 $includes_root = $param{includes_root};
173              
174 160         212 eval {
175 160 100       296 if ($fh) {
176 5         9 do {
177 5         77 while ($_ = readline($fh)) {
178 27         28 $ln++;
179 27         43 $parse->();
180             }
181 5         10 $fh = shift @fhs;
182 5         53 $ln = shift @lns;
183             } while ($fh);
184             } else {
185 155         673 my @text = split "\n", $text;
186 155         325 for (@text) {
187 444         475 $ln++;
188 444         757 $parse->();
189             }
190             }
191             };
192 160 100       895 if ($@) {
193 26 50       125 die "$globalerror (at input line #$ln)" if ($globalerror);
194 26 100       218 return undef if $param{soft_errors};
195 1         14 die;
196             }
197              
198 134         267 my @r;
199 134 100       345 $minimum = 0 if $minimum < 0;
200 134         230 for my $z (@zone) {
201 152 100       445 $z->{ttl} = $minimum if $z->{ttl} <= 0;
202 152         276 chop $z->{name};
203 152         217 my $line = $z->{Line};
204 152   100     570 my $lines = $z->{Lines} || 1;
205 152         275 delete $z->{Line};
206 152         210 delete $z->{Lines};
207 152 50       517 if ($param{tolower}) {
    50          
208 0         0 $z->{name} = lc $z->{name};
209 0 0       0 $z->{cname} = lc $z->{cname} if defined $z->{cname};
210 0 0       0 $z->{dname} = lc $z->{dname} if defined $z->{dname};
211 0 0       0 $z->{exchange} = lc $z->{exchange} if defined $z->{exchange};
212 0 0       0 $z->{mname} = lc $z->{mname} if defined $z->{mname};
213 0 0       0 $z->{rname} = lc $z->{rname} if defined $z->{rname};
214 0 0       0 $z->{nsdname} = lc $z->{nsdname} if defined $z->{nsdname};
215 0 0       0 $z->{ptrdname} = lc $z->{ptrdname} if defined $z->{ptrdname};
216 0 0       0 $z->{target} = lc $z->{target} if defined $z->{target};
217 0 0       0 $z->{mbox} = lc $z->{mbox} if defined $z->{mbox};
218 0 0       0 $z->{txtdname} = lc $z->{txtdname} if defined $z->{txtdname};
219             } elsif ($param{toupper}) {
220 0         0 $z->{name} = uc $z->{name};
221 0 0       0 $z->{cname} = uc $z->{cname} if defined $z->{cname};
222 0 0       0 $z->{dname} = uc $z->{dname} if defined $z->{dname};
223 0 0       0 $z->{exchange} = uc $z->{exchange} if defined $z->{exchange};
224 0 0       0 $z->{mname} = uc $z->{mname} if defined $z->{mname};
225 0 0       0 $z->{rname} = uc $z->{rname} if defined $z->{rname};
226 0 0       0 $z->{nsdname} = uc $z->{nsdname} if defined $z->{nsdname};
227 0 0       0 $z->{ptrdname} = uc $z->{ptrdname} if defined $z->{ptrdname};
228 0 0       0 $z->{target} = uc $z->{target} if defined $z->{target};
229 0 0       0 $z->{mbox} = uc $z->{mbox} if defined $z->{mbox};
230 0 0       0 $z->{txtdname} = uc $z->{txtdname} if defined $z->{txtdname};
231             }
232 152         1190 my $newrec = Net::DNS::RR->new(%$z);
233              
234 151 50       7817573 if ($newrec->{'type'} eq 'DNSKEY') {
235 0 0       0 if (ref($newrec) ne 'Net::DNS::RR::DNSKEY') {
236 0         0 warn "Failed to define a DNSSEC object (got: " . ref($newrec) . "); you're probably missing either MIME::Base64 or MIME::Base32";
237             } else {
238 0         0 $newrec->setkeytag;
239             }
240             }
241              
242             # no longer an issue with recent Net::DNS
243             #if ($newrec->{'type'} eq 'RRSIG') {
244             # fix an issue with RRSIG's signame being stripped of
245             # the trailing dot.
246              
247              
248             # $newrec->{'signame'} .= "."
249             # if ($newrec->{'signame'} !~ /\.$/);
250             #}
251 151         283 push @r, $newrec;
252 151         302 $r[-1]->{Line} = $line;
253 151         490 $r[-1]->{Lines} = $lines;
254             }
255 133         623 return \@r;
256             }
257              
258             sub error
259             {
260 26 100   26 0 66 if ($on_error) {
261 2         3 eval { $on_error->($ln, @_) };
  2         10  
262 2 50       14 if($@ ne '') {
263             # set global error so parse can die appropriately later.
264 0         0 $globalerror = $@;
265 0         0 die;
266             }
267             } else {
268 24 50 66     141 warn "@_, line $ln\n" if $soft_errors && !$quiet;
269             }
270 26         279 die "@_, line $ln\n";
271             }
272              
273             sub parse_line
274             {
275 427 50   427 0 26518 if (/^\$include[ \t]+/ig) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
276 0 0       0 if (!/\G[\"\']*([^\s\'\"]+)[\"\']*/igc) {
277 0         0 error("no include file specified $_");
278 0         0 return;
279             }
280 0         0 my $fn = $1;
281 0 0       0 if (! -f $fn) {
282             # expand file according to includes_root
283 0 0 0     0 if ($includes_root && -f $includes_root . '/'. $fn) {
284 0         0 $fn = $includes_root . '/'. $fn;
285             }
286             else {
287 0         0 error("could not find file $fn");
288 0         0 return;
289             }
290             }
291 0         0 unshift @fhs, $fh;
292 0         0 unshift @lns, $ln;
293 0         0 $fh = IO::File->new($fn, "r");
294 0         0 $ln = 0;
295 0 0       0 error("cannot open include file $fn: $!") unless defined $fh;
296 0         0 return;
297             } elsif (/^\$origin[ \t]+/ig) {
298 19 100       7111 if (/\G($pat_maybefullname)$pat_skip$/gc) {
    50          
299 17         63 my $name = $1;
300 17 100       91 $name = "$name$origin" unless $name =~ /\.$/;
301 17         34 $origin = $name;
302 17 50       70 $origin = ".$origin" unless $origin =~ /^\./;
303 17         543 return;
304             } elsif (/\G\.$pat_skip$/gc) {
305 2         3 $origin = ".";
306 2         9 return;
307             } else {
308 0         0 error("bad \$ORIGIN");
309             }
310             } elsif (/^\$generate[ \t]+/ig) {
311 2 50       17 if (/\G(\d+)\s*-\s*(\d+)\s+(.*)$/) {
312 2         5 my $from = $1;
313 2         6 my $to = $2;
314 2         7 my $pat = $3;
315 2 100       13 error("bad range in \$GENERATE") if $from > $to;
316 1 50       5 error("\$GENERATE pattern without a wildcard") if $pat !~ /\$/;
317 1         4 while ($from <= $to) {
318 5         10 $_ = $pat;
319 5         22 s{\$ (?:\{ ([\d+-]+) (?:, (\d+) (?:, ([doxX]) )? )? \})?}
320             {
321 10         25 my ($offset, $width, $base) = ($1, $2, $3);
322 10   50     34 $offset ||= 0;
323 10   50     38 $width ||= 0;
324 10   50     32 $base ||= 'd';
325 10         53 sprintf "%0$width$base", $offset + $from;
326             }xge;
327 5         94 $parse->();
328 5         21 $from++;
329             }
330 1         6 return;
331             } else {
332 0         0 error("bad \$GENERATE");
333             }
334             } elsif (/^\$ttl\b/ig) {
335 17 100       321 if (/\G\s+($pat_ttl)$pat_skip$/) {
336 12         29 my $v = $1;
337 12         34 $ttl = $default_ttl = ttl_fromtext($v);
338 12 50 33     68 if ($default_ttl < 0 || $default_ttl > $MAXIMUM_TTL) {
339 0         0 error("bad TTL value `$v'");
340             } else {
341 12 50       31 debug("\$TTL < $default_ttl\n") if $debug;
342             }
343             } else {
344 5         15 error("wrong \$TTL");
345             }
346 12         32 return;
347             } elsif (/^$pat_skip$/g) {
348             # skip
349 213         599 return;
350             } elsif (/^[ \t]+/g) {
351             # fall through
352             } elsif (/^\.[ \t]+/g) {
353 18         31 $domain = ".";
354             } elsif (/^\@[ \t]+/g) {
355 13         26 $domain = $origin;
356 13 100       63 $domain =~ s/^.// unless $domain eq ".";
357             } elsif (/^$/g) {
358             # skip
359 0         0 return;
360             } elsif (/^($pat_name\.)[ \t]+/g) {
361 81         252 $domain = $1;
362             } elsif (/^($pat_name)[ \t]+/g) {
363 47         128 $domain = "$1$origin";
364             } else {
365 4         24 error("syntax error");
366             }
367 172 100       4038 if (/\G($pat_ttl)[ \t]+/gc) {
368 68         140 my $v = $1;
369 68         173 $ttl = ttl_fromtext($v);
370 68 50       191 if ($ttl == 0) {
371 0         0 $ttl = $default_ttl;
372             } else {
373 68 50 33     380 if ($ttl < 0 || $ttl > $MAXIMUM_TTL) {
374 0         0 error("bad TTL value `$v'");
375             }
376             }
377             } else {
378 104         162 $ttl = $default_ttl;
379             }
380 172 100       736 if (/\G(in)[ \t]+/igc) {
381             # skip; we only support IN class
382             }
383 172 100       2090 if (/\G(a)[ \t]+/igc) {
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
384 42 50 33     1118 if (/\G(\d+)\.(\d+)\.(\d+)\.(\d+)$pat_skip$/ &&
      33        
      33        
      33        
385             $1 < 256 && $2 < 256 && $3 < 256 && $4 < 256) {
386 42         564 push @zone, {
387             Line => $ln,
388             name => $domain,
389             type => "A",
390             ttl => $ttl,
391             class => "IN",
392             address => "$1.$2.$3.$4",
393             };
394             } else {
395 0         0 error("bad IP address");
396             }
397             } elsif (/\G(ptr)[ \t]+/igc) {
398 21 50       2333 if (/\G($pat_maybefullname)$pat_skip$/gc) {
    0          
399 21         47 my $name = $1;
400 21 50       83 $name = "$name$origin" unless $name =~ /\.$/;
401 21         36 chop $name;
402 21         201 push @zone, {
403             Line => $ln,
404             name => $domain,
405             type => "PTR",
406             ttl => $ttl,
407             class => "IN",
408             ptrdname => $name,
409             };
410             } elsif (/\G\@$pat_skip$/gc) {
411 0         0 my $name = $origin;
412 0 0       0 $name =~ s/^.// unless $name eq ".";
413 0         0 chop $name;
414 0         0 push @zone, {
415             Line => $ln,
416             name => $domain,
417             type => "PTR",
418             ttl => $ttl,
419             class => "IN",
420             ptrdname => $name,
421             };
422             } else {
423 0         0 error("bad name in PTR");
424             }
425             } elsif (/\G(afsdb)[ \t]+/igc) {
426 0         0 my $subtype;
427 0 0       0 if (/\G(\d+)[ \t]+/gc) {
428 0         0 $subtype = $1;
429             } else {
430 0         0 error("bad subtype in AFSDB");
431             }
432 0 0       0 if (/\G($pat_maybefullname)$pat_skip$/gc) {
433 0         0 my $name = $1;
434 0 0       0 $name = "$name$origin" unless $name =~ /\.$/;
435 0         0 chop $name;
436 0         0 push @zone, {
437             Line => $ln,
438             name => $domain,
439             type => "AFSDB",
440             ttl => $ttl,
441             class => "IN",
442             subtype => $subtype,
443             hostname => $name,
444             };
445             }
446             } elsif (/\G(cname)[ \t]+/igc) {
447 6 100       1601 if (/\G($pat_maybefullname)$pat_skip$/gc) {
    50          
448 5         17 my $name = $1;
449 5 50       25 $name = "$name$origin" unless $name =~ /\.$/;
450 5         48 chop $name;
451 5         226 push @zone, {
452             Line => $ln,
453             name => $domain,
454             type => "CNAME",
455             ttl => $ttl,
456             class => "IN",
457             cname => $name,
458             };
459             } elsif (/\G\@$pat_skip$/gc) {
460 1         3 my $name = $origin;
461 1 50       8 $name =~ s/^.// unless $name eq ".";
462 1         2 chop $name;
463 1         9 push @zone, {
464             Line => $ln,
465             name => $domain,
466             type => "CNAME",
467             ttl => $ttl,
468             class => "IN",
469             cname => $name,
470             };
471             } else {
472 0         0 error("bad cname in CNAME");
473             }
474             } elsif (/\G(dname)[ \t]+/igc) {
475 2 50       619 if (/\G($pat_maybefullname)$pat_skip$/gc) {
    0          
476 2         5 my $name = $1;
477 2 50       11 $name = "$name$origin" unless $name =~ /\.$/;
478 2         21 chop $name;
479 2         208 push @zone, {
480             Line => $ln,
481             name => $domain,
482             type => "DNAME",
483             ttl => $ttl,
484             class => "IN",
485             dname => $name,
486             };
487             } elsif (/\G\@$pat_skip$/gc) {
488 0         0 my $name = $origin;
489 0 0       0 $name =~ s/^.// unless $name eq ".";
490 0         0 chop $name;
491 0         0 push @zone, {
492             Line => $ln,
493             name => $domain,
494             type => "DNAME",
495             ttl => $ttl,
496             class => "IN",
497             dname => $name,
498             };
499             } else {
500 0         0 error("bad dname in DNAME");
501             }
502             } elsif (/\G(mx)[ \t]+/igc) {
503 23         35 my $prio;
504 23 100       79 if (/\G(\d+)[ \t]+/gc) {
505 22         48 $prio = $1;
506             } else {
507 1         4 error("bad priority in MX");
508             }
509 22 50       2211 if (/\G($pat_maybefullnameorroot)$pat_skip$/gc) {
    0          
510 22         56 my $name = $1;
511 22 50       96 $name = "$name$origin" unless $name =~ /\.$/;
512 22         43 chop $name;
513 22         462 push @zone, {
514             Line => $ln,
515             name => $domain,
516             type => "MX",
517             ttl => $ttl,
518             class => "IN",
519             preference => $prio,
520             exchange => $name,
521             };
522             } elsif (/\G\@$pat_skip$/gc) {
523 0         0 my $name = $origin;
524 0 0       0 $name =~ s/^.// unless $name eq ".";
525 0         0 chop $name;
526 0         0 push @zone, {
527             Line => $ln,
528             name => $domain,
529             type => "MX",
530             ttl => $ttl,
531             class => "IN",
532             preference => $prio,
533             exchange => $name,
534             };
535             } else {
536 0         0 error("bad exchange in MX");
537             }
538             } elsif (/\G(aaaa)[ \t]+/igc) {
539 7 100       287 if (/\G([\da-fA-F:.]+)$pat_skip$/) {
540             # parsing stolen from Net::DNS::RR::AAAA
541 5         65 my $string = $1;
542 5 50       41 if ($string =~ /^(.*):(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
543 0         0 my ($front, $a, $b, $c, $d) = ($1, $2, $3, $4, $5);
544 0         0 $string = $front . sprintf(":%x:%x",
545             ($a << 8 | $b),
546             ($c << 8 | $d));
547             }
548              
549 5         11 my @addr;
550 5 50       29 if ($string =~ /^(.*)::(.*)$/) {
551 5         17 my ($front, $back) = ($1, $2);
552 5         26 my @front = split(/:/, $front);
553 5         17 my @back = split(/:/, $back);
554 5 50       33 my $fill = 8 - (@front ? $#front + 1 : 0)
    50          
555             - (@back ? $#back + 1 : 0);
556 5         18 my @middle = (0) x $fill;
557 5         28 @addr = (@front, @middle, @back);
558             } else {
559 0         0 @addr = split(/:/, $string);
560 0 0       0 if (@addr < 8) {
561 0         0 @addr = ((0) x (8 - @addr), @addr);
562             }
563             }
564              
565 40         174 push @zone, {
566             Line => $ln,
567             name => $domain,
568             type => "AAAA",
569             ttl => $ttl,
570             class => "IN",
571             address => sprintf("%x:%x:%x:%x:%x:%x:%x:%x",
572 5         18 map { hex $_ } @addr),
573             };
574             } else {
575 2         6 error("bad IPv6 address");
576             }
577             } elsif (/\G(ns)[ \t]+/igc) {
578 11 50       1284 if (/\G($pat_maybefullname)$pat_skip$/gc) {
    0          
579 11         25 my $name = $1;
580 11 50       43 $name = "$name$origin" unless $name =~ /\.$/;
581 11         19 chop $name;
582 11         210 push @zone, {
583             Line => $ln,
584             name => $domain,
585             type => "NS",
586             ttl => $ttl,
587             class => "IN",
588             nsdname => lc($name),
589             };
590             } elsif (/\G\@$pat_skip$/gc) {
591 0         0 my $name = $origin;
592 0 0       0 $name =~ s/^.// unless $name eq ".";
593 0         0 chop $name;
594 0         0 push @zone, {
595             Line => $ln,
596             name => $domain,
597             type => "NS",
598             ttl => $ttl,
599             class => "IN",
600             nsdname => lc($name),
601             };
602             } else {
603 0         0 error("bad name in NS");
604             }
605             } elsif (/\G(soa)\b/igc) {
606 26         63 $parse = \&parse_soa_name;
607 26         604 $soa = {
608             Line => $ln,
609             name => $domain,
610             type => "SOA",
611             ttl => $ttl,
612             class => "IN",
613             breakable => 0,
614             nextkey => "mname",
615             };
616 26         73 $parse->();
617 23         92 return;
618             } elsif (/\G(txt|spf)[ \t]+/igc) {
619 10         29 my $type = uc($1);
620 10 50       211 if (/\G('[^']+')$pat_skip$/gc) {
    50          
    0          
621 0         0 push @zone, {
622             Line => $ln,
623             name => $domain,
624             type => $type,
625             ttl => $ttl,
626             class => "IN",
627             txtdata => $1,
628             };
629             } elsif (/\G("[^"]+")$pat_skip$/gc) {
630 10         98 push @zone, {
631             Line => $ln,
632             name => $domain,
633             type => $type,
634             ttl => $ttl,
635             class => "IN",
636             txtdata => $1,
637             };
638             } elsif (/\G(["']?.*?["']?)$pat_skip$/gc) {
639 0         0 push @zone, {
640             Line => $ln,
641             name => $domain,
642             type => $type,
643             ttl => $ttl,
644             class => "IN",
645             txtdata => $1,
646             };
647             } else {
648 0         0 error("bad txtdata in $type");
649             }
650             } elsif (/\G(type[0-9]+)[ \t]+/igc) {
651 0         0 my $type = $1;
652 0 0       0 if (/\G\\#\s+(\d+)\s+\(\s(.*)$/gc) {
    0          
653             # multi-line
654 0         0 $sshfp = {
655             Line => $ln,
656             name => $domain,
657             type => uc $type,
658             ttl => $ttl,
659             class => "IN",
660             fptype => $1,
661             fingerprint => $2,
662             };
663 0         0 $parse = \&parse_sshfp;
664             } elsif (/\G\\#\s+(\d+)\s+(.*)$pat_skip$/gc) {
665 0         0 push @zone, {
666             Line => $ln,
667             name => $domain,
668             type => uc $type,
669             ttl => $ttl,
670             class => "IN",
671             fptype => $1,
672             fingerprint => $2,
673             };
674             } else {
675 0         0 error("bad data in in $type");
676             }
677             } elsif (/\G(sshfp)[ \t]+/igc) {
678 1 50       44 if (/\G(\d+)\s+(\d+)\s+\(\s*$/gc) {
    50          
679             # multi-line
680 0         0 $sshfp = {
681             Line => $ln,
682             name => $domain,
683             type => "SSHFP",
684             ttl => $ttl,
685             class => "IN",
686             algorithm => $1,
687             fptype => $2,
688             };
689 0         0 $parse = \&parse_sshfp;
690             } elsif (/\G(\d+)\s+(\d+)\s+([a-zA-Z0-9]+)$pat_skip$/gc) {
691 1         15 push @zone, {
692             Line => $ln,
693             name => $domain,
694             type => "SSHFP",
695             ttl => $ttl,
696             class => "IN",
697             algorithm => $1,
698             fptype => $2,
699             fingerprint => $3,
700             };
701             } else {
702 0         0 error("bad data in in SSHFP");
703             }
704             } elsif (/\G(loc)[ \t]+/igc) {
705             # parsing stolen from Net::DNS::RR::LOC
706 0 0       0 if (/\G (\d+) \s+ # deg lat
707             ((\d+) \s+)? # min lat
708             (([\d.]+) \s+)? # sec lat
709             (N|S) \s+ # hem lat
710             (\d+) \s+ # deg lon
711             ((\d+) \s+)? # min lon
712             (([\d.]+) \s+)? # sec lon
713             (E|W) \s+ # hem lon
714             (-?[\d.]+) m? # altitude
715             (\s+ ([\d.]+) m?)? # size
716             (\s+ ([\d.]+) m?)? # horiz precision
717             (\s+ ([\d.]+) m?)? # vert precision
718             $pat_skip
719             $/ixgc) {
720             # Defaults (from RFC 1876, Section 3).
721 0         0 my $default_min = 0;
722 0         0 my $default_sec = 0;
723 0         0 my $default_size = 1;
724 0         0 my $default_horiz_pre = 10_000;
725 0         0 my $default_vert_pre = 10;
726              
727             # Reference altitude in centimeters (see RFC 1876).
728 0         0 my $reference_alt = 100_000 * 100;
729              
730 0         0 my $version = 0;
731              
732 0         0 my ($latdeg, $latmin, $latsec, $lathem) = ($1, $3, $5, $6);
733 0         0 my ($londeg, $lonmin, $lonsec, $lonhem) = ($7, $9, $11, $12);
734 0         0 my ($alt, $size, $horiz_pre, $vert_pre) = ($13, $15, $17, $19);
735              
736 0 0       0 $latmin = $default_min unless $latmin;
737 0 0       0 $latsec = $default_sec unless $latsec;
738 0         0 $lathem = uc($lathem);
739              
740 0 0       0 $lonmin = $default_min unless $lonmin;
741 0 0       0 $lonsec = $default_sec unless $lonsec;
742 0         0 $lonhem = uc($lonhem);
743              
744 0 0       0 $size = $default_size unless $size;
745 0 0       0 $horiz_pre = $default_horiz_pre unless $horiz_pre;
746 0 0       0 $vert_pre = $default_vert_pre unless $vert_pre;
747              
748 0         0 push @zone, {
749             Line => $ln,
750             name => $domain,
751             type => "LOC",
752             ttl => $ttl,
753             class => "IN",
754             version => $version,
755             size => $size * 100,
756             horiz_pre => $horiz_pre * 100,
757             vert_pre => $vert_pre * 100,
758             latitude => dms2latlon($latdeg, $latmin, $latsec, $lathem),
759             longitude => dms2latlon($londeg, $lonmin, $lonsec, $lonhem),
760             altitude => $alt * 100 + $reference_alt,
761             };
762             } else {
763 0         0 error("bad LOC data");
764             }
765             } elsif (/\G(hinfo)[ \t]+/igc) {
766 4 100       122 if (/\G(["'].*?["']|\S+)\s+(["'].*?["']|\S+)$pat_skip$/gc) {
767 3         21 my $result = {
768             Line => $ln,
769             name => $domain,
770             type => "HINFO",
771             ttl => $ttl,
772             class => "IN",
773             cpu => $1,
774             os => $2,
775             };
776 3         12 $result->{'cpu'} =~ s/^["']//;
777 3         10 $result->{'cpu'} =~ s/["']$//;
778 3         8 $result->{'os'} =~ s/^["']//;
779 3         7 $result->{'os'} =~ s/["']$//;
780 3         17 push @zone, $result;
781             } else {
782 1         4 error("bad HINFO data");
783             }
784             } elsif (/\G(srv)[ \t]+/igc) {
785             # parsing stolen from Net::DNS::RR::SRV
786 0 0       0 if (/\G(\d+)\s+(\d+)\s+(\d+)\s+(\S+)$pat_skip$/gc) {
787 0         0 push @zone, {
788             Line => $ln,
789             name => $domain,
790             type => "SRV",
791             ttl => $ttl,
792             class => "IN",
793             priority => $1,
794             weight => $2,
795             port => $3,
796             target => $4,
797             };
798 0         0 $zone[-1]->{target} =~ s/\.+$//;
799             } else {
800 0         0 error("bad SRV data");
801             }
802             } elsif (/\G(key)[ \t]+/igc) {
803 0 0       0 if (!/\G(\d+)\s+(\d+)\s+(\d+)\s+/gc) {
804 0         0 error("bad KEY data 1");
805             }
806             $dnskey = {
807 0         0 first => 1,
808             Line => $ln,
809             name => $domain,
810             ttl => $ttl,
811             class => "IN",
812             type => "KEY",
813             flags => $1,
814             protocol => $2,
815             algorithm => $3
816             };
817 0 0       0 if (/\G\(\s*$/gc) {
    0          
818             # multi-line
819 0         0 $parse = \&parse_dnskey;
820             } elsif (/\G(.*\S)\s*$/) {
821             # single-line
822 0         0 $dnskey->{'key'} .= $1;
823 0         0 $dnskey->{'key'} =~ s/\s//g;
824 0         0 $dnskey->{'keybin'} = decode_base64($dnskey->{'key'});
825 0         0 push @zone, $dnskey;
826 0         0 $dnskey = undef;
827             } else {
828 0         0 error("bad KEY data 2");
829             }
830              
831             } elsif (/\G(rrsig)[ \t]+/igc) {
832 3 50       13 if (/\G(\w+)\s+(\d+)\s+(\d+)\s+(\d+)\s+/gc) {
833             # some versions of bind (>=10) put the sig-expir on the first line
834 3         37 $rrsig = {
835             first => 1,
836             Line => $ln,
837             name => $domain,
838             type => "RRSIG",
839             class => "IN",
840             ttl => $ttl,
841             typecovered => $1,
842             algorithm => $2,
843             labels => $3,
844             orgttl => $4,
845             };
846             } else {
847 0         0 error("bad RRSIG data 1");
848             }
849              
850 3 50       10 if (/\G(\d+)\s+/gc) {
851             # some versions of bind (<10) put the sig-expir on the first line
852             # and newer ones put it on the next.
853 3         10 $rrsig->{'sigexpiration'} = $1;
854             } else {
855 0         0 $rrsig->{'needsigexp'} = $1;
856             }
857              
858 3 100       157 if (/\G\(\s*$/gc) {
    50          
859             # multi-line
860 2         9 $parse = \&parse_rrsig;
861             } elsif (/\G(\d+)\s+(\d+)\s+($pat_maybefullnameorroot)\s+([^=]+=)\s*/gc) {
862             # single-line
863 1         4 $rrsig->{'siginception'} = $1;
864 1         2 $rrsig->{'keytag'} = $2;
865 1         3 $rrsig->{'signame'} = $3;
866 1         3 $rrsig->{'sig'} = $4;
867 1         7 $rrsig->{'sigbin'} = decode_base64($rrsig->{'sig'});
868 1         3 push @zone, $rrsig;
869 1         5 $rrsig = undef;
870             } else {
871 0         0 error("bad RRSIG data 2");
872             }
873             } elsif (/\G(dnskey)[ \t]+/igc) {
874 0 0       0 if (!/\G(\d+)\s+(\d+)\s+(\d+)\s+/gc) {
875 0         0 error("bad DNSKEY data 1");
876             }
877             $dnskey = {
878 0         0 first => 1,
879             Line => $ln,
880             name => $domain,
881             ttl => $ttl,
882             class => "IN",
883             type => "DNSKEY",
884             flags => $1,
885             protocol => $2,
886             algorithm => $3
887             };
888 0 0       0 if (/\G\(\s*$/gc) {
    0          
889             # multi-line
890 0         0 $parse = \&parse_dnskey;
891             } elsif (/\G([\sA-Za-z0-9\+\/=]+).*$/) {
892             # single-line
893 0         0 $dnskey->{'key'} .= $1;
894 0         0 $dnskey->{'key'} =~ s/\s//g;
895 0         0 $dnskey->{'keybin'} = decode_base64($dnskey->{'key'});
896 0         0 push @zone, $dnskey;
897 0         0 $dnskey = undef;
898             } else {
899 0         0 error("bad DNSKEY data 2");
900             }
901             } elsif (/\G(ds)[ \t]+/igc) {
902 0 0       0 if (!/\G(\d+)\s+(\d+)\s+(\d+)\s+/gc) {
903 0         0 error("bad DS data 1");
904             }
905             $ds = {
906 0         0 Line => $ln,
907             name => $domain,
908             class => "IN",
909             ttl => $ttl,
910             type => "DS",
911             keytag => $1,
912             algorithm => $2,
913             digtype => $3,
914             };
915 0 0       0 if (/\G\(\s*$/gc) {
    0          
916             # multi-line
917 0         0 $parse = \&parse_ds;
918             } elsif (/\G(.*\S)\s*$/) {
919             # single line
920 0         0 $ds->{'digest'} .= $1;
921 0         0 $ds->{'digest'} = lc($ds->{'digest'});
922 0         0 $ds->{'digest'} =~ s/\s//g;
923             # remove any surrounding single line ()s
924 0         0 $ds->{'digest'} =~ s/^\(//;
925 0         0 $ds->{'digest'} =~ s/\)$//;
926 0         0 $ds->{'digestbin'} = pack("H*", $ds->{'digest'});
927 0         0 push @zone, $ds;
928 0         0 $ds = undef;
929             } else {
930 0         0 error("bad DS data");
931             }
932             } elsif (/\G(tlsa)[ \t]+/igc) {
933 3 50       14 if (!/\G(\d+)\s+(\d+)\s+(\d+)\s+/gc) {
934 0         0 error("bad TLSA data 1");
935             }
936             $tlsa = {
937 3         29 Line => $ln,
938             name => $domain,
939             class => "IN",
940             ttl => $ttl,
941             type => "TLSA",
942             usage => $1,
943             selector => $2,
944             matchingtype => $3,
945             };
946 3 100       17 if (/\G\(\s*$/gc) {
    50          
947             # multi-line
948 1         5 $parse = \&parse_tlsa;
949             } elsif (/\G(.*\S)\s*$/) {
950             # single line
951 2         7 $tlsa->{'cert'} .= $1;
952 2         7 $tlsa->{'cert'} = lc($tlsa->{'cert'});
953 2         8 $tlsa->{'cert'} =~ s/\s//g;
954             # remove any surrounding single line ()s
955 2         6 $tlsa->{'cert'} =~ s/^\(//;
956 2         6 $tlsa->{'cert'} =~ s/\)$//;
957 2         11 $tlsa->{'certbin'} = pack("H*", $tlsa->{'cert'});
958 2         4 push @zone, $tlsa;
959 2         10 $tlsa = undef;
960             } else {
961 0         0 error("bad TLSA data");
962             }
963             } elsif (/\G(nsec)[ \t]+/igc) {
964 0 0       0 if (/\G\s*($pat_maybefullnameorroot)\s+(.*?)$pat_skip$/gc) {
965             # XXX: set the typebm field ourselves?
966 0         0 my ($nxtdname, $typelist) = ($1, $2);
967 0         0 $typelist = join(" ",sort split(/\s+/,$typelist));
968 0         0 push @zone,
969             {
970             Line => $ln,
971             name => $domain,
972             class => "IN",
973             ttl => $ttl,
974             type => "NSEC",
975             nxtdname => $nxtdname,
976             typelist => $typelist,
977             typebm =>
978             Net::DNS::RR::NSEC::_typearray2typebm(split(/\s+/,$typelist)),
979             };
980             } else {
981 0         0 error("bad NSEC data");
982             }
983             } elsif (/\G(nsec3)[ \t]+/igc) {
984 0 0       0 error ("You are missing required modules for NSEC3 support")
985             if (!$nsec3capable);
986 0 0       0 if (/\G\s*(\d+)\s+(\d+)\s+(\d+)\s+([-0-9A-Fa-f]+)\s+($pat_maybefullname)\s*(.*?)$pat_skip$/gc) {
    0          
987             # XXX: set the typebm field ourselves?
988 0         0 my ($alg, $flags, $iters, $salt, $nxthash, $typelist) =
989             ($1, $2, $3, $4, $5, $6);
990 0         0 $typelist = join(" ",sort split(/\s+/,$typelist));
991 0         0 my $binhash = MIME::Base32::decode(uc($nxthash));
992 0         0 push @zone,
993             {
994             Line => $ln,
995             name => $domain,
996             class => "IN",
997             ttl => $ttl,
998             type => "NSEC3",
999             hashalgo => $alg,
1000             flags => $flags,
1001             iterations => $iters,
1002             hnxtname => $nxthash,
1003             hnxtnamebin => $binhash,
1004             hashlength => length($binhash),
1005             salt => $salt,
1006             saltbin => pack("H*",$salt),
1007             saltlength => int(length($salt)/2),
1008             typelist => $typelist,
1009             typebm =>
1010             Net::DNS::RR::NSEC::_typearray2typebm(split(/\s+/,$typelist)),
1011             };
1012             # multi-line
1013             } elsif (/\G\s*(\d+)\s+(\d+)\s+(\d+)\s+([-0-9A-Fa-f]+)\s+\(/gc) {
1014             # XXX: set the typebm field ourselves?
1015 0         0 my ($alg, $flags, $iters, $salt) =
1016             ($1, $2, $3, $4);
1017 0         0 $nsec3 = {
1018             Line => $ln,
1019             name => $domain,
1020             class => "IN",
1021             ttl => $ttl,
1022             type => "NSEC3",
1023             hashalgo => $alg,
1024             flags => $flags,
1025             iterations => $iters,
1026             salt => $salt,
1027             saltbin => pack("H*",$salt),
1028             saltlength => int(length($salt)/2),
1029             };
1030 0         0 $parse = \&parse_nsec3;
1031             } else {
1032 0         0 error("bad NSEC data");
1033             }
1034             } elsif (/\G(nsec3param)[ \t]+/igc) {
1035 0 0       0 if (/\G\s*(\d+)\s+(\d+)\s+(\d+)\s+([-0-9A-Fa-f]+)$pat_skip$/gc) {
1036             # XXX: set the typebm field ourselves?
1037 0         0 my ($alg, $flags, $iters, $salt) = ($1, $2, $3, $4);
1038 0         0 push @zone,
1039             {
1040             Line => $ln,
1041             name => $domain,
1042             class => "IN",
1043             ttl => $ttl,
1044             type => "NSEC3PARAM",
1045             hashalgo => $alg,
1046             flags => $flags,
1047             iterations => $iters,
1048             salt => $salt,
1049             saltbin => pack("H*",$salt),
1050             saltlength => int(length($salt)/2),
1051             };
1052             } else {
1053 0         0 error("bad NSEC data");
1054             }
1055             } elsif (/\G(rp)[ \t]+/igc) {
1056 4         9 my $mbox;
1057 4 50       2980 if (/\G($pat_maybefullname)[ \t]+/gc) {
    0          
1058 4         18 $mbox = $1;
1059 4 100       30 $mbox = "$mbox$origin" unless $mbox =~ /\.$/;
1060 4         14 chop $mbox;
1061             } elsif (/\G\@[ \t]+/gc) {
1062 0         0 $mbox = $origin;
1063 0 0       0 $mbox =~ s/^.// unless $mbox eq ".";
1064 0         0 chop $mbox;
1065             } else {
1066 0         0 error("bad mbox in PTR");
1067             }
1068              
1069 4         786 my $txtdname;
1070 4 100       1943 if (/\G($pat_maybefullname)$pat_skip$/gc) {
    50          
1071 3         12 $txtdname = $1;
1072 3 100       19 $txtdname = "$txtdname$origin" unless $txtdname =~ /\.$/;
1073 3         10 chop $txtdname;
1074             } elsif (/\G\@$pat_skip$/gc) {
1075 1         3 $txtdname = $origin;
1076 1 50       7 $txtdname =~ s/^.// unless $txtdname eq ".";
1077 1         3 chop $txtdname;
1078             } else {
1079 0         0 error("bad txtdname in PTR");
1080             }
1081              
1082 4         935 push @zone, {
1083             Line => $ln,
1084             name => $domain,
1085             type => "RP",
1086             ttl => $ttl,
1087             class => "IN",
1088             mbox => $mbox,
1089             txtdname => $txtdname,
1090             };
1091             } elsif (/\G(naptr)[ \t]+/igc) {
1092             # Parsing taken from Net::DNS::RR::NAPTR
1093 0 0       0 if (!/\G(\d+) \s+ (\d+) \s+ ['"] (.*?) ['"] \s+ ['"] (.*?) ['"] \s+ ['"] (.*?) ['"] \s+ (\S+)$/xgc) {
1094 0         0 error("bad NAPTR data");
1095             }
1096 0         0 push @zone,
1097             {
1098             Line => $ln,
1099             name => $domain,
1100             class => "IN",
1101             ttl => $ttl,
1102             type => "NAPTR",
1103              
1104             order => $1,
1105             preference => $2,
1106             flags => $3,
1107             service => $4,
1108             regexp => $5,
1109             replacement => $6,
1110             };
1111 0         0 $zone[ $#zone ]{replacement} =~ s/\.+$//;
1112             } elsif (/\Gany\s+tsig.*$/igc) {
1113             # XXX ignore tsigs
1114             } else {
1115 9         46 error("unrecognized type for $domain\n$_\n");
1116             }
1117             }
1118              
1119             # Reference lat/lon (see RFC 1876).
1120             my $reference_latlon = 2**31;
1121             # Conversions to/from thousandths of a degree.
1122             my $conv_sec = 1000;
1123             my $conv_min = 60 * $conv_sec;
1124             my $conv_deg = 60 * $conv_min;
1125              
1126             sub dms2latlon {
1127 0     0 0 0 my ($deg, $min, $sec, $hem) = @_;
1128 0         0 my ($retval);
1129              
1130 0         0 $retval = ($deg * $conv_deg) + ($min * $conv_min) + ($sec * $conv_sec);
1131 0 0 0     0 $retval = -$retval if ($hem eq "S") || ($hem eq "W");
1132 0         0 $retval += $reference_latlon;
1133 0         0 return $retval;
1134             }
1135              
1136             sub parse_soa_name
1137             {
1138 51 50   51 0 127 error("parse_soa_name: internal error, no \$soa") unless $soa;
1139 51 50       121 if ($soa->{breakable}) {
1140 0 0       0 if (/\G[ \t]*($pat_maybefullname)$pat_skip$/igc) {
    0          
    0          
    0          
1141 0         0 $soa->{$soa->{nextkey}} = $1;
1142             } elsif (/\G$pat_skip$/gc) {
1143 0         0 return;
1144             } elsif (/\G[ \t]*(\@)[ \t]/igc) {
1145 0         0 $soa->{$soa->{nextkey}} = $origin;
1146             } elsif (/\G[ \t]*($pat_name\.)[ \t]/igc) {
1147 0         0 $soa->{$soa->{nextkey}} = $1;
1148             } else {
1149 0         0 error("expected valid $soa->{nextkey}");
1150             }
1151             } else {
1152 51 100       3962 if (/\G[ \t]*($pat_maybefullname)/igc) {
    50          
    100          
    50          
1153 47         222 $soa->{$soa->{nextkey}} = $1;
1154             } elsif (/\G[ \t]*\($pat_skip$/igc) {
1155 0         0 $soa->{breakable} = 1;
1156 0         0 return;
1157             } elsif (/\G[ \t]*(\@)[ \t]/igc) {
1158 2         7 $soa->{$soa->{nextkey}} = $origin;
1159             } elsif (/\G[ \t]*\(/igc) {
1160 0         0 $soa->{breakable} = 1;
1161 0         0 $parse->();
1162 0         0 return;
1163             } else {
1164 2         8 error("expected valid $soa->{nextkey}");
1165             }
1166             }
1167 49 100       881 if ($soa->{nextkey} eq "mname") {
    50          
1168 25         73 $soa->{mname} = lc($soa->{mname});
1169 25         44 $soa->{nextkey} = "rname";
1170             } elsif ($soa->{nextkey} eq "rname") {
1171 24         54 $soa->{rname} = lc($soa->{rname});
1172 24         40 $soa->{nextkey} = "serial";
1173 24         47 $parse = \&parse_soa_number;
1174             } else {
1175 0 0       0 error("parse_soa_name: internal error, bad {nextkey}") unless $soa;
1176             }
1177 49         121 $parse->();
1178             }
1179              
1180             sub ttl_or_serial
1181             {
1182 115     115 0 191 my ($v) = @_;
1183 115 100       227 if ($soa->{nextkey} eq "serial") {
1184 23 50       97 error("bad serial number") unless $v =~ /^\d+$/;
1185             } else {
1186 92         156 $v = ttl_fromtext($v);
1187 92 50       177 error("bad $soa->{nextkey}") unless $v;
1188             }
1189 115         388 return $v;
1190             }
1191              
1192             sub parse_rrsig
1193             {
1194             # got more data
1195 17 100   17 0 29 if ($rrsig->{'first'}) {
1196 2         5 delete $rrsig->{'first'};
1197 2 50 33     105 if (exists($rrsig->{'needsigexp'}) &&
    50 33        
1198             /\G\s*(\d+)\s+(\d+)\s+(\d+)\s+($pat_maybefullnameorroot)/gc) {
1199 0         0 delete $rrsig->{'needsigexp'};
1200 0         0 $rrsig->{'sigexpiration'} = $1;
1201 0         0 $rrsig->{'siginception'} = $2;
1202 0         0 $rrsig->{'keytag'} = $3;
1203 0         0 $rrsig->{'signame'} = $4;
1204             } elsif (!exists($rrsig->{'needsigexp'}) &&
1205             /\G\s*(\d+)\s+(\d+)\s+($pat_maybefullnameorroot)/gc) {
1206 2         7 $rrsig->{'siginception'} = $1;
1207 2         5 $rrsig->{'keytag'} = $2;
1208 2         8 $rrsig->{'signame'} = $3;
1209             } else {
1210 0         0 error("bad rrsig second line");
1211             }
1212             } else {
1213 15 100       52 if (/\)\s*$/) {
1214 2 50       16 if (/\G\s*(\S+)\s*\)\s*$/gc) {
1215 2         7 $rrsig->{'sig'} .= $1;
1216 2         23 $rrsig->{'sigbin'} = decode_base64($rrsig->{'sig'});
1217             # we're done
1218 2         5 $parse = \&parse_line;
1219              
1220 2         8 push @zone, $rrsig;
1221 2         13 $rrsig = undef;
1222             } else {
1223 0         0 error("bad rrsig last line");
1224             }
1225             } else {
1226 13 50       44 if (/\G\s*(\S+)\s*$/gc) {
1227 13         37 $rrsig->{'sig'} .= $1;
1228             } else {
1229 0         0 error("bad rrsig remaining lines");
1230             }
1231             }
1232             }
1233             }
1234              
1235             sub parse_sshfp
1236             {
1237             # got more data
1238 0 0   0 0 0 if (/\)\s*$/) {
1239             # last line
1240 0 0       0 if (/\G\s*(\S+)\s*\)\s*$/gc) {
1241 0         0 $sshfp->{'fingerprint'} .= $1;
1242             # we're done
1243 0         0 $parse = \&parse_line;
1244              
1245 0         0 push @zone, $sshfp;
1246 0         0 $sshfp = undef;
1247             } else {
1248 0         0 error("bad sshfp last line");
1249             }
1250             } else {
1251 0 0       0 if (/\G\s*(\S+)\s*$/gc) {
1252 0         0 $sshfp->{'fingerprint'} .= $1;
1253             } else {
1254 0         0 error("bad sshfp remaining lines");
1255             }
1256             }
1257             }
1258              
1259             sub parse_dnskey
1260             {
1261             # got more data?
1262 0 0   0 0 0 if (/\)\s*;.*$/) {
1263 0 0       0 if (/\G\s*(\S*)\s*\)\s*;.*$/gc) {
1264 0         0 $dnskey->{'key'} .= $1;
1265             # we're done
1266 0         0 $parse = \&parse_line;
1267              
1268 0         0 $dnskey->{'keybin'} = decode_base64($dnskey->{'key'});
1269 0         0 push @zone, $dnskey;
1270 0         0 $dnskey = undef;
1271             } else {
1272 0         0 error("bad dnskey last line");
1273             }
1274             } else {
1275 0 0       0 if (/\G\s*(\S+)\s*$/gc) {
1276 0         0 $dnskey->{'key'} .= $1;
1277             } else {
1278 0         0 error("bad dnskey remaining lines");
1279             }
1280             }
1281             }
1282              
1283             sub parse_ds
1284             {
1285             # got more data
1286 0 0   0 0 0 if (/\)\s*$/) {
1287 0 0       0 if (/\G\s*(\S*)\s*\)\s*$/gc) {
1288 0         0 $ds->{'digest'} .= $1;
1289 0         0 $ds->{'digest'} = lc($ds->{'digest'});
1290              
1291             # we're done
1292 0         0 $parse = \&parse_line;
1293              
1294 0         0 $ds->{'digestbin'} = pack("H*",$ds->{'digest'});
1295 0         0 push @zone, $ds;
1296 0         0 $ds = undef;
1297             } else {
1298 0         0 error("bad ds last line");
1299             }
1300             } else {
1301 0 0       0 if (/\G\s*(\S+)\s*$/gc) {
1302 0         0 $ds->{'digest'} .= $1;
1303             } else {
1304 0         0 error("bad ds remaining lines");
1305             }
1306             }
1307             }
1308              
1309             sub parse_tlsa
1310             {
1311             # got more data
1312 1 50   1 0 7 if (/\)\s*$/) {
1313 1         6 while (/\G\s*([0-9A-Za-z]+)\s*/gc) {
1314 2         18 $tlsa->{'cert'} .= $1;
1315             }
1316 1 50       6 if (/\G\s*\)$/gc) {
1317 1         4 $tlsa->{'cert'} = lc($tlsa->{'cert'});
1318              
1319             # we're done
1320 1         2 $parse = \&parse_line;
1321              
1322 1         5 $tlsa->{'certbin'} = pack("H*",$tlsa->{'cert'});
1323 1         3 push @zone, $tlsa;
1324 1         5 $tlsa = undef;
1325             } else {
1326 0         0 error("bad tlsa last line: $_");
1327             }
1328             } else {
1329 0 0       0 if (/\G\s*(\S+)\s*$/gc) {
1330 0         0 $tlsa->{'cert'} .= $1;
1331             } else {
1332 0         0 error("bad tlsa remaining lines");
1333             }
1334             }
1335             }
1336              
1337             sub parse_nsec3
1338             {
1339             #got more data
1340 0 0   0 0 0 if ( /\G\s*([A-Z0-9]{32})\s*(\))?/gc) {
    0          
    0          
1341 0         0 my $nxthash = $1;
1342 0         0 my $binhash = MIME::Base32::decode(uc($nxthash));
1343 0         0 $nsec3->{ 'hnxtname' } = $nxthash;
1344 0         0 $nsec3->{ 'hnxtnamebin' } = $binhash;
1345 0         0 $nsec3->{ 'hashlength' } = length( $binhash );
1346 0 0 0     0 if ( defined($2) && $2 eq ')' ) { # Was RR terminated ?
1347 0         0 push @zone, $nsec3;
1348             # we're done
1349 0         0 $parse = \&parse_line;
1350 0         0 $nsec3 = undef;
1351             }
1352             } elsif ( /\G\s+$/gc ) { # Empty line
1353             } elsif ( /\G\s*((\w+\s+)*)\)\s*$/) {
1354 0         0 my $typelist = $1;
1355 0         0 $typelist = join(" ",sort split(/\s+/,$typelist));
1356 0         0 $nsec3->{ 'typelist' } = $typelist;
1357 0         0 $nsec3->{ 'typebm' } =
1358             Net::DNS::RR::NSEC::_typearray2typebm(split(/\s+/,$typelist));
1359 0         0 push @zone, $nsec3;
1360             # we're done
1361 0         0 $parse = \&parse_line;
1362 0         0 $nsec3 = undef;
1363             } else {
1364 0         0 error( "bad NSEC3 continuation lines ($_)" );
1365             }
1366             }
1367              
1368             sub parse_soa_number
1369             {
1370 163 50   163 0 303 error("parse_soa_number: internal error, no \$soa") unless $soa;
1371 163 100       268 if ($soa->{breakable}) {
1372 139 100       1648 if (/\G[ \t]*($pat_ttl)$pat_skip$/igc) {
    100          
    50          
1373 22         42 $soa->{$soa->{nextkey}} = ttl_or_serial($1);
1374             } elsif (/\G$pat_skip$/gc) {
1375 24         76 return;
1376             } elsif (/\G[ \t]*($pat_ttl)\b/igc) {
1377 93         166 $soa->{$soa->{nextkey}} = ttl_or_serial($1);
1378             } else {
1379 0         0 error("expected valid $soa->{nextkey}");
1380             }
1381             } else {
1382 24 50       574 if (/\G[ \t]+($pat_ttl)/igc) {
    100          
    100          
1383 0         0 $soa->{$soa->{nextkey}} = ttl_or_serial($1);
1384             } elsif (/\G[ \t]*\($pat_skip$/igc) {
1385 5         10 $soa->{breakable} = 1;
1386 5         12 return;
1387             } elsif (/\G[ \t]*\(/igc) {
1388 18         32 $soa->{breakable} = 1;
1389 18         40 $parse->();
1390 18         36 return;
1391             } else {
1392 1         10 error("expected valid $soa->{nextkey}");
1393             }
1394             }
1395 115 100       455 if ($soa->{nextkey} eq "serial") {
    100          
    100          
    100          
    50          
1396 23         37 $soa->{nextkey} = "refresh";
1397             } elsif ($soa->{nextkey} eq "refresh") {
1398 23         39 $soa->{nextkey} = "retry";
1399             } elsif ($soa->{nextkey} eq "retry") {
1400 23         39 $soa->{nextkey} = "expire";
1401             } elsif ($soa->{nextkey} eq "expire") {
1402 23         37 $soa->{nextkey} = "minimum";
1403             } elsif ($soa->{nextkey} eq "minimum") {
1404 23         120 $minimum = $soa->{minimum};
1405 23 100       64 $default_ttl = $minimum if $default_ttl <= 0;
1406 23 50       67 $parse = $soa->{breakable} ? \&parse_close : \&parse_line;
1407 23 0 33     69 if (!$soa->{breakable} && !/\G$pat_skip$/gc) {
1408 0         0 error("unexpected trailing garbage after Minimum");
1409             }
1410 23         61 delete $soa->{nextkey};
1411 23         36 delete $soa->{breakable};
1412 23 100       99 $soa->{mname} .= $origin unless ($soa->{mname} =~ /\.$/);
1413 23 100       88 $soa->{rname} .= $origin unless ($soa->{rname} =~ /\.$/);
1414 23         145 $soa->{mname} =~ s/\.$//;
1415 23         76 $soa->{rname} =~ s/\.$//;
1416 23         65 $soa->{Lines} = $ln - $soa->{Line} + 1;
1417 23         39 push @zone, $soa;
1418 23         33 $soa = undef;
1419 23 50       114 return if $parse == \&parse_line;
1420             } else {
1421 0 0       0 error("parse_soa_number: internal error, bad {nextkey}") unless $soa;
1422             }
1423 115         239 $parse->();
1424             }
1425              
1426             sub parse_close
1427             {
1428 25 100   25 0 269 if (/\G[ \t]*\)$pat_skip$/igc) {
    50          
1429 23         73 $zone[-1]->{Lines} = $ln - $zone[-1]->{Line} + 1;
1430 23         37 $parse = \&parse_line;
1431 23         111 return;
1432             } elsif (/\G$pat_skip$/gc) {
1433 2         6 return;
1434             } else {
1435 0         0 error("expected closing block \")\"");
1436             }
1437             }
1438              
1439             sub debug
1440             {
1441 0     0 1 0 print STDERR @_;
1442             }
1443              
1444             sub ttl_fromtext
1445             # zero == invalid value
1446             {
1447 172     172 0 266 my ($t) = @_;
1448 172         209 my $ttl = 0;
1449 172 100       619 if ($t =~ /^\d+$/) {
    50          
1450 164         228 $ttl = $t;
1451             } elsif ($t =~ /^(?:\d+[WDHMS])+$/i) {
1452 8         12 my %ttl;
1453 8   50     38 $ttl{W} ||= 0;
1454 8   50     31 $ttl{D} ||= 0;
1455 8   50     28 $ttl{H} ||= 0;
1456 8   50     29 $ttl{M} ||= 0;
1457 8   50     30 $ttl{S} ||= 0;
1458 8         36 while ($t =~ /(\d+)([WDHMS])/gi) {
1459 15         62 $ttl{uc($2)} += $1;
1460             }
1461 8         31 $ttl = $ttl{S} + 60*($ttl{M} + 60*($ttl{H} + 24*($ttl{D} + 7*$ttl{W})));
1462             }
1463 172         338 return $ttl;
1464             }
1465              
1466             1;
1467              
1468             __END__