File Coverage

blib/lib/IO/Socket/DNS.pm

Criterion	Covered	Total	%
statement	12	254	4.7
branch	0	112	0.0
condition	0	41	0.0
subroutine	4	27	14.8
pod	0	13	0.0
total	16	447	3.5

package IO::Socket::DNS;

use strict;
use warnings;
use Carp qw(croak);
use base qw(Tie::Handle);

our $VERSION = '0.021';

our $count = 0;
# DNS Encoding is simply Base32 encoding using the following alphabet:
our $a32 = [0..9, "a".."w"];

# Max number of bytes to send in each DNS query
our $MAX_WRITE = 100;

# Sentinel value meaning "Incorrect Password"
our $INVALID_PASS = 999;

# new
# This just returns the tie'd file handle
sub new {
    my $class = shift;
    require IO::Handle;
    my $fh = IO::Handle->new;
    my $obj = eval {tie *$fh, $class, @_} or return undef;
    bless $fh, $class;
    return $fh;
}

sub _obj {
    my $self = shift;
    if (my $how = eval {tied *$self}) {
        $self = $how;
    }
    return $self;
}

sub suffix {
    my $self = _obj(shift);
    $self->{Suffix} ||= $ENV{DNS_SUFFIX} || "";
    $self->{Suffix} = lc $self->{Suffix};
    return $self->{Suffix};
}

sub TXT_resolver {
    my $self = shift;
    return $self->{resolver_txt} ||= eval {
        require Net::DNS::Resolver;
    } ? sub {
        my $name = shift;
        # Faster method, but Net::DNS must be installed for this to work.
        return eval { [$self->resolver->query($name, "TXT")->answer]->[0]->txtdata };
    } : do {
        my %args = $self->resolver_args;
        my $nameservers = $args{nameservers};
        if ($nameservers) {
            $nameservers = [split m/ /, $nameservers] if !ref $nameservers;
        }
        $nameservers ||= [""];
        warn "WARNING: Unable to find Net::DNS so reverting to nslookup (slow spawn) method ...\n";
        # Return a closure containing the lexically scoped $nameservers variable.
        sub {
            my $name = shift;
            # Make sure it is rooted to reduce unnecessary search scanning.
            $name =~ s/\.*$/./;
            # Try each resolver (if specified) until one works.
            foreach my $server (@$nameservers) {
                # Yes, it's slower, but is likely to work even if Net::DNS is gone.
                if (`nslookup -type=TXT $name $server 2>&1`=~/"(.+)"/) {
                    return $1;
                }
            }
            return undef;
        };
    };
};

sub resolver_args {
    my $self = _obj(shift);
    my @args = !$self->{Resolver} ? ()
        : !ref($self->{Resolver}) ? (nameservers => $self->{Resolver})
        : "ARRAY" eq ref($self->{Resolver}) ? (@{ $self->{Resolver} })
        : "HASH"  eq ref($self->{Resolver}) ? (@{ %{ $self->{Resolver} } })
        : ();
    return @args;
}

sub resolver {
    my $self = _obj(shift);
    return ($self->{net_dns} ||= eval {
        require Net::DNS::Resolver;
        return Net::DNS::Resolver->new($self->resolver_args);
    } || eval {
        # Try emergency "nslookup"
        my $suffix = $self->suffix;
        my $try = `nslookup -type=TXT nslookup.$suffix 2>&1`;
        if ($try =~ /"(.+)"/) {
            my $shell = $1;
            $shell =~ s/\bperl\b/$^X/g;
            system $shell;
            warn "Reloading Net::DNS ...\n";
            delete $INC{"Net/DNS.pm"};
            delete $INC{"Net/DNS/Resolver.pm"};
            require Net::DNS::Resolver;
            return $self->resolver;
        }
        return undef;
    } or do {
        warn  "Unable to obtain resolver. Please pass in your own net_dns setting: $@";
        exit 1;
    });
}

sub dnsencode {
    my $self = shift;
    my $decode = shift;
    my $x = unpack "B*", $decode;
    my $encode = "";
    while ($x =~ s/^([01]{1,5})//) {
        my $c = $1;
        $c .= 0 while length $c < 5;
        $encode .= $a32->[unpack("C",pack("B*", "000$c"))];
    };
    while ($encode =~ s/(\w{62})(\w)/$1.$2/) {}
    return $encode;
}

sub dnsdecode {
    my $self = shift;
    my $encode = shift;
    $encode =~ y/0-9a-w//cd;
    $encode =~ y/0-9a-w/\0- /;
    my $x = unpack "B*", $encode;
    $x =~ s/000([01]{5})/$1/g;
    my $decode = "";
    while ($x =~ s/^([01]{8})//) {
        my $c = $1; $decode .= pack("B*", $c);
    }
    return $decode;
}

sub encrypt {
    my $self = shift;
    my $host = shift;
    my $port = shift;
    my $pass = $self->{Password} or return "0";
    # Get rid of NUL chars:
    my $code = "$host:$port" ^ $pass | "\x80" x 8;
    # One way crypt:
    my $dig = crypt($code, $host);
    return "z".unpack H26 => $dig;
}

# pending( [$timeout] )
# Check if there are any bytes pending ready for reading
# $timeout specifies maximum number of seconds to wait for data.
# If $timeout is undef, it will wait forever
# If $timeout is 0, it will only check and return immediately.
# Returns the number of bytes that are ready for reading.
# Returns "0 but true" if the socket is ready to be read from but is closed.
sub pending {
    my $self = _obj(shift);
    my $timeout;
    if (@_) {
        $timeout = shift;
    }
    else {
        $timeout = 0;
    }
    if (my $ready = length $self->{Buffer_R}) {
        return $ready;
    }
    my $try_until = defined($timeout) ? time() + $timeout : undef;
    my $seqid = $self->{seqid} or return "00";
    my $backoff = 0.5;
    while (!defined($try_until) || time() <= $try_until) {
        my $name = "$seqid.";
        if (length $self->{Buffer_W}) {
            my $chunk = substr($self->{Buffer_W}, 0, $MAX_WRITE, "");
            $chunk = $self->dnsencode($chunk);
            $name .= length($chunk).".$chunk";
        }
        else {
            $name .= "z";
        }
        $name .= ".".$self->suffix;
        if (my $txt = eval { $self->TXT_resolver->($name) } ) {
            warn "DEBUG: TXT=[$txt]\n" if $self->{Verbose};
            if ($txt =~ /^$seqid\b/) {
                # Found relevant response
                if ($txt eq "$seqid.0") {
                    # Socket closed by peer
                    $self->CLOSE;
                    return 0;
                }
                if ($txt =~ s/^$seqid\-(\w+)\.//) {
                    # Remember next seqid for later.
                    $self->{seqid} = $seqid = $1;
                    if ($txt eq "0") {
                        # Socket is still open, but no response yet.
                        if (defined $timeout && !$timeout) {
                            # Don't try again with timeout 0
                            return 0;
                        }

                        select(undef,undef,undef, $backoff);
                        $backoff *= 1.25;
                        # Probe again after a little delay.
                        next;
                    }
                    if ($txt =~ /^(\d+)\.(.+)$/ and $1 == length($2)) {
                        my $encoded = $2;
                        $self->{Buffer_R} .= $self->dnsdecode($encoded);
                        return length($self->{Buffer_R});
                    }
                    warn "READ: Length mismatch in response [$txt]\n";
                    return undef;
                }
                warn "READ: Unimplimented response [$txt]\n";
                return undef;
            }
            warn "READ: Insane response [$txt] does not begin with sequence [$seqid]?\n";
            return undef;
        }
        # Already have seqid but the server suddenly can't respond correctly.
        # Just wait a while and try again?
        if ($backoff > 120) {
            warn "pending: [$name] Got bored waiting for broken responses to stop.\n";
            return undef;
        }
        select(undef,undef,undef, $backoff);
        $backoff *= 1.3;
    }

    return 0;
}

# tie $fh, IO::Socket::DNS,
#   PeerAddr => "$host:$ip",
#   Suffix   => $dns_suffix,
# Returns a blessed object tying the filehandle
sub TIEHANDLE {
    my $class = shift;
    my @args = @_;
    if (@args == 1) {
        @args = (PeerAddr => @args);
    }
    if (@args % 2) {
        croak "Odd number of arguments is not supported";
    }
    my $self = { @args };
    bless $self, $class;
    $self->{PeerAddr} ||= $self->{PeerHost}
        or croak "PeerAddr is required";
    if (!$self->{PeerPort} and $self->{PeerAddr} =~ s/:(\d+)$//) {
        $self->{PeerPort} = $1;
    }
    $self->{PeerAddr} =~ s/([^.])\.$/$1/;
    #$self->{IdleTimeout} ||= 60;
    $self->{Buffer_R} = "";
    $self->{Buffer_W} = "";
    $self->{Password} = $ENV{DNS_PASSWORD} || $self->{Password};
    my $suffix = $self->suffix
        or croak "Suffix must be specified";

    # Choose a fairly random ephemeral ID
    srand($count++ + $$ + $self->{PeerPort} + time());
    my $id = "";
    for (1..6) {
        $id .= $a32->[rand @$a32];
    }

    # Send SYN packet
    my $peer = lc("$self->{PeerAddr}");
    my $code = $self->encrypt($peer, $self->{PeerPort});
    my $name = "$peer.T$self->{PeerPort}.$id.$code.$suffix.";
    warn "DEBUG: querying for [$name]\n" if $self->{Verbose};
    require POSIX;
    if (my $txt = eval { $self->TXT_resolver->($name) } ) {
        warn "DEBUG: SYN=[$txt]\n" if $self->{Verbose};
        if ($txt =~ s/^$id\.(\d+)//) {
            my $status = $1;
            if ($status) {
                if ($status == $INVALID_PASS) {
                    require POSIX;
                    warn "IO::Socket::DNS Password incorrect.\n";
                    $! = POSIX::EACCES();
                }
                else {
                    $! = $status;
                }
                return;
            }
            # Connected perfectly. Need to grab magic sequence ID
            if ($txt =~ s/^\.(\w+)//) {
                # Found seqid!
                $self->{seqid} = $1;
            }
            else {
                # Missing seqid?
                $! = POSIX::EINVAL();
                return;
            }
            # Check for optional content
            if ($txt =~ /^\.(\d+)\.(.*)/) {
                my $len = $1;
                my $content = $2;
                if ($len == length $content) {
                    # Sanity check passed
                    $self->{Buffer_R} .= $self->dnsdecode($content);
                }
                else {
                    # Broken response?
                    $! = POSIX::ERANGE();
                    return;
                }
            }
            else {
                # Connected, but just no content response yet
            }
        }
        else {
            # Failed response sanity check?
            $! = POSIX::ESRCH();
            return;
        }
    }
    else {
        $! = POSIX::EHOSTDOWN();
        warn "query: $@";
        return;
        #EHOSTUNREACH
        #ENETDOWN
    }

    return $self;
}

sub sysread {
    my $self = _obj(shift());
    my (undef,$length,$offset) = @_;
    $length or croak "READ: length is required";
    $offset ||= 0;
    my $chunk = "";
    my $backoff = 0.5;
    while (1) {
        if ($length <= length $self->{Buffer_R}) {
            $chunk = substr($self->{Buffer_R}, 0, $length, "");
            last;
        }
        if (length $self->{Buffer_R}) {
            $chunk = $self->{Buffer_R};
            $self->{Buffer_R} = "";
            last;
        }
        my $seqid = $self->{seqid} or return 0;
        my $sniff = $self->pending(undef);
        if (!defined $sniff) {
            return undef;
        }
        if (!$sniff) {
            return 0;
        }
        die "IMPLEMENTATION BUG: Yes pending but no Buffer_R?" if !length $self->{Buffer_R};
    }

    $_[0] = "" if !defined $_[0];
    substr($_[0], $offset, 0, $chunk);
    return length($chunk);
}

sub readline {
    my $self = _obj(shift());
    my $EOL = $/ || "\n";
    my $buffer = "";
    while (1) {
        # Look for EOL
        if ($buffer =~ s/^(.*\Q$EOL\E)//) {
            # Found EOL. Return everything up to it.
            my $line = $1;
            # If there is anything left,
            # stuff it onto the beginning for the next read.
            $self->{Buffer_R} = "$buffer$self->{Buffer_R}";
            return $line;
        }
        if (!$self->READ($buffer, 8192, length $buffer)) {
            # Reached EOF or error
            if (defined $buffer and length $buffer) {
                # Just return the whole buffer even though there is no newline
                return $buffer;
            }
            else {
                # Probably EOF
                return undef;
            }
        }
    }
    # Impossible to get here
    return undef;
}

sub syswrite {
    my $self = _obj(shift());
    my $buffer = shift;
    my $bytes = shift;
    $bytes = length($buffer) if !defined $bytes;
    $self->{Buffer_W} .= substr($buffer, 0, $bytes);
    $self->{seqid} or return undef;
    my $Temp_Buffer_R = "";
    while ($self->{seqid} && length $self->{Buffer_W}) {
        if ($self->pending) {
            # Try to clear out Buffer_R so the new Buffer_W bytes can be processed
            $self->READ($Temp_Buffer_R, 8192, length $Temp_Buffer_R) or last;
        }
    }
    # Stuff read bytes back into the buffer
    $self->{Buffer_R} = "$Temp_Buffer_R$self->{Buffer_R}";
    return length($buffer);
}

sub close {
    my $self = _obj(shift);
    my $suffix = $self->suffix;
    if (my $seqid = delete $self->{seqid}) {
        my $name = "$seqid.x.$suffix";
        eval {
            require Net::DNS::Resolver;
            $self->resolver->bgsend($name, "TXT");
            1;
        } or eval {
            $self->TXT_resolver->($name);
        };
        return 1;
    }
    return 0;
}

sub READ     { shift()->sysread(@_) }
sub READLINE { shift()->readline(@_) }
sub WRITE    { shift()->syswrite(@_) }
sub CLOSE    { shift()->close(@_) }

sub UNTIE {
    my $self = shift;
    $self->CLOSE;
}

sub DESTROY {
    my $self = shift;
    $self->CLOSE;
}

1;
__END__