File Coverage

blib/lib/Data/Tranco.pm

Criterion	Covered	Total	%
statement	111	114	97.3
branch	11	24	45.8
condition	1	3	33.3
subroutine	27	27	100.0
pod	1	9	11.1
total	151	177	85.3

package Data::Tranco;
# ABSTRACT: An interface to the Tranco domain list.
use Archive::Zip qw(:ERROR_CODES);
use Archive::Zip::MemberRead;
use Carp;
use DBD::SQLite;
use DBI;
use Data::Mirror qw(mirror_file);
use File::Basename qw(basename dirname);
use File::Spec;
use File::stat;
use POSIX qw(getlogin);
use Text::CSV_XS;
use constant TRANCO_URL => 'https://tranco-list.eu/top-1m.csv.zip';
use feature qw(state);
use open qw(:encoding(utf8));
use strict;
use utf8;
use vars qw($TTL $ZIPFILE $DBFILE $DSN $STATIC);
use warnings;

$TTL        = 86400;
$ZIPFILE    = mirror_file(TRANCO_URL);
$DBFILE     = File::Spec->catfile(dirname($ZIPFILE), basename($ZIPFILE, '.zip').'.db');
$DSN        = 'dbi:SQLite:dbname='.$DBFILE;
$STATIC     = undef;


sub random_domain {
    my ($package, $suffix) = @_;

    state $sth = $package->get_db->prepare(q{
        SELECT * FROM `domains`
        WHERE `domain` LIKE ?
        ORDER BY RANDOM()
        LIMIT 0,1});

    $sth->execute($suffix ? '%.'.$suffix : '%');

    return reverse($sth->fetchrow_array);
}


sub top_domain {
    my ($package, $suffix) = @_;

    state $sth = $package->get_db->prepare(q{
        SELECT * FROM `domains`
        WHERE `domain` LIKE ?
        ORDER BY `id`
        LIMIT 0,1});

    $sth->execute($suffix ? '%.'.$suffix : '%');

    return reverse($sth->fetchrow_array);
}


sub sample {
    my ($package, $count, $suffix) = @_;

    state $sth = $package->get_db->prepare(q{
        SELECT `domain` FROM `domains`
        WHERE `domain` LIKE ?
        ORDER BY RANDOM()
        LIMIT 0,?});

    $sth->execute($suffix ? '%.'.$suffix : '%', int($count));

    my @domains;

    while (my @row = $sth->fetchrow_array) {
        push(@domains, @row);
    }

    return @domains;
}


sub top_domains {
    my ($package, $count, $suffix) = @_;

    state $sth = $package->get_db->prepare(q{
        SELECT `domain` FROM `domains`
        WHERE `domain` LIKE ?
        ORDER BY `id`
        LIMIT 0,?});

    $sth->execute($suffix ? '%.'.$suffix : '%', int($count));

    my @domains;

    while (my @row = $sth->fetchrow_array) {
        push(@domains, @row);
    }

    return @domains;
}


sub all {
    my ($package, $suffix) = @_;

    state $sth = $package->get_db->prepare(q{
        SELECT `domain` FROM `domains`
        WHERE `domain` LIKE ?
        ORDER BY `id`});

    $sth->execute($suffix ? '%.'.$suffix : '%');

    my @domains;

    while (my @row = $sth->fetchrow_array) {
        push(@domains, @row);
    }

    return @domains;
}


sub rank {
    my ($package, $domain) = @_;

    state $sth = $package->get_db->prepare(q{
        SELECT `id`
        FROM `domains`
        WHERE (`domain`=?)
    });

    $sth->execute($domain);

    return $sth->fetchrow_array;
}


sub get_db {
    my $package = shift;

    state $db;

    if (!$db) {
        $package->update_db if ($package->needs_update);

        $db = DBI->connect($DSN);
    }

    return $db;
}


#
# returns true if the database needs updating, that is:
#
# 0. $STATIC is not defined
# 1. the DB file doesn't exist
# 2. the zip file doesn't exist
# 3. the DB file is older than the zip file
# 4. the zip file is more than TTL seconds old
#
sub needs_update {
    my $package = shift;

    return undef if ($STATIC);

    return 1 unless (-e $DBFILE && -e $ZIPFILE);
    return 1 unless (stat($DBFILE)->mtime > stat($ZIPFILE)->mtime);
    return 1 unless (stat($ZIPFILE)->mtime > time() - $TTL);

    return undef;
}

sub update_db {
    my $package = shift;

    mirror_file(TRANCO_URL, $TTL);

    my $zip = Archive::Zip->new;

    croak('Zip read error') unless ($zip->read($ZIPFILE) == AZ_OK);

    my $db = DBI->connect($DSN, undef, undef, { AutoCommit => 0 });

    $db->do(q{
        CREATE TABLE IF NOT EXISTS `domains` (
            `id`        INTEGER PRIMARY KEY,
            `domain`    TEXT UNIQUE COLLATE NOCASE
        )
    });

    my $sth = $db->prepare(q{INSERT INTO `domains` (`id`, `domain`) VALUES (?, ?)});

    $db->do(q{DELETE FROM `domains`});

    my $fh  = Archive::Zip::MemberRead->new($zip, basename(TRANCO_URL, '.zip'));
    my $csv = Text::CSV_XS->new;
    while (my $row = $csv->getline($fh)) {
        $sth->execute(@{$row});
    }

    $db->commit;
    $db->disconnect;
}

1;

__END__