view release on metacpan or  search on metacpan

lib/App/perlmv.pm  view on Meta::CPAN

sub load_scriptlets {
    my ($self) = @_;
    $self->{'scriptlets'} //= $self->find_scriptlets();
}

sub find_scriptlets {
    my ($self) = @_;
    my $res    = {};

    require File::Slurper;
    require Module::List::Tiny;
    {
        my $mods = Module::List::Tiny::list_modules(
            'App::perlmv::scriptlet::',
            {list_modules=>1, recurse=>1, return_path=>1});
        for my $mod (sort keys %$mods) {
            my $name = $mod;
            $name =~ s/\AApp::perlmv::scriptlet:://;
            $name =~ s!::!/!g;
            $name =~ s!_!-!g;
            $res->{$name} = {
                module => $mod,
                code => File::Slurper::read_text($mods->{$mod}),
                from => "App::perlmv::scriptlet::*",
            };
        }
    }

    eval { require App::perlmv::scriptlets::std };
    if (%App::perlmv::scriptlets::std::scriptlets) {
        $res->{$_} = { code => $App::perlmv::scriptlets::std::scriptlets{$_},
                       from => "App::perlmv::scriptlets::std" }
            for keys %App::perlmv::scriptlets::std::scriptlets;
    }

    eval { require App::perlmv::scriptlets };
    if (%App::perlmv::scriptlets::scriptlets) {
        $res->{$_} = { code => $App::perlmv::scriptlets::scriptlets{$_},
                       from => "App::perlmv::scriptlets" }
            for keys %App::perlmv::scriptlets::scriptlets;
    }

    if (-d "/usr/share/perlmv/scriptlets") {
        local $/;
        for (glob "/usr/share/perlmv/scriptlets/*") {
            my $name = $_; $name =~ s!.+/!!;
            open my($fh), $_;
            my $code = <$fh>;
            $res->{$name} = { code => $code, from => $_ }
                if $code;
        }
    }

    if (-d "$self->{homedir}/.perlmv/scriptlets") {
        local $/;
        for (glob "$self->{homedir}/.perlmv/scriptlets/*") {
            my $name = $_; $name =~ s!.+/!!;
            open my($fh), $_;
            my $code = <$fh>;
            ($code) = $code =~ /(.*)/s; # untaint
            $res->{$name} = { code => $code, from => $_ }
                if $code;
        }
    }

    $res;
}

sub valid_scriptlet_name {
    my ($self, $name) = @_;
    $name =~ m!\A([A-Za-z0-9_][0-9A-Za-z_-]*/)*[A-Za-z0-9_][0-9A-Za-z_-]*\z!;
}

sub store_scriptlet {
    my ($self, $name, $code) = @_;
    die "FATAL: Invalid scriptlet name `$name`\n"
        unless $self->valid_scriptlet_name($name);
    die "FATAL: Code not specified\n" unless $code;
    my $path = "$self->{homedir}/.perlmv";
    unless (-d $path) {
        mkdir $path or die "FATAL: Can't mkdir `$path`: $!\n";
    }
    $path .= "/scriptlets";
    unless (-d $path) {
        mkdir $path or die "FATAL: Can't mkdir `$path: $!\n";
    }
    $path .= "/$name";
    if ((-e $path) && !$self->{'overwrite'}) {
        die "FATAL: Can't overwrite `$path (use -o)\n";
    } else {
        open my($fh), ">", $path;
        print $fh $code;
        close $fh or die "FATAL: Can't write to $path: $!\n";
    }
}

sub delete_user_scriptlet {
    my ($self, $name) = @_;
    unlink "$self->{homedir}/.perlmv/scriptlets/$name";
}

# keep sync with run_code(), run_code_for_cleaning()
sub compile_code {
    my ($self, $code) = @_;
    no strict;
    no warnings;
    local $_ = "-TEST";
    local $App::perlmv::code::PERLMV = $self;
    local $App::perlmv::code::TESTING = 1;
    local $App::perlmv::code::COMPILING = 1;
    local $App::perlmv::code::ARGS = $self->{'args'};
    eval "package App::perlmv::code; $code";
    die "FATAL: Code doesn't compile: code=$code, errmsg=$@\n" if $@;
}

# keep sync with run_code(), compile_code()
sub run_code_for_cleaning {
    my ($self, $code) = @_;
    no strict;
    no warnings;