chmod results from the CPAN

Doit

view release on metacpan or search on metacpan

		    error "Scope cleanup failed: $@";
		}
	    } else {
		# And eval {} in older perl versions would
		# clobber an outside $@. See
		# perldoc perl5140delta, "Exception Handling"
		$code->();
	    }
	}
    }
}

{
    package Doit::Util;
    use Exporter 'import';
    our @EXPORT; BEGIN { @EXPORT = qw(in_directory new_scope_cleanup copy_stat get_sudo_cmd is_in_path get_os_release) }
    $INC{'Doit/Util.pm'} = __FILE__; # XXX hack
    use Doit::Log;

    sub new_scope_cleanup (&) {
	my($code) = @_;
	my $sc = Doit::ScopeCleanups->new;
	$sc->add_scope_cleanup($code);
	$sc;
    }

    sub in_directory (&$) {
	my($code, $dir) = @_;
	my $scope_cleanup;
	if (defined $dir) {
	    require Cwd;
	    my $pwd = Cwd::getcwd();
	    if (!defined $pwd || $pwd eq '') { # XS variant returns undef, PP variant returns '' --- see https://rt.perl.org/Ticket/Display.html?id=132648
		warning "No known current working directory";
	    } else {
		$scope_cleanup = new_scope_cleanup
		    (sub {
			 chdir $pwd or error "Can't chdir to $pwd: $!";
		     });
	    }
	    chdir $dir
		or error "Can't chdir to $dir: $!";
	}
	$code->();
    }

    # $src may be a source file or an arrayref with stat information
    sub copy_stat ($$;@) {
	my($src, $dest, %preserve) = @_;
	my @stat = ref $src eq 'ARRAY' ? @$src : stat($src);
	error "Can't stat $src: $!" if !@stat;

	my $preserve_default   = !%preserve;
	my $preserve_ownership = exists $preserve{ownership} ? delete $preserve{ownership} : $preserve_default;
	my $preserve_mode      = exists $preserve{mode}      ? delete $preserve{mode}      : $preserve_default;
	my $preserve_time      = exists $preserve{time}      ? delete $preserve{time}      : $preserve_default;

	error "Unhandled preserve values: " . join(" ", %preserve) if %preserve;

	if ($preserve_mode) {
	    chmod $stat[2], $dest
		or warning "Can't chmod $dest to " . sprintf("0%o", $stat[2]) . ": $!";
	}
	if ($preserve_ownership) {
	    chown $stat[4], $stat[5], $dest
		or do {
		    my $save_err = $!; # otherwise it's lost in the get... calls
		    warning "Can't chown $dest to " .
			(getpwuid($stat[4]))[0] . "/" .
			(getgrgid($stat[5]))[0] . ": $save_err";
		};
	}
	if ($preserve_time) {
	    utime $stat[8], $stat[9], $dest
		or warning "Can't utime $dest to " .
		scalar(localtime $stat[8]) . "/" .
		scalar(localtime $stat[9]) .
		": $!";
	}
    }

    sub get_sudo_cmd () {
	return () if $> == 0;
	return ('sudo');
    }

    sub is_in_path {
	my($prog) = @_;

	if (!defined &_file_name_is_absolute) {
	    if (eval { require File::Spec; defined &File::Spec::file_name_is_absolute }) {
		*_file_name_is_absolute = \&File::Spec::file_name_is_absolute;
	    } else {
		*_file_name_is_absolute = sub {
		    my $file = shift;
		    my $r;
		    if ($^O eq 'MSWin32') {
			$r = ($file =~ m;^([a-z]:(/|\\)|\\\\|//);i);
		    } else {
			$r = ($file =~ m|^/|);
		    }
		    $r;
		};
	    }
	}

	if (_file_name_is_absolute($prog)) {
	    if ($^O eq 'MSWin32') {
		return $prog       if (-f $prog && -x $prog);
		return "$prog.bat" if (-f "$prog.bat" && -x "$prog.bat");
		return "$prog.com" if (-f "$prog.com" && -x "$prog.com");
		return "$prog.exe" if (-f "$prog.exe" && -x "$prog.exe");
		return "$prog.cmd" if (-f "$prog.cmd" && -x "$prog.cmd");
	    } else {
		return $prog if -f $prog and -x $prog;
	    }
	}
	require Config;
	%Config::Config = %Config::Config if 0; # cease -w
	my $sep = $Config::Config{'path_sep'} || ':';
	foreach (split(/$sep/o, $ENV{PATH})) {
	    if ($^O eq 'MSWin32') {

lib/Doit.pm view on Meta::CPAN


    use Doit::Log;

    my $diff_error_shown;
    our @diff_cmd;

    sub _new {
	my $class = shift;
	my $self = bless { }, $class;
	$self;
    }
    sub runner {
	my($self) = @_;
	# XXX hmmm, creating now self-refential data structures ...
	$self->{runner} ||= Doit::Runner->new($self);
    }
	    
    sub dryrunner {
	my($self) = @_;
	# XXX hmmm, creating now self-refential data structures ...
	$self->{dryrunner} ||= Doit::Runner->new($self, dryrun => 1);
    }

    sub init {
	my($class) = @_;
	require Getopt::Long;
	my $getopt = Getopt::Long::Parser->new;
	$getopt->configure(qw(pass_through noauto_abbrev));
	$getopt->getoptions(
			    'dry-run|n' => \my $dry_run,
			   );
	my $doit = $class->_new;
	if ($dry_run) {
	    $doit->dryrunner;
	} else {
	    $doit->runner;
	}
    }

    sub install_generic_cmd {
	my($self, $name, $check, $code, $msg) = @_;
	if (!$msg) {
	    $msg = sub { my($self, $args) = @_; $name . ($args ? " @$args" : '') };
	}
	my $cmd = sub {
	    my($self, @args) = @_;
	    my @commands;
	    my $addinfo = {};
	    if ($check->($self, \@args, $addinfo)) {
		push @commands, {
				 code => sub { $code->($self, \@args, $addinfo) },
				 msg  => $msg->($self, \@args, $addinfo),
				};
	    }
	    Doit::Commands->new(@commands);
	};
	no strict 'refs';
	*{"cmd_$name"} = $cmd;
    }

    sub cmd_chmod {
	my($self, @args) = @_;
	my %options; if (@args && ref $args[0] eq 'HASH') { %options = %{ shift @args } }
	my $quiet = delete $options{quiet};
	error "Unhandled options: " . join(" ", %options) if %options;
	my($mode, @files) = @args;
	my @files_to_change;
	for my $file (@files) {
	    my @s = stat($file);
	    if (@s) {
		if (($s[2] & 07777) != $mode) {
		    push @files_to_change, $file;
		}
	    } else {
		push @files_to_change, $file;
	    }
	}
	if (@files_to_change) {
	    my @commands =  {
			     code => sub {
				 my $changed_files = chmod $mode, @files_to_change;
				 if ($changed_files != @files_to_change) {
				     if (@files_to_change == 1) {
					 error "chmod failed: $!";
				     } elsif ($changed_files == 0) {
					 error "chmod failed on all files: $!";
				     } else {
					 error "chmod failed on some files (" . (@files_to_change-$changed_files) . "/" . scalar(@files_to_change) . "): $!";
				     }
				 }
			     },
			     ($quiet ? () : (msg => sprintf("chmod 0%o %s", $mode, join(" ", @files_to_change)))), # shellquote?
			     rv   => scalar @files_to_change,
			    };
	    Doit::Commands->new(@commands);
	} else {
	    Doit::Commands->return_zero;
	}
    }

    sub cmd_chown {
	my($self, @args) = @_;
	my %options; if (@args && ref $args[0] eq 'HASH') { %options = %{ shift @args } }
	my $quiet = delete $options{quiet};
	error "Unhandled options: " . join(" ", %options) if %options;
	my($uid, $gid, @files) = @args;

	if (!defined $uid) {
	    $uid = -1;
	} elsif ($uid !~ /^-?\d+$/) {
	    my $_uid = (getpwnam $uid)[2];
	    if (!defined $_uid) {
		# XXX problem: in dry-run mode the user/group could be
		# created in _this_ pass, so this error would happen
		# while in wet-run everything would be fine. Good solution?
		# * do uid/gid resolution _again_ in the command if it failed here?
		# * maintain a virtual list of created users/groups while this run, and
		#   use this list as a fallback?
		error "User '$uid' does not exist";
	    }
	    $uid = $_uid;
	}
	if (!defined $gid) {
	    $gid = -1;
	} elsif ($gid !~ /^-?\d+$/) {
	    my $_gid = (getgrnam $gid)[2];
	    if (!defined $_gid) {
		error "Group '$gid' does not exist";
	    }
	    $gid = $_gid;
	}

	my @files_to_change;
	if ($uid != -1 || $gid != -1) {
	    for my $file (@files) {
		my @s = stat($file);
		if (@s) {
		    if ($uid != -1 && $s[4] != $uid) {
			push @files_to_change, $file;
		    } elsif ($gid != -1 && $s[5] != $gid) {
			push @files_to_change, $file;
		    }
		} else {
		    push @files_to_change, $file;
		}
	    }
	}

	if (@files_to_change) {
	    my @commands =  {
			     code => sub {
				 my $changed_files = chown $uid, $gid, @files_to_change;

lib/Doit.pm view on Meta::CPAN

	__PACKAGE__->install_cmd($name);
    }

    sub install_cmd {
	shift; # $class unused
	my $cmd = shift;
	my $meth = 'cmd_' . $cmd;
	my $code = sub {
	    my($self, @args) = @_;
	    if ($self->{dryrun}) {
		$self->{Doit}->$meth(@args)->show;
	    } else {
		$self->{Doit}->$meth(@args)->doit;
	    }
	};
	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);

( run in 0.877 second using v1.01-cache-2.11-cpan-39bf76dae61 )