File Coverage

blib/lib/Config/TinyDNS.pm

Criterion	Covered	Total	%
statement	74	74	100.0
branch	13	14	92.8
condition	10	12	83.3
subroutine	19	19	100.0
pod	4	4	100.0
total	120	123	97.5

package Config::TinyDNS;

=head1 NAME

Config::TinyDNS - Manipulate tinydns' data file

=head1 SYNOPSIS

    use Config::TinyDNS qw/filter_tdns_data/;

    my $data = File::Slurp::read_file(...);
    $data = filter_tdns_data $data, qw/include vars lresolv/;

=head1 DESCRIPTION

Tinydns, the DNS server in Dan Bernstein's djbdns package, uses a simple
line-based format instead of a zone file. The format was designed to be
easy for machines to parse, so it sometimes requires rather a lot of
repetition. This module provides functions for manipulating these files,
however it is primarily intended as the backend for
L.

The general principle of operation is that the file is split into
records and fields, these records are passed through a series of
filters, and the results joined back up into a config file. The basic
file format is line-based, with each line consisting of a
single-character operator followed by a number of colon-separated
arguments. For more details on the format, see L.

=head1 FUNCTIONS

=cut

use 5.010;
use warnings;
use strict;
use Scalar::Util    qw/reftype/;
use List::MoreUtils qw/natatime/;
use Carp;

use Exporter::NoWork;

our $VERSION = 1;

my %Filters;

=head2 C>

Breaks the provided string up into a list of arrayrefs. Each arrayref
represents a line of the input; each line is broken into the initial
single-character operator and the subsequent colon-separated fields.
Trailing blank fields are removed. Blank lines are removed. Comments are
not broken up into fields.

For example, an input of

    +foo.com:1.2.3.4:
    Idynamic/bar.org
    # some:comment

would produce a data structure like

    ["+", "foo.com", "1.2.3.4"],
    ["I", "dynamic/bar.org"],
    ["#", " some:comment"],

=cut

sub split_tdns_data {
    map {
        s/(.)//
            ? [$1, ($1 eq "#" ? $_ : split /:/)]
            : ()
    } split /\n/, $_[0];
}

sub _strip_blank {
    @_ = @{[@_]};
    pop while @_ and not (defined $_[-1] and length $_[-1]);
    @_;
}

=head2 C>

Join the result of C> back up into a single string.
Undef fields are silently rendered as blanks. Trailing empty fields are
removed.

=cut

sub join_tdns_data {
    no warnings "uninitialized";
    join "", map "$_\n", map {
        $_->[0] . join ":", _strip_blank @$_[1..$#$_]
    } @_;
}

sub _lookup_filt {
    my ($k, @args) = @_;
    my $f = $Filters{$k} or croak "bad filter: $k";
    given (reftype $f) {
        when ("CODE")   { return $f }
        when ("REF")    { return ($$f)->(@args) }
        default         { die "bad \%Filters entry: $k => $f" }
    }
}

sub _decode_filt {
    my ($f) = @_;
    defined $f or return;
    given (reftype $f) {
        when ("CODE")   { return $f }
        when (undef)    { return _lookup_filt $f }
        when ("ARRAY")  { return _lookup_filt @$f }
        default         { croak "bad filter: $f" }
    }
}

sub _call_filt {
    my $c = shift;
    my $r = @_ ? shift : $_;
    my ($f, @r) = @$r;
    local $_ = $f;
    $c->(@r);
}

=head2 C, I>

Break I up using C>, pass it through a
series of filters, and join it up again with C>.
I should be a list of the following:

=over 4

=item * a CODE ref

The coderef will be called once for each line of input. C$_> will be set
to the initial single character and the arguments in C<@_> will be the
remaining fields. The return value should be a list of arrayrefs as from
C>. A simple filter that changes nothing looks like

    sub { return [$_, @_] }

=item * a plain string

This requests a filter registered with C>. See
L below for a list of the predefined filters.

=item * an ARRAY ref

The first argument will be looked up as a registered filter. If this is
a generator-type filter (see below), the generator will be called with
the rest of the contents of the arrayref as arguments.

=back

=cut

sub filter_tdns_data {
    my @lines = split_tdns_data shift;
    for my $f (@_) {
        my $c = _decode_filt $f;
        @lines =
            map _call_filt($c),
            @lines;
    }
    return join_tdns_data @lines;
}

=head2 C>

Register filters to be called by name later. I should be a list of
key C<< => >> value pairs, where each value is either

=over 4

=item * a CODE ref

The coderef will be called as though it had been supplied to
C directly. Any arguments passed (using an arrayref)
will be ignored.

=item * a ref to a CODE ref

For example

    record => \sub {
        my %vars;
        sub {
            /\$/ or return [$_, @_];
            $vars{$_[0]} = $_[1];
        };
    },

The coderef will be called once when C is called, and
the return value will be used as the filter sub. Any arguments supplied
will be passed to the generator sub.

=back

=cut

sub register_tdns_filters {
    my $i = natatime 2, @_;
    while (my ($k, $c) = $i->()) {
        $Filters{$k}    and croak "filter '$k' is already registered";
        ref $c and (
            reftype $c eq "CODE" or (
                reftype $c eq "REF" and reftype $$c eq "CODE"
            )
        )               or  croak "filter must be a coderef(ref)";
        $Filters{$k} = $c;
    }
}

# just for the tests
sub _filter_hash { \%Filters }

=head1 FILTERS

Many of these filters introduce ordering constraints on the lines of the
file. Be careful about re-ordering files written for them.

=head2 null

Pass all lines through unchanged. Note that blank lines and trailing
blank fields will still be removed.

=cut

register_tdns_filters
    null => sub { [$_, @_] };

=head2 vars

Input lines of the form

    $name:value

are treated as variable definitions and removed from the output.
Variables may have any name, but only those matching C<\w+> are useful.
Expressions looking like C will be substituted across all
fields, including in variable definitions. This allows a form of symref,
use of which should be discouraged. Variables must be defined before
they are used; nonexistent variables will be silently replaced with the
empty string. Dollars can be escaped by doubling them.

    $foo:foo.com
    =$foo:1.2.3.4
    +www.$foo:1.2.3.4
    "txt.$foo:this $$ is a dollar

translates to

    =foo.com:1.2.3.4
    +www.foo.com:1.2.3.4
    "txt.foo.com:this $ is a dollar

=cut

register_tdns_filters
    vars => \sub {
        my %vars = ('$' => '$');
        sub {
            no warnings "uninitialized";
            s/\$(\$|\w+)/$vars{$1}/ge for @_;
            /\$/            or return [$_, @_];
            $_[0] eq '$'    and return;
            $vars{$_[0]} = $_[1];
            return;
        }
    };

=head2 include

This interprets lines of the form

    Isome/file

as a request to include the contents of F at this point. The
included lines are scanned for further includes but are not passed
through any other filters (though this may change at some point).

=cut

register_tdns_filters
    include => \sub {
        my $include;
        $include = sub {
            /I/ or return [$_, @_];
            require File::Slurp;
            return map _call_filt($include),
                split_tdns_data scalar File::Slurp::read_file($_[0]);
        };
    };

=head2 lresolv

Resolve hostnames in IP-address slots in the configuration using the
information in this file. Names must be defined before they will be
translated. Currently only the C<+ = . & @> lines used by
tinydns-data(1) are recognised. If you want to run both lresolv and
L, you need to run lresolv first or local hostnames will
already have been replaced.

For example

    =foo.com:1.2.3.4
    +www.foo.com:foo.com

would translate to

    =foo.com:1.2.3.4
    +www.foo.com:1.2.3.4

=cut

register_tdns_filters
    lresolv => \sub {
        no warnings "uninitialized";
        my %hosts;
        my $repl = sub {
            for ((defined $_[1] ? "$_[0]:$_[1]" : ()), $_[0]) {
                if (
                    $_[0] =~ /[^0-9.]/ and
                    defined $hosts{$_}
                ) {
                   $_[0] = $hosts{$_};
                   last;
                }
            }
        };
        my $qual = sub { $_[0] =~ /\./ ? $_[0] : "$_[0].$_[1].$_[2]" };
        my $lo   = sub { $_[0] . (defined $_[1] ? ":$_[1]" : "") };
        sub {
            given ($_) {
                when ([".", "&"]) {
                    $repl->(@_[1, 5]);
                    my $key = $lo->($qual->($_[2], "ns", $_[0]), $_[5]);
                    $hosts{$key} = $_[1];
                }
                when (["=", "+"]) {
                    $repl->(@_[1, 4]);
                    $hosts{$lo->($_[0], $_[4])} = $_[1];
                }
                when (["@"]) {
                    $repl->(@_[1, 6]);
                    $hosts{$lo->($qual->($_[2], "mx", $_[0]), $_[6])} = $_[1];
                }
            }
            [$_, @_];
        };
    };

=head2 rresolv

Resolve hostnames in IP-address slots in the configuration by looking
them up in the current DNS. This assumes anything which doesn't match
C is a hostname, and any hostname that doesn't resolve is
replaced with C<0.0.0.0>. Currently this only recognises the standard
C<+=.&@> lines.

=cut

register_tdns_filters
    rresolv => \sub {
        require Socket;
        my $repl = sub {
            if ($_[0] =~ /[^0-9.]/) {
                $_[0] = Socket::inet_ntoa(
                    gethostbyname($_[0]) //
                        Socket::inet_aton("0.0.0.0")
                );
            }
        };
        sub { /[.&+=\@]/ and $repl->($_[1]); [$_, @_]; };
    };

=head2 site I

This adds an extra field to C<%> lines, so they look like

    %lo:ipprefix:site

If I is in the list of I provided, the I field will
be removed and the line left in the output. Otherwise, the line will be
removed entirely. This makes it possible to build data files for several
different views on the DNS from one master file.

=cut

register_tdns_filters
    site => \sub {
        my %sites = map +($_, 1), @_;
        sub {
            /%/             or return [$_, @_];
            @_ > 2          or return [$_, @_];
            my $site = pop;
            $sites{$site}   or return;
            return [$_, @_];
        };
    };

1;

=head1 SEE ALSO

L, L.

=head1 AUTHOR

Ben Morrow

=head1 COPYRIGHT

Copyright 2010 Ben Morrow.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

=over 4

=item *

Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

=item *

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

=back

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL BEN MORROW BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=cut

1;