App-rs
view release on metacpan or search on metacpan
}
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 {
'post-make' => 'make test'};
} elsif (-f 'Build.PL') {
{'pre-configure' => "perl Build.PL",
'no-configure' => 1,
'post-configure' => './Build',
'no-make' => 1,
'post-make' => './Build test',
'no-make-install' => 1,
'post-make-install' => "./Build install --install_base=$s->{prefix}"};
} else {
die c(RR, 'Neither Makefile.PL nor Build.PL found.');
}
} else {
my ($b, $v) = (do $s->{build}, $pkg);
$b = $b->($s) if ref $b eq 'CODE';
$v = $b->{$v} until ref $v or not $v;
$v;
}
};
xsh({'feed-stdin' => 1}, $b->{'pre-configure'}, 'bash') or die 'pre-configure failed.' if $b->{'pre-configure'};
unless ($b->{'no-configure'}) {
local %ENV = %ENV;
xsh(0, qw/autoreconf -iv/) or die 'autoreconf failed.' unless -e 'configure';
my @p;
if ($s->{bootstrap}) {
$ENV{CPPFLAGS} = "-I$s->{prefix}/include" unless $b->{'no-cppflags'};
$ENV{LDFLAGS} = "-L$s->{prefix}/lib -Wl,-I" . linker($s);
}
push @p, "--prefix=$s->{prefix}";
my $e = $b->{environment};
$ENV{$_} = $e->{$_} for keys %$e;
xsh(0, './configure', @{$b->{switch}}, @p,
{to => *STDERR,
from => *STDOUT,
mode => '>'}, qw/| less --quit-on-intr --RAW-CONTROL-CHARS/) or die 'configure failed.';
}
xsh({'feed-stdin' => 1}, $b->{'post-configure'}, 'bash') or die 'post-configure failed.' if $b->{'post-configure'};
xsh(0, 'make', $s->{jobs} ? "--jobs=$s->{jobs}" : (), @{$b->{'make-parameter'}}) or die 'make failed.' unless $b->{'no-make'};
xsh({'feed-stdin' => 1}, $b->{'post-make'}, 'bash') or die 'post-make failed.' if $b->{'post-make'};
# since the following is installation process we need to switch back to root.
runas('root') if $root;
xsh(0, qw/make install/, @{$b->{'make-install-parameter'}}) or die 'make install failed.' unless $b->{'no-make-install'};
xsh({'feed-stdin' => 1}, $b->{'post-make-install'}, 'bash') or die 'post-make failed.' if $b->{'post-make-install'};
# do some cleaning.
unless ($s->{prepared} or $s->{'no-rm'}) {
my $cwd = getcwd();
xsh(0, qw/rm -rf/, "../$d") if $s->{rm} or confirm "'rm -rf ../$d' on $cwd";
}
# return to where we started.
chdir $o or die "chdir $o: $!.";
# the next steps.
diff($oid);
tag($oid) unless $s->{cpan};
}
sub _which {
my $r = shift;
if ($r =~ m{^/}) {
die c(RR, "Absolute path $r not prefixed by $s->{root}"), ".\n" unless 0 == index $r, $s->{root};
$r = substr $r, length $s->{root};
}
my ($d, @p) = (0, split m{/}, $r);
{subr => sub {
my $o = shift;
if ($o->{event} eq 'ent') {
my $u = $d >= @p || $o->{ent} eq $p[$d];
$d += 1 if $u and $o->{db}{c};
$u;
} elsif ($o->{event} eq 'ret') {
$d -= 1, 0;
}
}, prophet => 1};
}
for my $f (qw/tag crowded list which/) {
no strict 'refs';
*$f = sub {
my $pid;
local $SIG{PIPE} = 'IGNORE';
{ pipe my $r, my $w or die $!;
$pid = xsh({asynchronous => 1},
qw/less -R/, {to => *STDIN,
from => $r,
mode => '<'});
close $r;
print $w jw(filter({sink => $w,
f => &{$::{"_$f"}}}, {db => $db,
d => ''})) }
# we must wait here or we will lose control-terminal.
waitpid $pid, 0;
};
}
{ my $refdb;
sub _RR () { $refdb = -f $s->{refdb} ? jr(rf($s->{refdb})) : {} }
sub _RW () {
print c(YY, "Writing reference counting database $s->{refdb}", ': ');
wf($s->{refdb}, jw($refdb));
say c(GG, 'done'), '.';
}
sub _install {
my $o = shift;
print "Satisfying: ", jw($o);
my $q = $refdb->{$o->{module}} ||= {};
my ($A, $L) = ($q->{current},
$s->{latest});
if ($A) { return if not $L and vcmp($A->{version}, $o->{version}) >= 0 }
# no update on CORE module even when latest is required.
else { return if vsat(@$o{qw/module version/}) }
my ($t, $B, $j, $V) = first {
vcmp($_->{version}, $o->{version}) >= 0
} @{$q->{available} ||= []};
if (not $L and $t) {
$B = $t;
print "Available: ", jw($B);
} else {
say 'Getting module info from metacpan...';
$j = Rmodinfo($o->{module});
if (eval { $j->{code} == 404 }) {
$j = Vmodinfo($o->{module});
my @r = map { $_->{_source} } @{$j->{hits}{hits}};
if (@r < 1) { die c(RR, "Nothing provides $o->{module}.") }
elsif (@r > 1) { say c(YY, "Multiple modules provides $o->{module}: ",
join ', ', map { $_->{distribution} } @r) }
( run in 2.394 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )