File Coverage

lib/Net/Domain/Match.pm

Criterion	Covered	Total	%
statement	28	91	30.7
branch	3	24	12.5
condition	0	3	0.0
subroutine	8	14	57.1
pod	3	8	37.5
total	42	140	30.0

package Net::Domain::Match;

use strict;

use version; our $VERSION = qv('0.2.3');

our $LOCAL = '/tmp/effective_tld_names.dat';
our $CACHE = '/tmp/effective_tld_names.dat.cache';
our $SOURCE = 'http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1';

use LWP::UserAgent;

sub import {
	if( grep { /:pdata/ } @_ ){
		$SOURCE = 'https://raw.github.com/petermblair/Perl-CPAN/master/Net-Domain-Regex/misc/tld.txt';
	}
}

sub new {
	my $class = shift;

	my $args = {
		local => $LOCAL,
		source => $SOURCE,
		cache => $CACHE,
		@_,
	};

	my $o = bless $args => $class;

	unless( -e $o->{local} ){
		$o->pull;
	}

	$o->refresh;

	return $o;
}

sub insert {
	my $self = shift;
	my $domain = shift;

	my @a = split( /\./, $domain );

	if( scalar @a == 2 ){
		$self->{tld}->{"$a[-1]"}++;
		$self->{sld}->{"$domain"}++;
	}
}

sub refresh {
	my $self = shift;

	use open qw(:std :utf8);
	open FD, "<$self->{local}";

	my $tlds = {};
	my $slds = {};

	while(  ){
		chomp;

		if(/^(\S[^\.\s]+)$/){
			$tlds->{$1}++;
		}
		elsif ( /^\S[^\.\s]+\.(.+)$/ && exists $tlds->{$1} ) {
			$slds->{$_}++;
		}
	}

	$self->{tld} = $tlds;
	$self->{sld} = $slds;

	# any manual overrides - not all ccSLD are in the external file
	for( qw/ co.uk / ){
		$self->insert( $_ );
	}

}

sub pull {
	my $self = shift;

	my $ua = LWP::UserAgent->new;
	my $req = HTTP::Request->new( GET => $self->{source} );
	my $res = $ua->request( $req );

	if( $res->is_success ){
		open FD, ">$self->{local}";
		local $/;
		print FD $res->content;
	} else {
		die $res->status_line;
	}
}

sub generate_regex {
}

sub generate_map {
	my $self = shift;

	my $map = {};

	for( keys %{$self->{tld}} ){
		$map->{$_} = {};
	}

	for( keys %{$self->{sld}} ){
		my @a = split( /\./, $_ );
		my $t = $a[-1];

		if( defined $map->{$t} ){
			$map->{$t}->{$_}++;
		}
	}

	return $map;
}

sub match {
	my $self = shift;
	my $target = shift;

	$self->match_map( $target );
}

sub match_map {
	my $self = shift;
	my $target = shift;
	my $orig = $target;

	use Data::Dumper;

	my $map = $self->generate_map();

	my @tok = split /[^\w\.\-]/, $target;

	my @results;

	TARGET:for my $target ( @tok ){
		my ( $tld, $domain, $hostname ) = ( undef, undef, '' );

		my @tokens = split( /\./, $target );

		# Check 1: Is the TLD found
		if( defined $map->{"$tokens[-1]"} ){
			# Check if the SLD is found
			if( defined $map->{"$tokens[-1]"}->{"$tokens[-2].$tokens[-1]"} ){
				$tld = "$tokens[-2].$tokens[-1]";
			} else {
				$tld = $tokens[-1];
			}
		}

		# bail out, if we don't have the TLD defined
		next TARGET unless $tld;

		# Strip out the $tld from the target
		$target =~ s/^(.*?)\.$tld$/$1/;

		# Re-split it, to get the domain
		my @a = split( /\./, $target );

		next TARGET unless scalar @a > 0;

		$domain = $a[-1];

		pop( @a );

		$hostname = join( ".", @a )
			if scalar @a > 0;

		push( @results, { match => $orig, hostname => $hostname, domain => $domain, tld => $tld } );
	}

	return @results;
}

1;

__END__