File Coverage

blib/lib/Acme/TLDR.pm

Criterion	Covered	Total	%
statement	66	70	94.2
branch	12	16	75.0
condition	1	3	33.3
subroutine	15	15	100.0
pod			n/a
total	94	104	90.3

package Acme::TLDR;
# ABSTRACT: Abbreviate Perl namespaces for the Extreme Perl Golf


use strict;
use utf8;
use warnings qw(all);

use Digest::MD5 qw(md5_hex);
use ExtUtils::Installed;
use File::HomeDir;
use File::Spec::Functions;
use Filter::Simple;
use List::MoreUtils qw(uniq);
use Module::CoreList;
use Storable;

our $VERSION = '0.004'; # VERSION


# hack; only absolute paths
BEGIN { @main::INC = grep { substr($_, 0, 1) eq substr($^X, 0, 1) } @INC }

FILTER_ONLY
    code => sub {
        my $installed = _installed();
        my $shortened = _shorten($installed);

        while (my ($long, $short) = each %{$shortened}) {
            s{\b\Q$short\E\b}{$long}gsx;
        }
    };

sub _debug {
    my ($fmt, @args) = @_;
    printf STDERR qq($fmt\n) => @args
        if exists $ENV{DEBUG};
    return;
}

sub _installed {
    my $cache = catfile(
        File::HomeDir->my_data,
        q(.Acme-TLDR-) . md5_hex(join ':' => sort @INC) . q(.cache)
    );
    _debug(q(ExtUtils::Installed cache: %s), $cache);

    my $updated = -M $cache;

    my $modules;
    if (
        not defined $updated
            or
        grep { -e and -M _ < $updated }
        map { catfile($_, q(perllocal.pod)) }
        @INC
    ) {
        ## no critic (ProhibitPackageVars)
        _debug(q(no cache found; generating));
        $modules = [
            uniq
                keys %{$Module::CoreList::version{$]}},
                ExtUtils::Installed->new->modules,
        ];
        store $modules => $cache
            unless exists $ENV{NOCACHE};
    } else {
        _debug(q(reading from cache));
        $modules = retrieve $cache;
    }

    return $modules;
}

sub _shorten {
    my ($modules) = @_;
    my %collisions = map { $_ => 1 } @{$modules};
    my %modules;

    for my $long (sort @{$modules}) {
        my @parts = split /\b|(?=[A-Z0-9])/x, $long;
        next unless $#parts;

        my $short = join q() => map { /^(\w)\w{3,}$/x ? $1 : $_ } @parts;
        next if $short eq $long;

        unless (exists $collisions{$short}) {
            ++$collisions{$short};
            $modules{$long} = $short;
            _debug(q(%-64s => %s), $long, $short);
        } else {
            _debug(q(%-64s => *undef*), $long);
        }
    }

    return \%modules;
}

1;

__END__