view release on metacpan or  search on metacpan

bin/rs  view on Meta::CPAN

	  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) }
			    my $k = $r[0];
			    say c(YY, "Using $k->{name} for $o->{module}.");
			    my $v = $k->{version};
			    $j = {name => Nrev($o->{module}) . "-$v",
				  version => $v,
				  dependency => [{module => Nrev($k->{distribution}),
						  version => $v,
						  slice($o, qw/phase relationship/)}]};
			    $V = 1;
		    }
		    say "Latest version: $j->{version}.";
		    return if $A and $A->{version} eq $j->{version};
		    $q->{dependency}{$j->{version}} = [grep { depF($_) } @{$j->{dependency}}];
		    $B = {slice($j, qw/name version/)};
	    }
	    my $D = $q->{dependency}{$B->{version}};
	    _install($_) for @$D;
	    if ($A) {
		    remove($A->{name});
		    _uninstall({to => $_,
				from => $o->{module}}) for depdiff($q->{dependency}{$A->{version}},
								   $D);
	    }
	    if (-f(my $f = "$s->{pool}$B->{name}.rs")) {
		    say c(YY, "Reusing compiled package $f.");
		    patch($f);
	    } elsif (not $V) {
		    if (-f($f = "$s->{'compile-in'}/$j->{archive}")) {
			    say c(YY, "Reusing source archive $f.");
		    } else {
			    $j->{download_url} =~ s|(?<=^http)s(?=://)|| unless $s->{https};
			    say "Downloading $j->{download_url} @ $j->{date}...";
			    purl({method => 'GET',
				  url => $j->{download_url},
				  save => $f});
		    }
		    compile($f);
		    unshift @{$q->{available}}, $B;
	    }
	    $q->{current} = $B;
	    $refdb->{$_->{module}}{referent}{$o->{module}} = $_->{version} for @$D;
    }
    { my $l;
      sub _lib () {
	      my @p = split ':', $ENV{PERL5LIB} || '';
	      my $b = "$s->{prefix}/lib/perl5";
	      if (none { $b eq s|/$||r } @p) {
		      $ENV{PERL5LIB} = $l = join ':', @p, $b;
		      say 'PERL5LIB set to: ', c(YY, $l), '.';
	      }
      }
      sub install {
	      _RR;
	      _lib;
	      @$s{qw/cpan rm/} = (1, 1);