File Coverage

bin/perldolicious

Criterion	Covered	Total	%
statement	46	65	70.7
branch	4	16	25.0
condition			n/a
subroutine	14	17	82.3
pod			n/a
total	64	98	65.3

#!/usr/bin/env perl
# -*- mode: perl -*- # cperl-mode doesn't recognize the DATA section  -_-

use Mojolicious::Lite;
use 5.010;

use File::Path ();
use File::Spec::Functions qw(catfile);
use File::Temp       ();
use File::Which      ();
use IO::Zlib         ();
use Mojo::UserAgent  ();
use Module::CoreList ();
use Module::Path     ();
use Mojo::JSON       ();
use Scalar::Util     ();
use Storable         ();

our $VERSION = '0.011';
$VERSION = eval $VERSION;

sub get_modules {
    my $cpan_package_file = shift;
    die "$cpan_package_file doesn't exist" unless -f $cpan_package_file;

    my $fh = IO::Zlib->new($cpan_package_file, 'r')
      or die "Could not open '$cpan_package_file': $!";

    my $modules;
    while (<$fh>) {
        my @columns = split /\s+/;
        next unless @columns == 3;
        my $module = $columns[0];
        push @$modules, $module;
    }

    return $modules;
}

sub write_modules {
    my ($modules_cache_file, $cpan_package_file) = @_;

    my $modules = get_modules($cpan_package_file);
    Storable::nstore($modules, $modules_cache_file);
}

sub compile_pattern {
    my ($pattern, $p) = @_;
    die "No pattern specified\n" unless $pattern;

    local $@;
    eval { $pattern = $p->{ignore_case} ? qr{$pattern}i : qr{$pattern}; };
    die "Invalid regular expression\n" if $@;

    return $pattern;
}

sub read_json_config {
    my $config_file = shift;

    open my $fh, '<', $config_file
      or die "Could not open '$config_file': $!";

    local $/;
    my $bytes = <$fh>;

    close $fh or die "Could not close '$config_file': $!";
    return Mojo::JSON->new()->decode($bytes);
}

helper setup_modules_file => sub {
    my $cache_file = app->config('modules_cache_file');
    my $limit      = app->config('auto_download');

    die "Configuration auto_download: $limit doesn't look like number\n"
      unless Scalar::Util::looks_like_number($limit);

    # file does not exist or file exists but it's older than the
    # specified limit (in days)
    if (not -f $cache_file
        or -f $cache_file and -M $cache_file > $limit)
    {

        if (-f $cache_file) {
            app->log->info("Deleting cache file $cache_file");
            unlink $cache_file or die $!;
        }

        my $url = 'http://www.cpan.org/modules/02packages.details.txt.gz';

        my $tempfile          = File::Temp->new;
        my $download_location = $tempfile->filename;

        app->log->info("Downloading $url to $download_location");
        Mojo::UserAgent->new->get($url)
          ->res->content->asset->move_to($download_location);

        app->log->info("Caching modules to $cache_file");
        write_modules($cache_file, $download_location);

    }
};

helper setup_log => sub {
    my ($self, $confdir) = @_;
    my $logfile = catfile($confdir, 'server.log');
    my $limit = 2_000_000;    # 2MB
    if (-f $logfile and -s $logfile > $limit) {
        unlink $logfile or die "Could not delete '$logfile'";
        app->log->info("Deleting $logfile");
    }

    app->log->path($logfile) if app->config('quiet');
};

helper initialize => sub {
    # for some reason cpandoc is not installed on some machines, even though
    # Pod::Cpandoc is already listed as a prereq in Build.PL
    die "cpandoc is not installed on your system\n"
      unless File::Which::which('cpandoc');

    my $confdir = $ENV{PERLDOLICIOUS_HOME}
      || catfile($ENV{HOME}, '.perldolicious');

    unless (-d $confdir) {
        File::Path::make_path($confdir)
          or die "Could not create directory $confdir";
    }

    my $confile = catfile($confdir, 'config.json');
    my $conf = {
        modules_cache_file => catfile($confdir, 'modules.storable'),
        auto_download      => 14,               # 2 weeks
        quiet              => 0
    };

    if (-f $confile) {
        my $user_conf = read_json_config($confile) || {};
        %$conf = (%$conf, %$user_conf);    # merge config
    }

    app->config($_ => $conf->{$_}) for keys %$conf;

    app->setup_log($confdir);
    app->setup_modules_file;

    app->log->info('*** STARTING A NEW SESSION ***');
    app->log->info("Config dir: $confdir");
    app->log->info("Loaded config file: $confile") if -f $confile;
    app->log->info('Loaded cache file: ' . app->config('modules_cache_file'));
};

helper find_modules => sub {
    my ($self, $pattern, $p) = @_;

    $pattern = compile_pattern($pattern, $p);
    my $modules_cache_file = app->config('modules_cache_file');

    state $modules = Storable::retrieve($modules_cache_file);
    return [grep { /$pattern/ } @$modules];
};

helper perldoc => sub {
    my ($self, $module, $p) = @_;
    my $args = $p->{source} ? '-m' : '-t';
    chomp(my $doc = `cpandoc $args $module`);
    return $doc;
};

get '/' => sub {
    my $self = shift;

    $self->render(
        template   => 'index',
        action_url => $self->url_for('/results'),
    );
};

post '/results' => sub {
    my $self = shift;
    my ($pattern, $ignore_case) =
      ($self->param('pattern'), $self->param('ignoreCase'));

    my $modules;

    local $@;

    eval {
        $modules =
          $self->find_modules($pattern, {ignore_case => $ignore_case});
    };

    if ($@) {
        $self->render_exception($@);
    }
    elsif (@$modules) {
        $self->render(
            pattern => $pattern,
            modules => $modules,
            matches => scalar(@$modules),
        );
    }
    else {
        $self->render_exception("Could not find modules that match $pattern");
    }
};

get '/doc/:module' => sub {
    my $self   = shift;
    my $module = $self->param('module');

    (my $distname = $module) =~ s{::}{-}g;
    my $release_date = Module::CoreList->first_release($module);

    my @known_temp_dirs = (qr{/var/folders}, qr{/tmp/}, qr{Local\\Temp});
    my $location = Module::Path::module_path($module);

    $location = undef if $location and grep { /$location/ } @known_temp_dirs;

    $self->render(
        template        => "doc",
        module          => $module,
        distname        => $distname,
        doc             => $self->perldoc($module),
        location        => $location,
        release_date    => $release_date,
        source_code_url => $self->url_for("/doc/$module/source"),
    );
};

get '/doc/:module/source' => sub {
    my $self   = shift;
    my $module = $self->param('module');
    $self->render(
        module      => $module,
        template    => 'source',
        source_code => $self->perldoc($module, {source => 1}),
    );
};

app->mode('production');
app->initialize;
app->defaults(layout => 'index');
app->start;

__DATA__