File Coverage

blib/lib/Net/DNS/DynDNS.pm

Criterion	Covered	Total	%
statement	188	249	75.5
branch	71	128	55.4
condition	38	108	35.1
subroutine	31	34	91.1
pod	4	14	28.5
total	332	533	62.2

package Net::DNS::DynDNS;

use warnings;
use strict;
use LWP();
use HTTP::Cookies();
use HTTP::Headers();
use Carp();
use English qw(-no_match_vars);
our $VERSION = '0.9993';

our @CARP_NOT = ('Net::DNS::DynDNS');
sub DEFAULT_TIMEOUT                      { return 60 }
sub NUMBER_OF_OCTETS_IN_IP_ADDRESS       { return 4; }
sub MAXIMUM_VALUE_OF_AN_OCTET            { return 256; }
sub FIRST_BYTE_OF_10_PRIVATE_RANGE       { return 10; }
sub FIRST_BYTE_OF_172_16_PRIVATE_RANGE   { return 172; }
sub SECOND_BYTE_OF_172_16_PRIVATE_RANGE  { return 16; }
sub FIRST_BYTE_OF_192_168_PRIVATE_RANGE  { return 192; }
sub SECOND_BYTE_OF_192_168_PRIVATE_RANGE { return 168; }
sub LOCALHOST_RANGE                      { return 127; }
sub MULTICAST_RESERVED_LOWEST_RANGE      { return 224; }

sub new {
    my ( $class, $user_name, $password, $params ) = @_;
    my $self    = {};
    my $timeout = DEFAULT_TIMEOUT();
    if ( ( ref $user_name ) && ( ref $user_name eq 'SCALAR' ) ) {
        if ( not( ( ref $password ) && ( ref $password eq 'SCALAR' ) ) ) {
            Carp::croak('No password supplied');
        }
    }
    elsif ( ( ref $user_name ) && ( ( ref $user_name ) eq 'HASH' ) ) {
        $params    = $user_name;
        $user_name = undef;
        $password  = undef;
    }
    if ( exists $params->{timeout} ) {
        if ( ( $params->{timeout} ) && ( $params->{timeout} =~ /^\d+$/xsm ) ) {
            $timeout = $params->{timeout};
        }
        else {
            Carp::croak(q[The 'timeout' parameter must be a number]);
        }
    }
    my $name = "Net::DNS::DynDNS $VERSION "
      ;    # a space causes the default LWP User Agent to be appended.
    if ( exists $params->{user_agent} ) {
        if ( ( $params->{user_agent} ) && ( $params->{user_agent} =~ /\S/xsm ) )
        {
            $name = $params->{user_agent};
        }
    }
    my $ua = LWP::UserAgent->new( timeout => $timeout )
      ; # no sense in using keep_alive => 1 because updates and checks are supposed to happen infrequently
    $ua->env_proxy();
    $ua->agent($name);
    my $cookie_jar = HTTP::Cookies->new( hide_cookie2 => 1 );
    $ua->cookie_jar($cookie_jar);
    $ua->requests_redirectable( ['GET'] );
    $self->{_ua} = $ua;
    my $headers = HTTP::Headers->new();

    if ( ($user_name) && ($password) ) {
        $headers->authorization_basic( $user_name, $password );
    }
    $self->{_headers}   = $headers;
    $self->{server}     = $params->{server} || 'dyndns.org';
    $self->{dns_server} = $params->{dns_server} || 'members.dyndns.org';
    $self->{check_ip}   = $params->{check_ip} || 'checkip.dyndns.org';
    bless $self, $class;
    $self->update_allowed(1);
    return $self;
}

sub _get {
    my ( $self, $uri ) = @_;
    my $ua      = $self->{_ua};
    my $headers = $self->{_headers};
    my $request = HTTP::Request->new( 'GET' => $uri, $headers );
    my $response;
    eval {
        local $SIG{'ALRM'} =
          sub { Carp::croak "Timeout when retrieving $uri"; };
        alarm $ua->timeout();
        $response = $ua->request($request);
        alarm 0;
        1;
    } or do {
        chomp $EVAL_ERROR;
        Carp::croak "Failed to get a response from '$uri':$EVAL_ERROR";
    };
    return $response;
}

sub default_ip_address {
    my ( $proto, $params ) = @_;
    my ($self);
    if ( ref $proto ) {
        $self = $proto;
    }
    else {
        $self = $proto->new($params);
    }
    my ($check_ip_uri) = $self->_check_ip_address_uri($params);

    # user_name / password is not necessary for checkip.
    # therefore don't send user_name / password

    my $headers = $self->{_headers};
    my ( $user_name, $password ) = $headers->authorization_basic();
    $headers->remove_header('Authorization');

    my ( $response, $network_error );
    eval { $response = $self->_get($check_ip_uri); } or do {
        $network_error = $EVAL_ERROR;
    };

    # restore user_name / password

    if ( ($user_name) && ($password) ) {
        $headers->authorization_basic( $user_name, $password );
    }

    if ($network_error) {
        chomp $network_error;
        Carp::croak($network_error);
    }
    return $self->_parse_ip_address( $check_ip_uri, $response );
}

sub _check_ip_address_uri {
    my ( $self, $params ) = @_;
    my $protocol = 'http'
      ; # default protocol is http because no user_name / passwords are required
    if ( exists $params->{protocol} ) {
        if ( ( defined $params->{protocol} ) && ( $params->{protocol} ) ) {
            $params->{protocol} = lc( $params->{protocol} );
            if (   ( $params->{protocol} ne 'http' )
                && ( $params->{protocol} ne 'https' ) )
            {
                Carp::croak(
                    q[The 'protocol' parameter must be one of 'http' or 'https']
                );
            }
        }
        else {
            Carp::croak(
                q[The 'protocol' parameter must be one of 'http' or 'https']);
        }
        $protocol = $params->{protocol};
    }
    if ( $protocol eq 'https' ) {
        eval { require Net::HTTPS; } or do {
            Carp::croak(q[Cannot load Net::HTTPS]);
        };
    }
    return $protocol . '://' . $self->{check_ip};
}

sub _parse_ip_address {
    my ( $self, $check_ip_uri, $response ) = @_;
    my $ip_address;
    if ( $response->is_success() ) {
        my $content = $response->content();
        if ( $content =~ /Current\sIP\sAddress:\s(\d+.\d+.\d+.\d+)/xsm ) {
            $ip_address = $1;
        }
        else {
            Carp::croak("Failed to parse response from '$check_ip_uri'");
        }
    }
    else {
        my $content = $response->content();
        $content =~ s/\s*$//smx;
        if ( $content =~ /Can't\sconnect\sto\s$self->{check_ip}/xsm ) {
            Carp::croak("Failed to connect to '$check_ip_uri'");
        }
        else {
            Carp::croak(
"Failed to get a success type response from '$check_ip_uri':$content"
            );
        }
    }
    return $ip_address;
}

sub _validate_update {
    my ( $self, $hostnames, $ip_address, $params ) = @_;
    my $headers = $self->{_headers};
    my ( $user_name, $password ) = $headers->authorization_basic();
    if ( not $self->update_allowed() ) {
        Carp::croak(
"$self->{server} has forbidden updates until the previous error is corrected"
        );
    }
    if ( not( ($user_name) && ($password) ) ) {
        Carp::croak(q[Username and password must be supplied for an update]);
    }
    if ( not($hostnames) ) {
        Carp::croak(q[The update method must be supplied with a hostname]);
    }
    if (
        not( $hostnames =~
            /^(?:(?:[[:alpha:]\d\-]+[.])+[[:alpha:]\d\-]+,?)+$/xsm )
      )
    {
        Carp::croak(
"The hostnames do not seem to be in a valid format.  Try 'test.$self->{server}'"
        );
    }
    $self->_validate_ip_address($ip_address);
    if ( ( ref $params ) && ( ( ref $params ) eq 'HASH' ) ) {
        $self->_check_wildcard($params);
        $self->_check_mx($params);
        $self->_check_backmx($params);
        $self->_check_offline($params);
        if ( exists $params->{protocol} ) {
            $self->_check_protocol($params);
        }
        else {
            $params->{protocol} = 'https';
        }
    }
    elsif ($params) {
        Carp::croak(
            q[Extra parameters must be passed in as a reference to a hash]);
    }
    return;
}

sub _validate_ip_address {
    my ( $self, $ip_address ) = @_;
    if ( defined $ip_address ) {
        my @bytes = split /[.]/xsm, $ip_address;
        if ( ( scalar @bytes ) != NUMBER_OF_OCTETS_IN_IP_ADDRESS() ) {
            Carp::croak(q[Bad IP address]);
        }
        foreach my $byte (@bytes) {
            if ( not( $byte =~ /^\d+$/xsm ) ) {
                Carp::croak(q[Bad IP address.  Each byte must be numeric]);
            }
            if ( ( $byte >= MAXIMUM_VALUE_OF_AN_OCTET() ) || ( $byte < 0 ) ) {
                Carp::croak(q[Bad IP address.  Each byte must be within 0-255]);
            }
        }
        if (
               ( $bytes[0] == 0 )
            || ( $bytes[0] == LOCALHOST_RANGE() )
            || ( $bytes[0] == FIRST_BYTE_OF_10_PRIVATE_RANGE() )
            || (   ( $bytes[0] == FIRST_BYTE_OF_172_16_PRIVATE_RANGE() )
                && ( $bytes[1] == SECOND_BYTE_OF_172_16_PRIVATE_RANGE() ) )
            ||    # private
            (
                   ( $bytes[0] == FIRST_BYTE_OF_192_168_PRIVATE_RANGE() )
                && ( $bytes[1] == SECOND_BYTE_OF_192_168_PRIVATE_RANGE() )
            )
            ||    # private
            ( $bytes[0] >= MULTICAST_RESERVED_LOWEST_RANGE() )
          )       # multicast && reserved
        {
            Carp::croak(
q[Bad IP address.  The IP address is in a range that is not publically addressable]
            );
        }
    }
}

sub _check_wildcard {
    my ( $self, $params ) = @_;
    if ( exists $params->{wildcard} ) {
        if ( ( defined $params->{wildcard} ) && ( $params->{wildcard} ) ) {
            $params->{wildcard} = uc( $params->{wildcard} );
            if (   ( $params->{wildcard} ne 'ON' )
                && ( $params->{wildcard} ne 'OFF' )
                && ( $params->{wildcard} ne 'NOCHG' ) )
            {
                Carp::croak(
q[The 'wildcard' parameter must be one of 'ON','OFF' or 'NOCHG']
                );
            }
        }
        else {
            Carp::croak(
                q[The 'wildcard' parameter must be one of 'ON','OFF' or 'NOCHG']
            );
        }
    }
}

sub _check_mx {
    my ( $self, $params ) = @_;
    if ( exists $params->{mx} ) {
        if ( ( defined $params->{mx} ) && ( $params->{mx} ) ) {
            if (
                not( $params->{mx} =~
                    /^(?:(?:[[:alpha:]\d\-]+[.])+[[:alpha:]\d\-]+,?)+$/xsm )
              )
            {
                Carp::croak(
"The 'mx' parameter does not seem to be in a valid format.  Try 'test.$self->{server}'"
                );
            }
        }
        else {
            Carp::croak(
q[The 'mx' parameter must be a valid fully qualified domain name]
            );
        }
    }
    else {
        if ( exists $params->{backmx} ) {
            Carp::croak(
q[The 'backmx' parameter cannot be set without specifying the 'mx' parameter]
            );
        }
    }
}

sub _check_backmx {
    my ( $self, $params ) = @_;
    if ( exists $params->{backmx} ) {
        if ( ( defined $params->{backmx} ) && ( $params->{backmx} ) ) {
            $params->{backmx} = uc( $params->{backmx} );
            if (   ( $params->{backmx} ne 'YES' )
                && ( $params->{backmx} ne 'NO' ) )
            {
                Carp::croak(
                    q[The 'backmx' parameter must be one of 'YES' or 'NO']);
            }
        }
        else {
            Carp::croak(q[The 'backmx' parameter must be one of 'YES' or 'NO']);
        }
    }
}

sub _check_offline {
    my ( $self, $params ) = @_;
    if ( exists $params->{offline} ) {
        if ( ( defined $params->{offline} ) && ( $params->{offline} ) ) {
            $params->{offline} = uc( $params->{offline} );
            if (   ( $params->{offline} ne 'YES' )
                && ( $params->{offline} ne 'NO' ) )
            {
                Carp::croak(
                    q[The 'offline' parameter must be one of 'YES' or 'NO']);
            }
        }
        else {
            Carp::croak(
                q[The 'offline' parameter must be one of 'YES' or 'NO']);
        }
    }
}

sub _check_protocol {
    my ( $self, $params ) = @_;
    if ( ( defined $params->{protocol} ) && ( $params->{protocol} ) ) {
        $params->{protocol} = lc( $params->{protocol} );
        if (   ( $params->{protocol} ne 'http' )
            && ( $params->{protocol} ne 'https' ) )
        {
            Carp::croak(
                q[The 'protocol' parameter must be one of 'http' or 'https']);
        }
    }
    else {
        Carp::croak(
            q[The 'protocol' parameter must be one of 'http' or 'https']);
    }
}

sub update_allowed {
    my ( $self, $allowed ) = @_;
    my $old;
    if ( ( exists $self->{update_allowed} ) && ( $self->{update_allowed} ) ) {
        $old = $self->{update_allowed};
    }
    if ( defined $allowed ) {
        $self->{update_allowed} = $allowed;
    }
    return $old;
}

sub _error {
    my ( $self, $code, $content ) = @_;
    $self->update_allowed(0);
    my %errors = (
        'badauth' => 'The username and password pair do not match a real user',
        '!donator' =>
'An option available only to credited users (such as offline URL) was specified, but the user is not a credited user',
        'notfqdn' =>
'The hostname specified is not a fully-qualified domain name (not in the form hostname.dyndns.org or domain.com)',
        'nohost' =>
          'The hostname specified does not exist in this user account',
        'numhost' => 'Too many hosts (more than 20) specified in an update',
        'abuse'   => 'The hostname specified is blocked for update abuse',
        'badagent' =>
          'The user agent was not sent or HTTP method is not permitted',
        'dnserr' => 'DNS error encountered',
        '911'    => 'There is a problem or scheduled maintenance on our side',
    );
    Carp::croak( $errors{$code} || "Unknown error:$code:$content" );
}

sub update {
    my ( $self, $hostnames, $ip_address, $params ) = @_;
    if ( ( ref $ip_address ) && ( ref $ip_address eq 'HASH' ) ) {
        $params     = $ip_address;
        $ip_address = undef;
    }
    $self->_validate_update( $hostnames, $ip_address, $params );
    my $protocol =
      'https';    # default protocol is https to protect user_name / password
    if ( $params->{protocol} ) {
        $protocol = $params->{protocol};
    }
    if ( $protocol eq 'https' ) {
        eval { require Net::HTTPS; } or do {
            Carp::croak(q[Cannot load Net::HTTPS]);
        };
    }
    my $update_uri =
      $protocol . "://$self->{dns_server}/nic/update?hostname=" . $hostnames;
    if ( defined $ip_address ) {
        $update_uri .= '&myip=' . $ip_address;
    }
    if ( exists $params->{wildcard} ) {
        $update_uri .= '&wildcard=' . $params->{wildcard};
    }
    if ( exists $params->{mx} ) {
        $update_uri .= '&mx=' . $params->{mx};
    }
    if ( exists $params->{backmx} ) {
        $update_uri .= '&backmx=' . $params->{backmx};
    }
    if ( exists $params->{offline} ) {
        $update_uri .= '&offline=' . $params->{offline};
    }
    my $response = $self->_get($update_uri);
    my $content  = $response->content();
    my $result   = $self->_parse_content( $update_uri, $content );
    return $result;
}

sub _parse_content {
    my ( $self, $update_uri, $content ) = @_;
    my @lines = split /\015?\012/xsm, $content;
    my $result;
    foreach my $line (@lines) {
        if (
            $line =~ m{
			( \S + )  # response code
			\s+
			(\S.*) $ # ip address (possible)
			}xsm
          )
        {
            my ( $code, $additional ) = ( $1, $2 );
            if (
                   ( $code eq 'good' )
                || ( $code eq 'nochg' )
                || ( $code eq '200'
                ) # used by http://www.changeip.com/accounts/knowledgebase.php?action=displayarticle&id=47
              )
            {
                if ($result) {
                    if ( $result ne $additional ) {
                        Carp::croak(
                            "Could not understand multi-line response\n$content"
                        );
                    }
                }
                else {
                    $result = $additional;
                }
            }
            else {
                $self->_error( $code, $content );
            }
        }
        elsif (
            $line =~ m{
                ^ ( \S + ) $ # if this line of the response is a single code word
              }xsm
          )
        {
            my ($code) = ($1);
            $self->_error( $code, $content );
        }
        else {
            Carp::croak(
                "Failed to parse response from '$update_uri'\n$content");
        }
    }
    return $result;
}

1;

__END__