File Coverage

blib/lib/Net/NAT/PMP.pm

Criterion	Covered	Total	%
statement	9	61	14.7
branch	0	40	0.0
condition	0	3	0.0
subroutine	3	13	23.0
pod	5	10	50.0
total	17	127	13.3

#  Copyright (c) 2009 David Caldwell,  All Rights Reserved. -*- cperl -*-

use strict;
use warnings;

package Net::NAT::PMP;
our $VERSION = '0.9.4';

use IO::Socket::INET;
sub Port { 5351 }
sub Version { 0 } # protocol version we support

sub socket    { $_[0]->{socket} }
sub router_ip { $_[0]->{router_ip} }

sub error {
    my ($self, $message)  = @_;
    return $self->{error} unless defined $message;
    $self->{error} = $message;
    undef
}

sub get_router_address {
    my $gateway;
    if      ($^O eq 'darwin') {
        # Would be much better to use the sysctl interface here, natively.
        open NETSTAT, '-|', 'netstat', '-rlnf', 'inet' or die "Couldn't run netstat: $!";
        while () {
            $gateway = $1 if /^default\s+(\d+\.\d+\.\d+\.\d+)/;
        }
        close NETSTAT;
    } elsif ($^O eq 'linux') {
        open ROUTE, '<', '/proc/net/route' or die "Couldn't open /proc/net/route: $!";
        while () {
            $gateway = $1 if /^\S+\s+00000000\s+([0-9A-F]+)/;
        }
        close ROUTE;
        # Stupid linux prints it as a hex number in network byte order. The following should work on both
        # big and little endian machines. I don't have any big endian's on hand to test though.
        $gateway = join(".", unpack "CCCC", pack "L", hex $gateway) if $gateway;
    } else { die "Automatically discovering the gateway address is not supported on $^O yet! Please pass the address of your router to Net:NAT::PMP::new()" }
    $gateway;
}

sub new {
    my ($class, $router_ip) = @_;
    $router_ip ||= get_router_address();
    my $self = bless {
        router_ip => $router_ip,
        socket => IO::Socket::INET->new(PeerAddr => $router_ip, PeerPort => Net::NAT::PMP::Port, Proto=>'udp'),#, Timeout => .25),
    }, $class;
    $self->{socket} ? $self : undef;
}

sub external_address {
    my ($self) = @_;
    my $op = 0;
    return $self->error("send: $!") unless defined $self->socket->send(pack("CC", Version, $op));
    my $packet;
    return $self->error("recv: $!") unless defined $self->socket->recv($packet, 12);
    my (%response, @external_address);
    (@response{qw(vers op result_code time)}, @external_address) = unpack("CCnNCCCC", $packet);
    return $self->error("Got unexpected op $response{op} instead of @{[128 + $op]}") unless $response{op} == 128 + $op;
    return $self->error("Got unexpected result_code $response{result_code} instead of 0") unless $response{result_code} == 0;
    my $dotted = join('.', @external_address);
    return $dotted;
}

sub create_mapping {
    my ($self, $internal_port, $external_port, $lifetime_seconds, $udp) = @_;
    $external_port = $internal_port unless defined $external_port; # wheres my //= !!!
    $lifetime_seconds = 3600 unless defined $lifetime_seconds;
    my $op = $udp ? 1 : 2;
    return $self->error("send: $!") unless defined $self->socket->send(pack ("CCnnnN", Version, $op, 0, $internal_port, $external_port, $lifetime_seconds));
    my $packet;
    return $self->error("recv: $!") unless defined $self->socket->recv($packet, 16);
    my %response;
    @response{qw(vers op result_code time internal_port external_port lifetime_seconds)} = unpack "CCnNnnN", $packet;
    return $self->error("Got unexpected op $response{op} instead of @{[128 + $op]}") unless $response{op} == 128 + $op;
    return $self->error("Got unexpected result_code $response{result_code} instead of 0") unless $response{result_code} == 0;
    return $external_port;
}

sub destroy_mapping {
    my ($self, $internal_port, $udp) = @_;
    $self->create_mapping($internal_port, 0, 0, $udp);
}

1;

__END__