view release on metacpan or  search on metacpan

bin/rs  view on Meta::CPAN

#!/usr/bin/env perl

#   Copyright © 2018 Yang Bo
#
#   This file is part of RSLinux.
#
#   RSLinux is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#
#   RSLinux is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with RSLinux.  If not, see <http://www.gnu.org/licenses/>.

use App::rs 'sane',
    iautoload => ['App::rs',
		  ['Term::ANSIColor', [qw/colored c/]],
		  [qw/Cwd abs_path getcwd/],
		  [qw/File::Path make_path/],
		  ['List::Util', map { "&$_" } qw/reduce all first none/],
		  ['Fcntl', map { "&$_" } qw/S_IFMT S_IFLNK S_IFREG S_IFDIR/],
		  [qw/Config %Config/]];

BEGIN {
	for my $c (qw/green cyan yellow magenta red/) {
		no strict 'refs';
		my $f = uc substr $c, 0, 1;
		*$f = sub () { [$c] };
		*{$f x 2} = sub () { ['bold', $c] };
	}
}
sub set {
	my ($f, $m) = @_;
	# chown should be called before chmod to prevent setuid, setgid bit gets reset.
	chown @$m{qw/uid gid/}, $f and chmod $m->{mode} & 07777, $f and utimensat($f, $m->{mtime}) or die "$f: $!";
}
sub equiv {
	my ($p, $q) = @_;
	no warnings 'uninitialized';
	all { $p->{$_} eq $q->{$_} } qw/mode uid gid size mtime hl sl/;
}
sub elf {
	open my $fh, '<', shift or die $!;
	my $b;
	read($fh, $b, 4) == 4 and $b eq "\x7fELF";
}
sub strip {
	my ($f, $m, $root) = @_;
	my $s;
	if (/\.[ao]$/)						{ @$s{qw/strip archive/} = (1, 1) }
	elsif ((/\.so/ or $m->{mode} & 0111) and elf($f))	{ $s->{strip} = 1 }
	if ($s->{strip}) {
		xsh(0, 'strip', $s->{archive} ? '--strip-unneeded' : (), $f);
		say "strip on $f, st: $?.";
		if (not $?) {
			set($f, $m);
			$m->{size} = (stat $f)[7];
		}
	}
}
sub _diff {
	my ($cp, $vp) = @_;
	my ($db, $v) = ($vp->{db}, {});
	opendir(my $dh, $cp->{root} . $vp->{d}) or die $!;
	for (sort readdir $dh) {
		my $ign = $vp->{ign}{$_};
		# ignore leaf only.
		next if /^\.{1,2}$/ or $ign and not ref $ign;
		my ($r, $m) = ($vp->{d} . $_, {});
		my $f = $cp->{root} . $r;
		(my $i, @$m{qw/mode uid gid size mtime/}) = (lstat $f)[1, 2, 4, 5, 7, 9];
		if ($cp->{ih}{$i})	{ $m->{hl} = $cp->{ih}{$i} }
		else			{ $cp->{ih}{$i} = $r }
		my $t = $m->{mode} & S_IFMT;
		if ($t == S_IFDIR)	{ delete $m->{size} }
		elsif ($t == S_IFLNK)	{ $m->{sl} = readlink $f or die $! }
		elsif ($t != S_IFREG)	{ die "unknown type $t of $f." }
		my $st = {};
		if (my $_m = $db->{$_}) {
			my $_t = $_m->{mode} & S_IFMT;
			if ($t == S_IFDIR xor $_t == S_IFDIR)	{ ... }
			elsif ($t == S_IFDIR)			{ $st->{dir} = 1 }
			else					{ $st->{mod} = 1 if not equiv($m, $_m) }
		} else {
			$st->{ne} = 1;
		}
		if (%$st) {
			if ($t == S_IFDIR) {
				add(my $p = $db->{$_} ||= {c => {}}, %$m);
				my $c = _diff($cp, {db => $p->{c},
						    ign => $vp->{ign}{$_},
						    d => $r . '/'});
				if ($st->{ne} or %$c) {
					$v->{$_} = {%$m,
						    c => $c};
					$p->{owner}{$cp->{oid}} = $cp->{ts};
				}
			} else {
				my $n = 1 if $t == S_IFREG and not $m->{hl};
				strip($f, $m) if $n and $cp->{wet};
				my $p = $db->{$_} = {%$m,
						     owner => $db->{$_}{owner}};
				$p->{owner}{current} = $cp->{oid}, $p->{owner}{record}{$cp->{oid}} = $cp->{ts};
				$v->{$_} = {%$m};
				$v->{$_}{c} = \$f if $n;
			}
		}
	}
	$v;
}
sub _patch {
	my ($cp, $vp) = @_;
	my ($db, $v) = @$vp{qw/db v/};
	for (sort keys %$v) {
		my ($r, $q) = ($vp->{d} . $_, $v->{$_});
		my $f = $cp->{root} . $r;
		# That's for historical reasons...
		my $t = $q->{sl} ? S_IFLNK : $q->{mode} & S_IFMT;
		if ($t == S_IFDIR) {
			if (not $db->{$_}) {
				mkdir $f or die "mkdir $f: $!";
				$db->{$_} = {%$q,
					     c => {}};
			}
			my $p = $db->{$_};
			_patch($cp, {v => $q->{c},
				     db => $p->{c},
				     d => $r . '/'});
			set($f, $p) if not $p->{owner};
			$p->{owner}{$cp->{oid}} = $cp->{ts};
		} else {
			unlink $f or die "$f exists but unable to unlink." if -e $f;
			if ($t == S_IFREG) {
				if ($q->{hl}) {
					my $g = $cp->{root} . $q->{hl};
					link $g, $f or die "unable to hard link $f to $g: $!";
				} else {
					wf($f, delete $q->{c});
					set($f, $q);
				}
			} else {
				# That's really nasty...
				symlink my $g = $q->{sl}, $f or die "unable to symlink $f to $q->{sl}: $!.";
				# symlink(7) explicitly says the permission of a symbolic link can't be changed(on Linux).
				lchown($f, @$q{qw/uid gid/}) and utimensat($f, $q->{mtime}) or die "$f: $!";
			}
			# A new hash is required here and above since metadata varies for non-directory.
			my $p = $db->{$_} = {%$q,
					     owner => $db->{$_}{owner}};
			$p->{owner}{current} = $cp->{oid}, $p->{owner}{record}{$cp->{oid}} = $cp->{ts};
		}
	}
}
# merge two patch trees, the first one takes higher priority.
sub merge {
	my ($p, $q) = @_;
	for (keys %$q) {
		if (not $p->{$_}) {
			$p->{$_} = $q->{$_};
		} else {
			my ($t, $_t) = ($p->{$_}{mode} & S_IFMT, $q->{$_}{mode} & S_IFMT);
			if ($t == S_IFDIR xor $_t == S_IFDIR)	{ ... }
			elsif ($t == S_IFDIR)			{ merge($p->{$_}{c}, $q->{$_}{c}) }
		}
	}
}
# add path r from v to p.
sub grow {
	my ($p, $v, $r) = @_;
	my @d = split m|/|, $r;
	my $f = pop @d;
	for (@d) {
		$p->{$_} = {%{$v->{$_}},
			    c => {}} if not $p->{$_};
		$p = $p->{$_}{c}, $v = $v->{$_}{c};
	}
	$p->{$f} = $v->{$f};
}
sub rm {
	my ($cp, $vp) = @_;
	my $db = $vp->{db};
	for (keys %$db) {
		my ($r, $p, $o) = ($vp->{d} . $_, $db->{$_}, $db->{$_}{owner});
		my $f = $cp->{root} . $r;
		if ($p->{c}) {
			if ($o->{$cp->{oid}}) {
				rm($cp, {db => $p->{c},
					 d => $r . '/'});
				delete $o->{$cp->{oid}};
				if (not %$o) {
					rmdir $f or die "unable to rmdir $f: $!." if $cp->{hard};
					delete $db->{$_};
				}
			}
		} else {
			my $d = $o->{record};
			if (delete $d->{$cp->{oid}}) {
				if ($o->{current} eq $cp->{oid}) {
					unlink $f or warn "unable to unlink $f: $!." if $cp->{hard};
					if (%$d) {
						if ($cp->{hard}) {
							my $oid = reduce { $d->{$b} > $d->{$a} ? $b : $a } keys %$d;
							my $p = $cp->{patch}{$oid} ||= {v => rs_parse($cp->{pool} . $oid . '.rs'),
											p => {}};
							grow(@$p{qw/p v/}, $r);
						} else {
							# %$p{qw/owner mode/}.
							delete @$p{grep { !/owner|mode/ } keys %$p};
						}
					} else {
						delete $db->{$_};
					}
				}
			}
		}
	}
}
sub runas {
	my $u = shift;
	if ($u ne 'root') {
		my ($uid, $gid) = (getpwnam $u)[2, 3];
		($(, $)) = ($gid, "$gid $gid");
		($<, $>) = ($uid, $uid);
	} else {
		($<, $>) = (0, 0);
		($(, $)) = (0, '0 0');
	}
}
sub _crowded {
	{subr => sub {
		my $o = shift;
		if ($o->{event} eq 'ent') {
			my $db = $o->{db};
			$db->{c} ? 1 : keys %{$db->{owner}{record}} > 1;
		}
	 }, prophet => 0};
}
sub _tag {
	my $oid = shift;
	{subr => sub {
		my $o = shift;
		if ($o->{event} eq 'ent') {
			my $db = $o->{db};
			$db->{c} ? $db->{owner}{$oid} : $db->{owner}{record}{$oid};
		}
	 }, prophet => 1};
}
sub _list {
	my $v = {};
	{subr => sub {
		my $o = shift;
		if ($o->{event} eq 'ent') {
			my $db = $o->{db};
			add($v, $db->{c} ? %{$db->{owner}} : %{$db->{owner}{record}});
		} elsif ($o->{event} eq 'ret') {
			$v = [map { [$_, ''.localtime $v->{$_} ] } sort { $v->{$b} <=> $v->{$a} } keys %$v];
		}
	 }, prophet => 0};
}
sub filter {
	my ($cp, $vp) = @_;
	my ($v, $f, $db, $d) = ({}, $cp->{f}{subr}, @$vp{qw/db d/});
	say {$cp->{sink}} $d if $cp->{f}{prophet};
	for (sort keys %$db) {
		my ($p, $r) = ($db->{$_}, $d . $_);
		if ($f->({event => 'ent',
			  ent => $_,
			  db => $p})) {
			say {$cp->{sink}} $r unless $p->{c};
			if ($p->{c}) {
				my $c = filter($cp, {db => $p->{c},
						     d => $r . '/'});
				$v->{$_} = {%$p,
					    c => $c} if %$c or $cp->{f}{prophet};
			} else {
				$v->{$_} = $p;
			}
		}
	}
	$f->({event => 'ret'}) or $v;
}
sub confirm ($) {