File Coverage

lib/Haineko/DNS.pm

Criterion	Covered	Total	%
statement	73	74	98.6
branch	11	14	78.5
condition	5	6	83.3
subroutine	17	17	100.0
pod	7	8	87.5
total	113	119	94.9

package Haineko::DNS;
use feature ':5.10';
use strict;
use warnings;
use Net::DNS;
use Try::Tiny;
use Class::Accessor::Lite;

my $rwaccessors = [
    'A',        # (ArrayRef) A
    'MX',       # (ArrayRef) MX
    'NS',       # (ArrayRef) NS
    'TXT',      # (ArrayRef) TXT
];
my $roaccessors = [
    'name',     # (String) domain name
];
my $woaccessors = [];
Class::Accessor::Lite->mk_accessors( @$rwaccessors );
Class::Accessor::Lite->mk_ro_accessors( @$roaccessors );

my $DNSRR = [ 'A', 'MX', 'NS', 'TXT' ];

sub new {
    my $class = shift;
    my $argvs = shift // return undef;
    my $param = { 'name' => lc $argvs };

    return bless $param, __PACKAGE__;
}

sub flush {
    my $self = shift;

    for my $e ( @$DNSRR ) {
        delete $self->{ $e } if exists $self->{ $e };
    }
    return $self;
}

sub resolve {
    my $self = shift;
    my $type = shift || 'A';
    my $name = $self->{'name'};

    my $rrresolver = undef;
    my $rrqueryset = undef;
    my $resolvedrr = undef;
    my $methodlist = {
        'A'    => 'address',
        'MX'   => 'exchange',
        'NS'   => 'nsdname',
        'TXT'  => 'txtdata',
    };

    try {
        $rrresolver = Net::DNS::Resolver->new;
        $rrqueryset = $rrresolver->query( $self->{'name'}, $type );
        $resolvedrr = [];

        for my $e ( $rrqueryset->answer ) {
            # $rrqueryset is a Net::DNS::Packet object
            my $ttlsec = $e->ttl;
            my $method = $methodlist->{ $type };
            my $record = {
                'rr'  => $e->$method,
                'ttl' => $ttlsec,
                'exp' => time + $ttlsec,
                'p'   => 0,
            };

            $record->{'p'} = $e->preference if $type eq 'MX';
            push @$resolvedrr, $record;
        }

    } catch {
        # ...
        $resolvedrr = [];
    };

    if( $type eq 'MX' ) {
        # Sort by preference
        $self->{'MX'} = [ sort { $a->{'p'} <=> $b->{'p'} } @$resolvedrr ];

    } else {
        $self->{ $type } = $resolvedrr;
    }

    return $self;
}

sub rr {
    my $self = shift;
    my $type = shift || 'A'; $type = 'A' unless grep { $type eq $_ } @$DNSRR;
    my $dnsr = undef;

    my $pick = sub {
        my $list = [];
        return [] unless ref $self->$type eq 'ARRAY';

        for my $r ( @{ $self->$type } ) {
            next if $r->{'exp'} < time;
            push @$list, $r->{'rr'};
        }
        return $list;
    };

    $dnsr = $pick->();
    return $dnsr if scalar @$dnsr;

    $self->resolve( $type );
    return $pick->();
}

sub arr {
    my $self = shift;
    return $self->rr('A');
}

sub mxrr {
    my $self = shift;
    return $self->rr('MX');
}

sub nsrr {
    my $self = shift;
    return $self->rr('NS');
}

sub txtrr {
    my $self = shift;
    return $self->rr('TXT');
}

1;
__END__