Doit
view release on metacpan or search on metacpan
lib/Doit.pm view on Meta::CPAN
}
}
$$bufref;
};
my @commands;
push @commands, {
(code => $code, $info ? (run_always => 1) : ()),
($quiet ? () : (msg => "@args")),
};
Doit::Commands->new(@commands);
}
sub cmd_info_qx {
my($self, @args) = @_;
my %options; if (@args && ref $args[0] eq 'HASH') { %options = %{ shift @args } }
$options{info} = 1;
$self->cmd_qx(\%options, @args);
}
sub cmd_rmdir {
my($self, $directory) = @_;
if (-d $directory) {
my @commands = {
code => sub { rmdir $directory or error "$!" },
msg => "rmdir $directory",
};
Doit::Commands->new(@commands);
} else {
Doit::Commands->return_zero;
}
}
sub cmd_run {
my($self, @args) = @_;
my @commands;
push @commands, {
code => sub {
require IPC::Run;
my $success = IPC::Run::run(@args);
if (!$success) {
_handle_dollar_questionmark;
}
},
msg => do {
my @print_cmd;
for my $arg (@args) {
if (ref $arg eq 'ARRAY') {
push @print_cmd, @$arg;
} else {
push @print_cmd, $arg;
}
}
join " ", @print_cmd;
},
rv => 1,
};
Doit::Commands->new(@commands);
}
sub cmd_setenv {
my($self, $key, $val) = @_;
if (!defined $ENV{$key} || $ENV{$key} ne $val) {
my @commands = {
code => sub { $ENV{$key} = $val },
msg => qq{set \$ENV{$key} to "$val", previous value was } . (defined $ENV{$key} ? qq{"$ENV{$key}"} : qq{unset}),
rv => 1,
};
Doit::Commands->new(@commands);
} else {
Doit::Commands->return_zero;
}
}
sub cmd_symlink {
my($self, $oldfile, $newfile) = @_;
my $doit;
if (-l $newfile) {
my $points_to = readlink $newfile
or error "Unexpected: readlink $newfile failed (race condition?)";
if ($points_to ne $oldfile) {
$doit = 1;
}
} elsif (!-e $newfile) {
$doit = 1;
} else {
warning "$newfile exists but is not a symlink, will fail later...";
}
if ($doit) {
my @commands = {
code => sub { symlink $oldfile, $newfile or error "$!" },
msg => "symlink $oldfile $newfile",
rv => 1,
};
Doit::Commands->new(@commands);
} else {
Doit::Commands->return_zero;
}
}
sub cmd_system {
my($self, @args) = @_;
my %options; if (@args && ref $args[0] eq 'HASH') { %options = %{ shift @args } }
my $quiet = delete $options{quiet};
my $info = delete $options{info};
my $show_cwd = delete $options{show_cwd};
error "Unhandled options: " . join(" ", %options) if %options;
@args = Doit::Win32Util::win32_quote_list(@args) if Doit::IS_WIN;
my $code = sub {
system @args;
if ($? != 0) {
_handle_dollar_questionmark;
}
};
my @commands;
push @commands, {
rv => 1,
code => $code,
lib/Doit.pm view on Meta::CPAN
sub cmd_touch {
my($self, @files) = @_;
my @commands;
for my $file (@files) {
if (!-e $file) {
push @commands, {
code => sub { open my $fh, '>>', $file or error "$!" },
msg => "touch non-existent file $file",
}
} else {
push @commands, {
code => sub { utime time, time, $file or error "$!" },
msg => "touch existent file $file",
};
}
}
my $doit_commands = Doit::Commands->new(@commands);
$doit_commands->set_last_rv(scalar @files);
$doit_commands;
}
sub cmd_create_file_if_nonexisting {
my($self, @files) = @_;
my @commands;
for my $file (@files) {
if (!-e $file) {
push @commands, {
code => sub { open my $fh, '>>', $file or error "$!" },
msg => "create empty file $file",
};
}
}
if (@commands) {
my $doit_commands = Doit::Commands->new(@commands);
$doit_commands->set_last_rv(scalar @commands);
$doit_commands;
} else {
Doit::Commands->return_zero;
}
}
sub cmd_unlink {
my($self, @files) = @_;
my @files_to_remove;
for my $file (@files) {
if (-e $file || -l $file) {
push @files_to_remove, $file;
}
}
if (@files_to_remove) {
my @commands = {
code => sub { unlink @files_to_remove or error "$!" },
msg => "unlink @files_to_remove", # shellquote?
};
Doit::Commands->new(@commands);
} else {
Doit::Commands->return_zero;
}
}
sub cmd_unsetenv {
my($self, $key) = @_;
if (defined $ENV{$key}) {
my @commands = {
code => sub { delete $ENV{$key} },
msg => qq{unset \$ENV{$key}, previous value was "$ENV{$key}"},
rv => 1,
};
Doit::Commands->new(@commands);
} else {
Doit::Commands->return_zero;
}
}
sub cmd_utime {
my($self, $atime, $mtime, @files) = @_;
my $now;
if (!defined $atime) {
$atime = ($now ||= time);
}
if (!defined $mtime) {
$mtime = ($now ||= time);
}
my @files_to_change;
for my $file (@files) {
my @s = stat $file;
if (@s) {
if ($s[8] != $atime || $s[9] != $mtime) {
push @files_to_change, $file;
}
} else {
push @files_to_change, $file; # will fail later
}
}
if (@files_to_change) {
my @commands = {
code => sub {
my $changed_files = utime $atime, $mtime, @files;
if ($changed_files != @files_to_change) {
if (@files_to_change == 1) {
error "utime failed: $!";
} elsif ($changed_files == 0) {
error "utime failed on all files: $!";
} else {
error "utime failed on some files (" . (@files_to_change-$changed_files) . "/" . scalar(@files_to_change) . "): $!";
}
}
},
msg => "utime $atime, $mtime, @files",
rv => scalar @files_to_change,
};
Doit::Commands->new(@commands);
} else {
Doit::Commands->return_zero;
}
}
sub cmd_which {
lib/Doit.pm view on Meta::CPAN
no strict 'refs';
*{$cmd} = $code;
}
sub add_component {
my($self, $component_or_module) = @_;
my $module;
if ($component_or_module =~ /::/) {
$module = $component_or_module;
} else {
$module = 'Doit::' . ucfirst($component_or_module);
}
for (@{ $self->{components} }) {
return if $_->{module} eq $module;
}
if (!eval qq{ require $module; 1 }) {
Doit::Log::error("Cannot load $module: $@");
}
my $o = $module->new
or Doit::Log::error("Error while calling $module->new");
for my $function ($o->functions) {
my $fullqual = $module.'::'.$function;
my $code = sub {
my($self, @args) = @_;
$self->$fullqual(@args);
};
no strict 'refs';
*{$function} = $code;
}
my $mod_file = do {
(my $relpath = $module) =~ s{::}{/};
$relpath .= '.pm';
};
push @{ $self->{components} }, { module => $module, path => $INC{$mod_file}, relpath => $mod_file };
if ($o->can('add_components')) {
for my $sub_component ($o->add_components) {
$self->add_component($sub_component);
}
}
}
for my $cmd (
qw(chmod chown mkdir rename rmdir symlink unlink utime),
qw(make_path remove_tree), # File::Path
qw(copy move), # File::Copy
qw(run), # IPC::Run
qw(qx info_qx), # qx// and variant which even runs in dry-run mode, both using list syntax
qw(open2 info_open2), # IPC::Open2
qw(open3 info_open3), # IPC::Open3
qw(system info_system), # builtin system with variant
qw(cond_run), # conditional run
qw(touch), # like unix touch
qw(ln_nsf), # like unix ln -nsf
qw(which), # like unix which
qw(create_file_if_nonexisting), # does the half of touch
qw(write_binary), # like File::Slurper
qw(change_file), # own invention
qw(setenv unsetenv), # $ENV manipulation
) {
__PACKAGE__->install_cmd($cmd);
}
sub call_wrapped_method {
my($self, $context, $method, @args) = @_;
my @ret;
if ($context eq 'a') {
@ret = eval { $self->$method(@args) };
} else {
$ret[0] = eval { $self->$method(@args) };
}
if ($@) {
('e', $@);
} else {
('r', @ret);
}
}
# XXX call vs. call_with_runner ???
sub call {
my($self, $sub, @args) = @_;
$sub = 'main::' . $sub if $sub !~ /::/;
no strict 'refs';
&$sub(@args);
}
sub call_with_runner {
my($self, $sub, @args) = @_;
$sub = 'main::' . $sub if $sub !~ /::/;
no strict 'refs';
&$sub($self, @args);
}
# XXX does this belong here?
sub do_ssh_connect {
my($self, $host, %opts) = @_;
my $remote = Doit::SSH->do_connect($host, dry_run => $self->is_dry_run, components => $self->{components}, %opts);
$remote;
}
# XXX does this belong here?
sub do_sudo {
my($self, %opts) = @_;
my $sudo = Doit::Sudo->do_connect(dry_run => $self->is_dry_run, components => $self->{components}, %opts);
$sudo;
}
# XXX does this belong here?
sub do_fork {
my($self, %opts) = @_;
$self->add_component(qw(fork));
my $fork = Doit::Fork->do_connect(dry_run => $self->is_dry_run, %opts);
$fork;
}
}
{
package Doit::RPC;
( run in 0.938 second using v1.01-cache-2.11-cpan-39bf76dae61 )