public suffix from domain

psl.pl

#!/usr/bin/env perl

use strict;
use feature qw(say);
use autodie;
use LWP::UserAgent;
use HTTP::Request;
use File::Temp qw(tempfile);
use Getopt::Long qw(:config posix_default no_ignore_case gnu_compat);

our $PSL = "https://raw.githubusercontent.com/publicsuffix/list/master/public_suffix_list.dat";

my %opts;
GetOptions(\%opts, qw(
    list|l=s
    naked-domain|n
 ));


if (@ARGV != 1) {
    say "Usage: $0 [-l local_public_suffix_path -n ] domain";
    exit 1;
}

my $tree = make_tree();

my $domain = shift;
say exists $opts{'naked-domain'} ? naked_domain($domain) : public_suffix($domain);

sub naked_domain {

    my $domain = shift;
    my $public_suffix = public_suffix($domain);
    if (!$public_suffix) {
        return;
    }
    my $quote_public_suffix = quotemeta($public_suffix);
    $domain =~ s/\.${quote_public_suffix}$//;
    return (split(/\./, $domain))[-1] . "." . $public_suffix;
}


sub public_suffix {

    my $domain = shift;
    my @parts = reverse(split /\./, $domain);
    my $tmp_parts = [];
    _public_suffix($tree, $tmp_parts, @parts);
    return join(".", reverse(@{$tmp_parts}));
}

sub _public_suffix {

    my($tree, $tmp_parts, @parts) = @_;
    my $subtree;
    if (scalar(@parts) == 0) {
        return;
    }
    my $part = shift @parts;
    if (exists $tree->{$part}) {
        push @{$tmp_parts}, $part;
        $subtree = $tree->{$part};
    } else {
        return;
    }
    return _public_suffix($subtree, $tmp_parts, @parts);
}

sub make_tree {

    my $tree = {};
    my $psl;
    my $fh;
    if ($opts{list}){
        $psl = $opts{list};
        open $fh, "<", $psl;
    } else {
        ($fh, $psl) = tempfile(UNLINK => 1);
        my $ua  = LWP::UserAgent->new;
        my $req = HTTP::Request->new(GET => $PSL);
        my $res = $ua->request($req, sub { my $content = shift; print $fh $content });
        if (!$res->is_success) {
            die $res->status_line;
        }
        seek $fh, 0, 0;
    }
    while (my $line = <$fh>) {
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;
        if ($line eq "" || $line =~ /^\/\//) {
            next;
        }
        my @parts = reverse(split /\./, $line);
        _make_tree($tree, @parts);
    }
    close $fh;
    return $tree;
}

sub _make_tree {

    my($tree, @parts) = @_;
    if (scalar(@parts) == 0) {
        return;
    }
    my $part = shift @parts;
    if (!exists $tree->{$part}) {
        $tree->{$part} = {}
    }
    return _make_tree($tree->{$part}, @parts);
}