# DNS::ZoneParse
# Parse and Manipulate DNS Zonefiles
# Version 0.91
# CVS: $Id: ZoneParse.pm,v 1.20 2003/08/03 14:28:24 simonflack Exp $
package DNS::ZoneParse;

use 5.005;
use Storable 'dclone';
use POSIX 'strftime';
use vars qw($VERSION);
use strict;
use Carp;

$VERSION = '0.91';
my (%dns_id, %dns_soa, %dns_ns, %dns_a, %dns_cname, %dns_mx,
    %dns_txt, %dns_ptr, %dns_a4);


sub new {
    my $class = shift;
    my $self = bless [], $class;

    $self->_initialize();
    $self->_load_file(@_) if @_;
    return $self;
}

sub DESTROY {
    my $self = shift;
    delete $dns_soa   {$self};    delete $dns_ns    {$self};
    delete $dns_a     {$self};    delete $dns_cname {$self};
    delete $dns_mx    {$self};    delete $dns_txt   {$self};
    delete $dns_ptr   {$self};    delete $dns_a4    {$self};
}

sub AUTOLOAD {
    my $self = shift;
    (my $method = $DNS::ZoneParse::AUTOLOAD) =~ s/.*:://;

    my $rv = $method eq 'soa'      ? $dns_soa   {$self}
           : $method eq 'ns'       ? $dns_ns    {$self}
           : $method eq 'a'        ? $dns_a     {$self}
           : $method eq 'cname'    ? $dns_cname {$self}
           : $method eq 'mx'       ? $dns_mx    {$self}
           : $method eq 'txt'      ? $dns_txt   {$self}
           : $method eq 'ptr'      ? $dns_ptr   {$self}
           : $method eq 'aaaa'     ? $dns_a4    {$self}
           : $method eq 'zonefile' ? $dns_id    {$self}->{ZoneFile}
           : $method eq 'origin'   ? $dns_id    {$self}->{Origin}
           : undef;

    croak "Invalid method called: $method" unless defined $rv;
    return $rv;
}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# Public OO Methods
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

sub dump {
    # returns a HOH for use with XML modules, etc
    my $self = shift;
    return dclone({
                   SOA   => $dns_soa   {$self}, AAAA  => $dns_a4  {$self},
                   A     => $dns_a     {$self}, NS    => $dns_ns  {$self},
                   CNAME => $dns_cname {$self}, MX    => $dns_mx  {$self},
                   PTR   => $dns_ptr   {$self}, TXT   => $dns_txt {$self},
                  });
}

sub new_serial {
    my $self = shift;
    my $incriment = shift || 0;
    my $soa = $dns_soa{$self};
    if ($incriment > 0) { 
        $soa->{serial} += $incriment;
    } else {
        my $newserial = strftime("%Y%m%d%H", localtime(time));
        $soa->{serial} = ($newserial > $soa->{serial}) ? $newserial
            : $soa->{serial} + 1;
    }
    return $soa->{serial};
}

sub output {
    my $self = shift;
    my @quick_classes = qw(A AAAA CNAME PTR);
    my $output = "";
    $output .= <<ZONEHEADER;
;
;  Database file $dns_id{$self}->{ZoneFile} for $dns_id{$self}->{Origin} zone.
;	Zone version: $dns_soa{$self}->{serial}
; 

\$TTL $dns_soa{$self}->{ttl}
$dns_soa{$self}->{origin}		$dns_soa{$self}->{ttl}	IN  SOA  $dns_soa{$self}->{primary} $dns_soa{$self}->{email} (
				$dns_soa{$self}->{serial}	; serial number
				$dns_soa{$self}->{refresh}	; refresh
				$dns_soa{$self}->{retry}	; retry
				$dns_soa{$self}->{expire}	; expire
				$dns_soa{$self}->{minimumTTL}	; minimum TTL
				)
;
; Zone NS Records
;

ZONEHEADER

    foreach (@{$dns_ns{$self}}) {
        $output .= "$_->{name}	$_->{ttl}	$_->{class}	NS	$_->{host}\n";
    }

    $output .= "\n\;\n\; Zone MX Records\n\;\n\n";
    foreach (@{$dns_mx{$self}}) {
        $output .= "$_->{name}	$_->{ttl}	$_->{class}	MX	$_->{priority} "
                ." $_->{host}\n";
    }

    $output .= "\n\;\n\; Zone Records\n\;\n\n";
    foreach (@{$dns_a{$self}}) {
        $output .= "$_->{name}	$_->{ttl}	$_->{class}	A	$_->{host}\n";
    }
    foreach (@{$dns_cname{$self}}) {
        $output .= "$_->{name}	$_->{ttl}	$_->{class}	CNAME	$_->{host}\n";
    }
    foreach (@{$dns_a4{$self}}) {
        $output .= "$_->{name}	$_->{ttl}	$_->{class}	AAAA	$_->{host}\n";
    }
    foreach (@{$dns_txt{$self}}) {
        $output .= qq[$_->{name}	$_->{ttl} $_->{class} TXT	"$_->{text}"\n]
    }
    foreach (@{$dns_ptr{$self}}) {
        $output .= "$_->{name}	$_->{ttl}	$_->{class}	PTR		$_->{host}\n";
    }
    return $output;
}


# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# Private Methods
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

sub _initialize {
    my $self = shift;
    $dns_id    {$self} = {};    $dns_soa   {$self} = {};
    $dns_ns    {$self} = [];    $dns_a     {$self} = [];
    $dns_cname {$self} = [];    $dns_mx    {$self} = [];
    $dns_txt   {$self} = [];    $dns_ptr   {$self} = [];
    $dns_a4    {$self} = [];
    return 1;
}


sub _load_file {
    my ($self, $zonefile) = @_;
    my $zone_contents;
    if(ref($zonefile) eq "SCALAR") {
        $zone_contents = $$zonefile;
    } else {
        local *inZONE;
        if (open(inZONE, "$zonefile")) {
            $zone_contents = do {local $/; <inZONE>};
            close(inZONE);
        } else {
            croak qq[DNS::ZoneParse Could not open input file: "$zonefile":$!]
        }
    }
    if ($self->_parse( $zonefile, $zone_contents )) { return 1; }
}


sub _parse {
    my ($self, $zonefile, $contents) = @_;
    $self->_initialize();

    my $chars = qr/[a-z\-\.0-9]+/i;
    $contents =~ /Database file ($chars)( dns)? for ($chars) zone/si;
    $dns_id{$self} = _massage({ ZoneFile => $1 || $zonefile, Origin => $3 });

    my $records    = $self->_clean_records($contents);
    my $valid_name = qr/[\@a-z_\-\.0-9\*]+/i;
    my $valid_ip6  = qr/[\@a-z_\-\.0-9\*:]+/i;
    my $rr_class   = qr/\b(?:in|hs|ch)\b/i;
    my $rr_types   = qr/\b(?:ns|a|cname)\b/i;
    my $rr_ttl     = qr/(?:\d+[wdhms]?)+/i;
    my $ttl_cls    = qr/(?:($rr_ttl)\s+)?(?:\b($rr_class)\s+)?\s*/; 

    _massage();    # reset last_name
    foreach (@$records) {
        if (/^($valid_name)? \s*          # host
              (?:($rr_ttl)\s+)?           # ttl
              (?:\b($rr_class)\s+)?\s*    # class
              ($rr_types) \s+             # record type
              ($valid_name)               # record data
             /ix) {
             my ($name, $ttl, $class, $type, $host) = ($1, $2, $3, $4, $5);
             if (!$class && defined $name && $name =~ /^$rr_class$/) {
                 $class = uc $name;
                 undef $name;
             }
             my $dns_thing = uc $type eq 'NS' ? $dns_ns{$self}
                 : uc $type eq 'A' ? $dns_a{$self} : $dns_cname{$self};
             push @$dns_thing,
                 _massage({name => $name, class=> $class,
                           host => $host, ttl => $ttl})
        }
        elsif (/($valid_name)? \s* $ttl_cls AAAA \s+ ($valid_ip6)/)
        {
            my ($name, $ttl, $class, $host) = ($1, $2, $3, $4);
             if (!$class && defined $name && $name =~ /^$rr_class$/) {
                 $class = uc $name;
                 undef $name;
             }
             push @{$dns_a4{$self}},
                 _massage({name => $name, class=> $class,
                           host => $host, ttl => $ttl})
        }
        elsif (/($valid_name)? \s* $ttl_cls MX \s+ (\d+) \s+ ($valid_name)/ix)
        {
              # host ttl class mx pri dest
             my ($name, $ttl, $class, $pri, $host) = ($1, $2, $3, $4, $5);
             if (!$class && defined $name && $name =~ /^$rr_class$/) {
                 $class = uc $name;
                 undef $name;
             }
             push @{$dns_mx{$self}},
                  _massage({ name => $name, priority => $pri,
                             host => $host, ttl => $ttl, class => $class})
        }
        elsif (/($valid_name) \s+ $ttl_cls
                SOA \s+ ($valid_name) \s+ ($valid_name) \s*
                \(?\s* ($rr_ttl) \s+ ($rr_ttl) \s+ ($rr_ttl) \s+
                ($rr_ttl) \s+ ($rr_ttl) \s* \)? /ix)
        {
            # SOA record
            my $ttl = $dns_soa{$self}->{ttl} || $2 || '';
            $dns_soa{$self} =
                _massage({ origin => $1, ttl => $ttl, primary => $4,
                           email =>$5, serial => $6, refresh=> $7,
                           retry=> $8, expire=> $9, minimumTTL => $10 });
        }
        elsif (/(\d$valid_name+)\s+($rr_ttl)?\s*?($rr_class)?\s*?PTR\s+($valid_name)/i)
        {
            # PTR
            push @{$dns_ptr{$self}},
                _massage({ name => $1, class => $3, ttl => $2,  host => $4 });
        }
        elsif (/($valid_name) \s+ $ttl_cls TXT \s+ \"([^\"]*)\"/ix)
        {
            push @{$dns_txt{$self}},
                _massage({ name => $1,  ttl => $2, class => $3, text=> $4});
        }
        elsif (/\$TTL\s+($rr_ttl)/i) {
            $dns_soa{$self}->{ttl} = $1;
        }
    }
    return 1;
}

sub _clean_records {
    my $self = shift;
    my ($zone) = shift;

    $zone =~ s<\;.{0,}$><>mg;    # Remove comments
    $zone =~ s<^\s*?$><>mg;      # Remove empty lines
    $zone =~ s!$/{2,}!$/!g;      # Remove double carriage returns

    # Concatenate everything split over multiple lines i.e. elements surrounded
    # by parentheses can be split over multiple lines. See RFC 1035 section 5.1
    $zone =~ s{(\([^\)]*?\))}{_concatenate($1)}egs;

    my @records = map {s/^\s+//g; $_} split (m|$/|, $zone);
    return \@records;
}

sub _concatenate {
    my $text_in_parenth= shift;
    $text_in_parenth=~ s{$/}{}g;
    return $text_in_parenth;
}

my $last_name = '@';
sub _massage {
    my $record = shift;
    return $last_name = '@' unless $record;
    foreach (keys %$record) {
        $record->{$_} = "" unless defined $record->{$_};
        $record->{$_} = uc $record->{$_} if $_ eq 'class';
    }
    return $record unless defined $record->{name};
    if (length $record->{name}) {
        $last_name = $record->{name};
    } else {
        $record->{name} = $last_name;
    }
    return $record;
}

1;
__END__

=head1 NAME

DNS::ZoneParse - Parse and manipulate DNS Zone Files.

=head1 SYNOPSIS

    use DNS::ZoneParse;
    
    my $zonefile = DNS::ZoneParse->new("/path/to/dns/zonefile.db");
    
    # Get a reference to the MX records
    my $mx = $zonefile->mx;
    
    # Change the first mailserver on the list
    $mx->[0] = { host => 'mail.localhost.com',
                 priority => 10,
                 name => '@' };
    
    # update the serial number
    $zonefile->new_serial();
    
    # write the new zone file to disk 
    open NEWZONE, ">/path/to/dns/zonefile.db" or die "error";
    print NEWZONE $zonefile->output();
    close NEWZONE;

=head1 INSTALLATION

   perl Makefile.PL
   make
   make test
   make install

Win32 users substitute "make" with "nmake" or equivalent. 
nmake is available at http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe

=head1 DESCRIPTION

This module will parse a Zone File and put all the Resource Records (RRs)
into an anonymous hash structure. At the moment, the following types of 
RRs are supported: SOA, NS, MX, A, CNAME, TXT, PTR. It could be useful for
maintaining DNS zones, or for transferring DNS zones to other servers. If
you want to generate an XML-friendly version of your zone files, it is
easy to use XML::Simple with this module once you have parsed the zonefile.

DNS::ZoneParse scans the DNS zonefile - removes comments and seperates
the file into it's constituent records. It then parses each record and
stores the records internally. See below for information on the accessor
methods.


=head2 METHODS

=over 4

=item new

This creates the DNS::ZoneParse Object and loads the zonefile

Example:
    my $zonefile = DNS::ZoneParse->new("/path/to/zonefile.db");

You can also initialise the object with the contents of a file:
    my $zonefile = DNS::ZoneParse->new( \$zone_contents );

=item a(), cname(), mx(), ns(), ptr()

These methods return references to the resource records. For example:

    my $mx = $zonefile->mx;

Returns the mx records in an array reference.

A, CNAME, NS, MX and PTR records have the following properties:
'ttl', 'class', 'host', 'name'

MX records also have a 'priority' property.

=item soa()

Returns a hash reference with the following properties:
'serial', 'origin', 'primary', 'refresh', 'retry', 'ttl', 'minimumTTL',
'email', 'expire'

=item dump

Returns a copy of the datastructute that stores all the resource records. This
might be useful if you want to quickly transform the data into another format,
such as XML.

=item new_serial

C<new_serial()> incriments the Zone serial number. It will generate a
date-based serial number. Or you can pass a positive number to add to the
current serial number.

Examples:

    $zonefile->new_serial();    # generates a new serial number based on date:
                               # YYYYmmddHH format, incriments current serial
                               # by 1 if the new serial is still smaller

    $zonefile->new_serial(50);  # adds 50 to the original serial number

=item output

C<output()> returns the new zonefile output as a string. If you wish your
output formatted differently, you can pass the output of C<dump()> to your
favourite templating module.

=back

=head2 EXAMPLES

This script will print the A records in a zone file, add a new A record for the
name "new" and then return the zone file.

    use strict;
    use DNS::ZoneParse;
    
    my $zonefile = DNS::ZoneParse->new("/path/to/zonefile.db");
    
    print "Current A Records\n";
    my $a_records = $zonefile->a();
    
    foreach my $record (@$a_records) {
        print "$record->{name} resolves at $record->{host}\n";
    }
    
    push (@$a_records, { name => 'new', class => 'IN',
                         host => '127.0.0.1', ttl => '' });
    
    $zonefile->new_serial();
    my $newfile = $zonefile->output();




This script will convert a DNS Zonefile to an XML file using XML::Simple.


    use strict;
    use DNS::ZoneParse;
    use XML::Simple;

    my $zonefile = DNS::ZoneParse->new("/path/to/zonefile.db");

    my $new_xml = XMLout($zonefile->dump,
                         noattr => 1,
                         suppressempty => 1,
                         rootname => $zonefile->origin);

=head1 CHANGES

see F<Changes>

=head1 API

The DNS::ZoneParse API may change in future versions. At present, the parsing
is not as strict as it should be and support for C<$ORIGIN> and C<$TTL> is
quite basic. It would also be nice to support the C<INCLUDE>
statement. Furthermore, parsing large zonefiles with thousands of records can
use lots of memory - some people have requested a callback interface.

=head1 BUGS

I can squash more bugs with your help. Please let me know if you spot something
that doesn't work as expected.

You can report bugs via the CPAN RT:
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DNS-ZoneParse>

If possible, please provide a diff against F<t/dns-zoneparse.t> and
F<t/test-zone.db> that demonstrates the bug(s).

=head1 AUTHOR

Simon Flack

=head1 LICENSE

DNS::ZoneParse is free software which you can redistribute and/or modify under
the same terms as Perl itself.

=cut
