view release on metacpan or  search on metacpan

lib/App/Cme/Command/run.pm  view on Meta::CPAN

use base qw/App::Cme::Common/;
use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;

my $__test_home = '';
# used only by tests
## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
sub _set_test_home { $__test_home = shift; return;}

my $home = $__test_home || File::HomeDir->my_home;

my @script_paths = map {path($_)} (
    "$home/.cme/scripts",
    "/etc/cme/scripts/",
);

push @script_paths, path($INC{"Config/Model.pm"})->parent->child("Model/scripts") ;

sub opt_spec {
    my ( $class, $app ) = @_;
    return ( 
        [ "arg=s@"  => "script argument. run 'cme run <script> -doc' for possible arguments" ],
        [ "backup:s"  => "Create a backup of configuration files before saving." ],
        [ "foreach=s" => "Run script in several directories. The list of directories "
          . "must be passed as a single argument, i.e. --foreach 'foo bar'. If this "
          . "argument is '-', the list is taken from STDIN."],
        [ "commit|c:s" => "commit change with passed message" ],
        [ "cat" => "Show the script file" ],
        [ "no-commit|nc!" => "skip commit to git" ],
        [ "doc!"    => "show documention of script" ],
        [ "list!"   => "list available scripts" ],
        $class->cme_global_options,
    );
}

sub validate_args {
    my ($self, $opt, $args) = @_;

    $self->check_unknown_args($args);
    return;
}

sub usage_desc {
  my ($self) = @_;
  my $desc = $self->SUPER::usage_desc; # "%c COMMAND %o"
  return "$desc [ script ] [ -args foo=12 [ -args bar=13 ]";
}

sub description {
    my ($self) = @_;
    return $self->get_documentation;
}

sub check_script_arguments ($self, $opt, $script_name) {
    if ($opt->{list} or not $script_name) {
        my @scripts;
        foreach my $path ( @script_paths ) {
            next unless $path->is_dir;
            push @scripts, map {$_->basename} grep { ! /~$/ } $path->children();
        }
        say $opt->{list} ? "Available scripts:" : "Missing script argument. Choose one of:";
        foreach my $script_path (sort @scripts) {
            my ($file, $data) = $self->get_script_data($script_path);
            my $app_info = $data->{app} ? sprintf(" (app %s)", $data->{app}) : "";
            printf("- %s%s\n",$script_path, $app_info );
        }
        say "";
        say "Run 'cme run <script> -doc' to get more details on a script.";
        return 0;
    }
    return 1;
}

sub find_script_file ($self, $script_name) {
    my $script;
    if ($script_name =~ m!/!) {
        $script = path($script_name);
    }
    else {
        # check script in known locations
        foreach my $path ( @script_paths ) {
            next unless $path->is_dir;
            $script = $path->child($script_name);
            last if $script->is_file;
        }
    }

    die "Error: cannot find script $script_name\n" unless $script->is_file;

    return $script;
}

## no critic (Subroutines::ProhibitManyArgs)
sub replace_var_in_value ($user_args, $script_var, $data, $value) {
    state $var_pattern = qr~(?<!\\) \$([a-zA-Z]\w+) (?!\s*{)~x;

    # change $var but not \$var, not $var{} and not $1
    $value =~ s~ $var_pattern
               ~ $user_args->{$1} // $script_var->{$1} // $ENV{$1} // $data->{default}{$1} // '$'.$1 ~xeg;

    # register vars without replacements
    foreach my $var ($value =~ m~ $var_pattern ~xg) {
        $data->{missing}{$var} = 1 ;
    }

    # now change \$var in $var
    $value =~ s!\\\$!\$!g;

    return $value;
}

# replace variables with command arguments or eval'ed variables or env variables
## no critic (Subroutines::ProhibitManyArgs)
sub replace_vars ($user_args, $script_var, $data, @items) {
    foreach my $item (@items) {
        if (ref $data->{$item}  eq 'ARRAY') {
            my @new;
            foreach my $value ($data->{$item}->@*) {
                push @new, replace_var_in_value ($user_args, $script_var, $data, $value);
            }
            $data->{$item} = \@new;
        }
        elsif ($data->{$item}) {
            $data->{$item} = replace_var_in_value ($user_args, $script_var, $data, $data->{$item});
        }
    }
    return;
}

lib/App/Cme/Command/run.pm  view on Meta::CPAN

    # replace strings like "{{ config_load_path }}" in $msg
    $msg =~ s/\{\{(.*?)\}\}/$root->grab_value($1)/e;

    # replace strings like "$value" in $msg
    $msg =~ s/\$(\w+)/$values->{$1}/eg;

    return $msg;
}

# returns: script file name, script data if script is *not* Perl code
sub get_script_data ($self, $script_name, $opt = {}) {
    my $script_file = $self->find_script_file($script_name);

    my $content = $script_file->slurp_utf8;

    if ($content =~ m/^#!/ and -x $script_file) {
        my ($app) = $content =~ /# app:\s?(.*?)\n/;
        my @doc = grep {s/^##\s?//;} split /\n/, $content;
        return $script_file, {doc => \@doc, app => $app};
    }

    # parse variables passed on command line
    my %user_args = map { split '=',$_,2; } @{ $opt->{arg} };

    return ($script_file, parse_script($script_file, $content, \%user_args));
}

sub run_script_as_code ($self, $script_name, $script_file) {
    splice @ARGV, 0,2;          # remove 'run script' arguments
    my $done = eval $script_file->slurp_utf8."\n1;\n"; ## no critic (BuiltinFunctions::ProhibitStringyEval)
    if (ref $done eq 'HASH') {
        warn "script $script_name returns a hash but it's processed as a plain script.",
            " This may not be what you want\n";
    }
    die "Error in script $script_name: $@\n" unless $done;
    return;
}

sub execute {
    my ($self, $opt, $app_args) = @_;

    # cannot use logger until Config::Model is initialised

    # see Debian #839593 and perlunicook(1) section X 13
    @$app_args = map { decode_utf8($_, 1) } @$app_args;

    my $script_name = shift @$app_args;

    return unless $self->check_script_arguments($opt, $script_name);

    my ($script_file, $script_data) = $self->get_script_data($script_name, $opt);

    if ($opt->{cat}) {
        print $script_file->slurp_utf8;
        return;
    }

    my $commit_msg = $script_data->{commit_msg};

    if ($opt->doc) {
        say join "\n", $script_data->{doc}->@*;
        say "will commit with message: '$commit_msg'" if $commit_msg;
        return;
    }

    if (not defined $script_data->{app}) {
        $self->run_script_as_code ($script_name, $script_file);
        return;
    }

    if (my @missing = sort keys $script_data->{missing}->%*) {
        die "Error: Missing variables '". join("', '",@missing)
            ."' in command arguments for script $script_file\n"
            ."Please use option '".join(' ', map { "-arg $_=xxx"} @missing)."'\n";
    }

    $self->process_args($opt, [ $script_data->{app}, $app_args->@* ]);

    # override commit message. may also trigger a commit even if none
    # is specified in script
    if ($opt->{commit}) {
        $commit_msg = $opt->{commit};
    }

    $opt->{_verbose} = 'Loader' if $opt->{verbose};

    my ( $categories, $appli_info, $appli_map ) = Config::Model::Lister::available_models;
    my $app = $script_data->{app};
    if ($opt->{foreach} and $appli_info->{$app}{_category} ne 'application') {
        die "Cannot use --foreach option with $app. This option can only be used with ".
            join(' ', $categories->{application}->@*). ". Check your cme script.\n";
    }

    # parse variables passed on command line

    if ($opt->{foreach}) {
        $self->run_foreach_loop($opt,$app_args, $script_data);
    }
    else {
        my %user_args = map { split '=',$_,2; } @{ $opt->{arg} };
        $self->run_script ($opt, $app_args, $script_data, \%user_args);
    }

    return;
}

sub run_foreach_loop($self, $opt,$app_args, $script_data ) {
    my %user_args = map { split '=',$_,2; } @{ $opt->{arg} };

    ## no critic (BuiltinFunctions::ProhibitComplexMappings)
    my @dirs = map { chomp; split /\s+/; }
        ($opt->{foreach} eq '-' ? <STDIN> : ($opt->{foreach}));

    my $start = path('.')->absolute;

    foreach my $d (@dirs) {
        my $t_dir = $start->child($d);
        if (not $t_dir->is_dir) {
            die "Cannot run script in $d: not a directory\n";
        }
        say "Running script in $t_dir ...";
        # instance is stored in Config::Model, so the name must be changed
        $opt->{instance_name} = $d;
        # instance is persisted in $self, so its ref must be removed
        delete $self->{_instance};
        chdir $t_dir->stringify;
        $self->run_script ($opt, $app_args, $script_data, {%user_args});
        # once we're done, remove instance from Model to avoid memory leaks
        $self->{_model}->delete_instance($d);
    }

    chdir $start->stringify;
    return;
}

sub run_script ($self, $opt, $app_args, $script_data, $user_args){
    my $commit_msg = $script_data->{commit_msg};
    my $stashed;

    # stash pending work
    if ($commit_msg and not $opt->{no_commit}) {
        $stashed = $self->autostash;
    }

    # call loads
    my ($model, $inst, $root) = $self->init_cme($opt,$app_args);
    foreach my $load_str ($script_data->{load}->@*) {
        $root->load($load_str);
    }

    if ($script_data->{code}) {
        my $to_run = '';
        while (my ($name, $value) = each $script_data->{values}->%*) {
            $to_run .= "my \$$name = '$value';\n";
        }
        $to_run .= join("\n",$script_data->{code}->@*);
        my $res = eval($to_run); ## no critic (ProhibitStringyEval)
        die "Error in code specification: $@\ncode is: \n$to_run\n" if $@;
    }

    if ($script_data->{sub}) {
        $script_data->{sub}->($root, $user_args);
    }

    if ($inst->needs_save) {
        $self->save($inst,$opt) ;

        # commit if needed
        if ($commit_msg and not $opt->{no_commit}) {
            my $processed_msg = $self->process_commit_message(
                $root, $script_data->{values}, $commit_msg
            );
            $self->commit($processed_msg);
        }
    } else {
        say "No change were applied";
    }


    if ($stashed) {
        $self->pop_stash;
    }

    return;
}

package App::Cme::Run::Var; ## no critic (Modules::ProhibitMultiplePackages)
$App::Cme::Run::Var::VERSION = '1.049';
require Tie::Hash;

## no critic (ClassHierarchies::ProhibitExplicitISA)
our @ISA = qw(Tie::ExtraHash);

sub FETCH {
    my ($self, $key) = @_ ;
    my ($h, $missing, $default) = @$self;
    my $res = $h->{$key} // $default->{$key} ;
    $missing->{$key} = 1 unless defined $res;
    return $res // '';
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

App::Cme::Command::run - Run a cme script

=head1 VERSION

version 1.049

=head1 SYNOPSIS

 $ cat ~/.cme/scripts/remove-mia
 doc: remove mia from Uploaders. Require mia parameter
 # declare app to configure
 app: dpkg
 # specify one or more instructions
 load: ! control source Uploaders:-~/$mia$/
 # commit the modifications with a message (git only)
 commit: remove MIA dev $mia

 $ cme run remove-mia -arg mia=longgone@d3bian.org

 # cme run can also use environment variables
 $ cat ~/.cme/scripts/add-me-to-uploaders
 app: dpkg-control
 load: source Uploaders:.push("$DEBFULLNAME <$DEBEMAIL>")

 $ cme run add-me-to-uploaders