lib/CPANPLUS/Dist/Gentoo.pm

   1 package CPANPLUS::Dist::Gentoo;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Cwd        ();
   7 use List::Util qw/reduce/;
   8 use File::Copy ();
   9 use File::Path ();
  10 use File::Spec;
  11
  12 use IPC::Cmd          ();
  13 use Parse::CPAN::Meta ();
  14
  15 use CPANPLUS::Error ();
  16
  17 use base qw/CPANPLUS::Dist::Base/;
  18
  19 use CPANPLUS::Dist::Gentoo::Atom;
  20 use CPANPLUS::Dist::Gentoo::Guard;
  21 use CPANPLUS::Dist::Gentoo::Maps;
  22
  23 =head1 NAME
  24
  25 CPANPLUS::Dist::Gentoo - CPANPLUS backend generating Gentoo ebuilds.
  26
  27 =head1 VERSION
  28
  29 Version 0.10
  30
  31 =cut
  32
  33 our $VERSION = '0.10';
  34
  35 =head1 SYNOPSIS
  36
  37     cpan2dist --format=CPANPLUS::Dist::Gentoo \
  38               --dist-opts overlay=/usr/local/portage \
  39               --dist-opts distdir=/usr/portage/distfiles \
  40               --dist-opts manifest=yes \
  41               --dist-opts keywords=x86 \
  42               --dist-opts header="# Copyright 1999-2008 Gentoo Foundation" \
  43               --dist-opts footer="# End" \
  44               Any::Module You::Like
  45
  46 =head1 DESCRPITON
  47
  48 This module is a CPANPLUS backend that recursively generates Gentoo ebuilds for a given package in the specified overlay (defaults to F</usr/local/portage>), updates the manifest, and even emerges it (together with its dependencies) if the user requires it.
  49 You need write permissions on the directory where Gentoo fetches its source files (usually F</usr/portage/distfiles>).
  50 The valid C<KEYWORDS> for the generated ebuilds are by default those given in C<ACCEPT_KEYWORDS>, but you can specify your own with the C<keywords> dist-option.
  51
  52 The generated ebuilds are placed into the C<perl-gcpanp> category.
  53 They favour depending on a C<virtual>, on C<perl-core>, C<dev-perl> or C<perl-gcpan> (in that order) rather than C<perl-gcpanp>.
  54
  55 =head1 INSTALLATION
  56
  57 Before installing this module, you should append C<perl-gcpanp> to your F</etc/portage/categories> file.
  58
  59 You have two ways for installing this module :
  60
  61 =over 4
  62
  63 =item *
  64
  65 Use the perl overlay located at L<http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git>.
  66 It contains an ebuild for L<CPANPLUS::Dist::Gentoo>.
  67
  68 =item *
  69
  70 Bootstrap an ebuild for L<CPANPLUS::Dist::Gentoo> using itself.
  71 Note that if your Gentoo system C<perl> is C<5.8.x>, L<CPANPLUS> and its dependencies are not installed and not even available in the main portage tree.
  72 So you need to bootstrap them as well.
  73
  74 First, fetch tarballs for L<CPANPLUS> and L<CPANPLUS::Dist::Gentoo> :
  75
  76     $ cd /tmp
  77     $ wget http://search.cpan.org/CPAN/authors/id/B/BI/BINGOS/CPANPLUS-0.9003.tar.gz
  78     $ wget http://search.cpan.org/CPAN/authors/id/V/VP/VPIT/CPANPLUS-Dist-Gentoo-0.10.tar.gz
  79
  80 Log in as root and unpack them in e.g. your home directory :
  81
  82     # cd
  83     # tar xzf /tmp/CPANPLUS-0.9003.tar.gz
  84     # tar xzf /tmp/CPANPLUS-Dist-Gentoo-0.10.tar.gz
  85
  86 Set up environment variables so that the toolchain is temporarily available :
  87
  88     # export OLDPATH=$PATH
  89     # export PATH=/root/CPANPLUS-0.9003/bin:$PATH
  90     # export PERL5LIB=/root/CPANPLUS-Dist-Gentoo-0.10/blib/lib:/root/CPANPLUS-0.9003/lib:/root/CPANPLUS-0.9003/inc/bundle
  91
  92 Make sure you don't have an old C<.cpanplus> configuration visible :
  93
  94     # [ -d /root/.cpanplus ] && mv /root/.cpanplus{,.bak}
  95
  96 Bootstrap L<CPANPLUS> :
  97
  98     # cd /root/CPANPLUS-Dist-Gentoo-0.10
  99     # samples/g-cpanp CPANPLUS
 100
 101 Reset the environment :
 102
 103     # export PATH=$OLDPATH
 104     # unset PERL5LIB OLDPATH
 105
 106 Emerge L<CPANPLUS> with the ebuilds you've just generated :
 107
 108     # emerge -tv CPANPLUS
 109
 110 As of september 2009, C<podlators> and C<ExtUtils-MakeMaker> may fail to emerge due to collisions.
 111 You can work around this by disabling the C<protect-owned> C<FEATURE> for them :
 112
 113     # FEATURES="-protect-owned" emerge podlators
 114     # FEATURES="-protect-owned" emerge ExtUtils-MakeMaker
 115
 116 You may need to run each of these commands two times for them to succeed.
 117
 118 At this point, you can bootstrap L<CPANPLUS::Dist::Gentoo> using the system L<CPANPLUS> :
 119
 120     # PERL5LIB=/root/CPANPLUS-Dist-Gentoo-0.10/blib/lib samples/g-cpanp CPANPLUS::Dist::Gentoo
 121     # emerge -tv CPANPLUS-Dist-Gentoo
 122
 123 =back
 124
 125 =head1 METHODS
 126
 127 This module inherits all the methods from L<CPANPLUS::Dist::Base>.
 128 Please refer to its documentation for precise information on what's done at each step.
 129
 130 =cut
 131
 132 use constant CATEGORY => 'perl-gcpanp';
 133
 134 my $overlays;
 135 my $default_keywords;
 136 my $default_distdir;
 137 my $main_portdir;
 138
 139 my %forced;
 140
 141 my $unquote = sub {
 142  my $s = shift;
 143  $s =~ s/^["']*//;
 144  $s =~ s/["']*$//;
 145  return $s;
 146 };
 147
 148 my $format_available;
 149
 150 sub format_available {
 151  return $format_available if defined $format_available;
 152
 153  for my $prog (qw/emerge ebuild/) {
 154   unless (IPC::Cmd::can_run($prog)) {
 155    __PACKAGE__->_abort("$prog is required to write ebuilds");
 156    return $format_available = 0;
 157   }
 158  }
 159
 160  if (IPC::Cmd->can_capture_buffer) {
 161   my $buffers;
 162   my ($success, $errmsg) = IPC::Cmd::run(
 163    command => [ qw/emerge --info/ ],
 164    verbose => 0,
 165    buffer  => \$buffers,
 166   );
 167   if ($success) {
 168    if ($buffers =~ /^PORTDIR_OVERLAY=(.*)$/m) {
 169     $overlays = [ map Cwd::abs_path($_), split ' ', $unquote->($1) ];
 170    }
 171    if ($buffers =~ /^ACCEPT_KEYWORDS=(.*)$/m) {
 172     $default_keywords = [ split ' ', $unquote->($1) ];
 173    }
 174    if ($buffers =~ /^DISTDIR=(.*)$/m) {
 175     $default_distdir = Cwd::abs_path($unquote->($1));
 176    }
 177    if ($buffers =~ /^PORTDIR=(.*)$/m) {
 178     $main_portdir = Cwd::abs_path($unquote->($1));
 179    }
 180   } else {
 181    __PACKAGE__->_abort($errmsg);
 182   }
 183  }
 184
 185  $default_keywords = [ 'x86' ] unless defined $default_keywords;
 186  $default_distdir  = '/usr/portage/distfiles' unless defined $default_distdir;
 187
 188  return $format_available = 1;
 189 }
 190
 191 sub init {
 192  my ($self) = @_;
 193  my $stat = $self->status;
 194  my $conf = $self->parent->parent->configure_object;
 195
 196  $stat->mk_accessors(qw/name version author distribution desc uri src license
 197                         meta min_perl
 198                         fetched_arch requires configure_requires
 199                         ebuild_name ebuild_version ebuild_dir ebuild_file
 200                         portdir_overlay
 201                         overlay distdir keywords do_manifest header footer
 202                         force verbose/);
 203
 204  $stat->force($conf->get_conf('force'));
 205  $stat->verbose($conf->get_conf('verbose'));
 206
 207  return 1;
 208 }
 209
 210 my $filter_prereqs = sub {
 211  my ($int, $prereqs) = @_;
 212
 213  my @requires;
 214  for my $prereq (sort keys %$prereqs) {
 215   next if $prereq =~ /^perl(?:-|\z)/;
 216
 217   my $obj = $int->module_tree($prereq);
 218   next unless $obj; # Not in the module tree (e.g. Config)
 219   next if $obj->package_is_perl_core;
 220
 221   my $version;
 222   if ($prereqs->{$prereq}) {
 223    if ($obj->installed_version && $obj->installed_version < $obj->version) {
 224     $version = $obj->installed_version;
 225    } else {
 226     $version = $obj->package_version;
 227    }
 228   }
 229
 230   push @requires, [ $obj->package_name, $version ];
 231  }
 232
 233  return \@requires;
 234 };
 235
 236 sub prepare {
 237  my $self = shift;
 238  my $mod  = $self->parent;
 239  my $stat = $self->status;
 240  my $int  = $mod->parent;
 241  my $conf = $int->configure_object;
 242
 243  my %opts = @_;
 244
 245  my $OK   = sub { $stat->prepared(1); 1 };
 246  my $FAIL = sub { $stat->prepared(0); $self->_abort(@_) if @_; 0 };
 247  my $SKIP = sub { $stat->prepared(1); $stat->created(1); $self->_skip(@_) if @_; 1 };
 248
 249  my $keywords = delete $opts{keywords};
 250  if (defined $keywords) {
 251   $keywords = [ split ' ', $keywords ];
 252  } else {
 253   $keywords = $default_keywords;
 254  }
 255  $stat->keywords($keywords);
 256
 257  my $manifest = delete $opts{manifest};
 258  $manifest = 1 unless defined $manifest;
 259  $manifest = 0 if $manifest =~ /^\s*no?\s*$/i;
 260  $stat->do_manifest($manifest);
 261
 262  my $header = delete $opts{header};
 263  if (defined $header) {
 264   1 while chomp $header;
 265   $header .= "\n\n";
 266  } else {
 267   my $year = (localtime)[5] + 1900;
 268   $header = <<"  DEF_HEADER";
 269 # Copyright 1999-$year Gentoo Foundation
 270 # Distributed under the terms of the GNU General Public License v2
 271 # \$Header: \$
 272   DEF_HEADER
 273  }
 274  $stat->header($header);
 275
 276  my $footer = delete $opts{footer};
 277  if (defined $footer) {
 278   $footer = "\n" . $footer;
 279  } else {
 280   $footer = '';
 281  }
 282  $stat->footer($footer);
 283
 284  my $overlay = delete $opts{overlay};
 285  $overlay = (defined $overlay) ? Cwd::abs_path($overlay) : '/usr/local/portage';
 286  $stat->overlay($overlay);
 287
 288  my $distdir = delete $opts{distdir};
 289  $distdir = (defined $distdir) ? Cwd::abs_path($distdir) : $default_distdir;
 290  $stat->distdir($distdir);
 291
 292  return $FAIL->("distdir isn't writable") if $stat->do_manifest && !-w $distdir;
 293
 294  $stat->fetched_arch($mod->status->fetch);
 295
 296  my $cur = File::Spec->curdir();
 297  my $portdir_overlay;
 298  for (@$overlays) {
 299   if ($_ eq $overlay or File::Spec->abs2rel($overlay, $_) eq $cur) {
 300    $portdir_overlay = [ @$overlays ];
 301    last;
 302   }
 303  }
 304  $portdir_overlay = [ @$overlays, $overlay ] unless $portdir_overlay;
 305  $stat->portdir_overlay($portdir_overlay);
 306
 307  my $name = $mod->package_name;
 308  $stat->name($name);
 309
 310  my $version = $mod->package_version;
 311  $stat->version($version);
 312
 313  my $author = $mod->author->cpanid;
 314  $stat->author($author);
 315
 316  $stat->distribution($name . '-' . $version);
 317
 318  $stat->ebuild_version(CPANPLUS::Dist::Gentoo::Maps::version_c2g($name, $version));
 319
 320  $stat->ebuild_name(CPANPLUS::Dist::Gentoo::Maps::name_c2g($name));
 321
 322  $stat->ebuild_dir(File::Spec->catdir(
 323   $stat->overlay,
 324   CATEGORY,
 325   $stat->ebuild_name,
 326  ));
 327
 328  my $file = File::Spec->catfile(
 329   $stat->ebuild_dir,
 330   $stat->ebuild_name . '-' . $stat->ebuild_version . '.ebuild',
 331  );
 332  $stat->ebuild_file($file);
 333
 334  if ($stat->force) {
 335   # Always generate an ebuild in our category when forcing
 336   if ($forced{$file}) {
 337    $stat->dist($file);
 338    return $SKIP->('Ebuild already forced for', $stat->distribution);
 339   }
 340   ++$forced{$file};
 341   if (-e $file) {
 342    unless (-w $file) {
 343     $stat->dist($file);
 344     return $SKIP->("Can't force rewriting of $file");
 345    }
 346    1 while unlink $file;
 347   }
 348  } else {
 349   if (my $atom = $self->_cpan2portage($name, $version)) {
 350    $stat->dist($atom->ebuild);
 351    return $SKIP->('Ebuild already generated for', $stat->distribution);
 352   }
 353  }
 354
 355  $stat->prepared(0);
 356
 357  $self->SUPER::prepare(@_);
 358
 359  return $FAIL->() unless $stat->prepared;
 360
 361  my $desc = $mod->description;
 362  ($desc = $name) =~ s/-+/::/g unless $desc;
 363  $stat->desc($desc);
 364
 365  $stat->uri('http://search.cpan.org/dist/' . $name);
 366
 367  $author =~ /^(.)(.)/ or return $FAIL->('Wrong author name');
 368  $stat->src("mirror://cpan/modules/by-authors/id/$1/$1$2/$author/" . $mod->package);
 369
 370  $stat->license($self->intuit_license);
 371
 372  my $mstat = $mod->status;
 373  $stat->configure_requires($int->$filter_prereqs($mstat->configure_requires));
 374  $stat->requires($int->$filter_prereqs($mstat->requires));
 375
 376  my $meta = $self->meta;
 377  $stat->min_perl(CPANPLUS::Dist::Gentoo::Maps::perl_version_c2g(
 378   $meta->{requires}->{perl},
 379  ));
 380
 381  return $OK->();
 382 }
 383
 384 =head2 C<meta>
 385
 386 Returns the contents of the F<META.yml> or F<META.json> files as parsed by L<Parse::CPAN::Meta>.
 387
 388 =cut
 389
 390 sub meta {
 391  my $self = shift;
 392  my $mod  = $self->parent;
 393  my $stat = $self->status;
 394
 395  my $meta = $stat->meta;
 396  return $meta if defined $meta;
 397
 398  my $extract_dir = $mod->status->extract;
 399
 400  for my $name (qw/META.json META.yml/) {
 401   my $meta_file = File::Spec->catdir($extract_dir, $name);
 402   next unless -e $meta_file;
 403
 404   local $@;
 405   my $meta = eval { Parse::CPAN::Meta::LoadFile($meta_file) };
 406   if (defined $meta) {
 407    $stat->meta($meta);
 408    return $meta;
 409   }
 410  }
 411
 412  return;
 413 }
 414
 415 =head2 C<intuit_license>
 416
 417 Returns an array reference to a list of Gentoo licences identifiers under which the current distribution is released.
 418
 419 =cut
 420
 421 my %dslip_license = (
 422  p => 'perl',
 423  g => 'gpl',
 424  l => 'lgpl',
 425  b => 'bsd',
 426  a => 'artistic',
 427  2 => 'artistic_2',
 428 );
 429
 430 sub intuit_license {
 431  my $self = shift;
 432  my $mod  = $self->parent;
 433
 434  my $dslip = $mod->dslip;
 435  if (defined $dslip and $dslip =~ /\S{4}(\S)/) {
 436   my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($dslip_license{$1});
 437   return \@licenses if @licenses;
 438  }
 439
 440  my $meta    = $self->meta;
 441  my $license = $meta->{license};
 442  if (defined $license) {
 443   my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($license);
 444   return \@licenses if @licenses;
 445  }
 446
 447  return [ CPANPLUS::Dist::Gentoo::Maps::license_c2g('perl') ];
 448 }
 449
 450 sub create {
 451  my $self = shift;
 452  my $stat = $self->status;
 453
 454  my $file;
 455
 456  my $guard = CPANPLUS::Dist::Gentoo::Guard->new(sub {
 457   if (defined $file and -e $file and -w _) {
 458    1 while unlink $file;
 459   }
 460  });
 461
 462  my $SIG_INT = $SIG{INT};
 463  local $SIG{INT} = sub {
 464   if ($SIG_INT) {
 465    local $@;
 466    eval { $SIG_INT->() };
 467    die $@ if $@;
 468   }
 469   die 'Caught SIGINT';
 470  };
 471
 472  my $OK   = sub {
 473   $guard->unarm;
 474   $stat->created(1);
 475   $stat->dist($file) if defined $file;
 476   1;
 477  };
 478
 479  my $FAIL = sub {
 480   $stat->created(0);
 481   $stat->dist(undef);
 482   $self->_abort(@_) if @_;
 483   0;
 484  };
 485
 486  unless ($stat->prepared) {
 487   return $FAIL->(
 488    'Can\'t create', $stat->distribution, 'since it was never prepared'
 489   );
 490  }
 491
 492  if ($stat->created) {
 493   $self->_skip($stat->distribution, 'was already created');
 494   $file = $stat->dist; # Keep the existing one.
 495   return $OK->();
 496  }
 497
 498  my $dir = $stat->ebuild_dir;
 499  unless (-d $dir) {
 500   eval { File::Path::mkpath($dir) };
 501   return $FAIL->("mkpath($dir): $@") if $@;
 502  }
 503
 504  $file = $stat->ebuild_file;
 505
 506  # Create a placeholder ebuild to prevent recursion with circular dependencies.
 507  {
 508   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 509   print $eb "PLACEHOLDER\n";
 510  }
 511
 512  $stat->created(0);
 513  $stat->dist(undef);
 514
 515  $self->SUPER::create(@_);
 516
 517  return $FAIL->() unless $stat->created;
 518
 519  {
 520   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 521   my $source = $self->ebuild_source;
 522   return $FAIL->() unless defined $source;
 523   print $eb $source;
 524  }
 525
 526  return $FAIL->() if $stat->do_manifest and not $self->update_manifest;
 527
 528  return $OK->();
 529 }
 530
 531 =head2 C<update_manifest>
 532
 533 Updates the F<Manifest> file for the ebuild associated to the current dist object.
 534
 535 =cut
 536
 537 sub update_manifest {
 538  my $self = shift;
 539  my $stat = $self->status;
 540
 541  my $file = $stat->ebuild_file;
 542  unless (defined $file and -e $file) {
 543   return $self->_abort('The ebuild file is invalid or does not exist');
 544  }
 545
 546  unless (File::Copy::copy($stat->fetched_arch => $stat->distdir)) {
 547   return $self->_abort("Couldn\'t copy the distribution file to distdir ($!)");
 548  }
 549
 550  $self->_notify('Adding Manifest entry for', $stat->distribution);
 551
 552  return $self->_run([ 'ebuild', $file, 'manifest' ], 0);
 553 }
 554
 555 =head2 C<ebuild_source>
 556
 557 Returns the source of the ebuild for the current dist object, or C<undef> when one of the dependencies couldn't be mapped to an existing ebuild.
 558
 559 =cut
 560
 561 sub ebuild_source {
 562  my $self = shift;
 563  my $stat = $self->status;
 564
 565  # We must resolve the deps now and not inside prepare because _cpan2portage
 566  # has to see the ebuilds already generated for the dependencies of the current
 567  # dist.
 568
 569  my (@configure_requires, @requires);
 570
 571  my @phases = (
 572   [ configure_requires => \@configure_requires ],
 573   [ requires           => \@requires           ],
 574  );
 575
 576  push @requires, CPANPLUS::Dist::Gentoo::Atom->new(
 577   category => 'dev-lang',
 578   name     => 'perl',
 579   version  => $stat->min_perl,
 580  );
 581
 582  for (@phases) {
 583   my ($phase, $list) = @$_;
 584
 585   for (@{ $stat->$phase }) {
 586    my $atom = $self->_cpan2portage(@$_);
 587    unless (defined $atom) {
 588     $self->_abort(
 589      "Couldn't find an appropriate ebuild for $_->[0] in the portage tree"
 590     );
 591     return;
 592    }
 593
 594    push @$list, $atom;
 595   }
 596
 597   @$list = CPANPLUS::Dist::Gentoo::Atom->fold(@$list);
 598  }
 599
 600  my $d = $stat->header;
 601  $d   .= "# Generated by CPANPLUS::Dist::Gentoo version $VERSION\n\n";
 602  $d   .= 'MODULE_AUTHOR="' . $stat->author . "\"\ninherit perl-module\n\n";
 603  $d   .= 'S="${WORKDIR}/' . $stat->distribution . "\"\n";
 604  $d   .= 'DESCRIPTION="' . $stat->desc . "\"\n";
 605  $d   .= 'HOMEPAGE="' . $stat->uri . "\"\n";
 606  $d   .= 'SRC_URI="' . $stat->src . "\"\n";
 607  $d   .= "SLOT=\"0\"\n";
 608  $d   .= 'LICENSE="|| ( ' . join(' ', sort @{$stat->license}) . " )\"\n";
 609  $d   .= 'KEYWORDS="' . join(' ', sort @{$stat->keywords}) . "\"\n";
 610  $d   .= 'RDEPEND="' . join("\n", sort @requires) . "\"\n";
 611  $d   .= 'DEPEND="' . join("\n", '${RDEPEND}', sort @configure_requires) . "\"\n";
 612  $d   .= "SRC_TEST=\"do\"\n";
 613  $d   .= $stat->footer;
 614
 615  return $d;
 616 }
 617
 618 sub _cpan2portage {
 619  my ($self, $dist_name, $dist_version) = @_;
 620
 621  my $name    = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name);
 622  my $version = CPANPLUS::Dist::Gentoo::Maps::version_c2g($dist_name, $dist_version);
 623
 624  my @portdirs = ($main_portdir, @{$self->status->portdir_overlay});
 625
 626  for my $category (qw/virtual perl-core dev-perl perl-gcpan/, CATEGORY) {
 627   my $name = ($category eq 'virtual' ? 'perl-' : '') . $name;
 628
 629   for my $portdir (@portdirs) {
 630    my @ebuilds = glob File::Spec->catfile(
 631     $portdir,
 632     $category,
 633     $name,
 634     "$name-*.ebuild",
 635    ) or next;
 636
 637    my $last = reduce { $a < $b ? $b : $a } # handles overloading
 638                map CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($_),
 639                 @ebuilds;
 640    next if defined $version and $last < $version;
 641
 642    return CPANPLUS::Dist::Gentoo::Atom->new(
 643     category => $last->category,
 644     name     => $last->name,
 645     version  => $version,
 646     ebuild   => $last->ebuild,
 647    );
 648   }
 649
 650  }
 651
 652  return;
 653 }
 654
 655 sub install {
 656  my $self = shift;
 657  my $stat = $self->status;
 658  my $conf = $self->parent->parent->configure_object;
 659
 660  my $sudo = $conf->get_program('sudo');
 661  my @cmd = ('emerge', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 662  unshift @cmd, $sudo if $sudo;
 663
 664  my $success = $self->_run(\@cmd, 1);
 665  $stat->installed($success);
 666
 667  return $success;
 668 }
 669
 670 sub uninstall {
 671  my $self = shift;
 672  my $stat = $self->status;
 673  my $conf = $self->parent->parent->configure_object;
 674
 675  my $sudo = $conf->get_program('sudo');
 676  my @cmd = ('emerge', '-C', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 677  unshift @cmd, $sudo if $sudo;
 678
 679  my $success = $self->_run(\@cmd, 1);
 680  $stat->uninstalled($success);
 681
 682  return $success;
 683 }
 684
 685 sub _run {
 686  my ($self, $cmd, $verbose) = @_;
 687  my $stat = $self->status;
 688
 689  my ($success, $errmsg, $output) = do {
 690   local $ENV{PORTDIR_OVERLAY}     = join ' ', @{$stat->portdir_overlay};
 691   local $ENV{PORTAGE_RO_DISTDIRS} = $stat->distdir;
 692   IPC::Cmd::run(
 693    command => $cmd,
 694    verbose => $verbose,
 695   );
 696  };
 697
 698  unless ($success) {
 699   $self->_abort($errmsg);
 700   if (not $verbose and defined $output and $stat->verbose) {
 701    my $msg = join '', @$output;
 702    1 while chomp $msg;
 703    CPANPLUS::Error::error($msg);
 704   }
 705  }
 706
 707  return $success;
 708 }
 709
 710 sub _abort {
 711  my $self = shift;
 712
 713  CPANPLUS::Error::error("@_ -- aborting");
 714
 715  return 0;
 716 }
 717
 718 sub _notify {
 719  my $self = shift;
 720
 721  CPANPLUS::Error::msg("@_");
 722
 723  return 1;
 724 }
 725
 726 sub _skip { shift->_notify(@_, '-- skipping') }
 727
 728 =head1 DEPENDENCIES
 729
 730 Gentoo (L<http://gentoo.org>).
 731
 732 L<CPANPLUS>, L<IPC::Cmd> (core modules since 5.9.5), L<Parse::CPAN::Meta> (since 5.10.1).
 733
 734 L<Cwd>, L<Carp> (since perl 5), L<File::Path> (5.001), L<File::Copy> (5.002), L<File::Spec> (5.00405), L<List::Util> (5.007003).
 735
 736 =head1 SEE ALSO
 737
 738 L<cpan2dist>.
 739
 740 L<CPANPLUS::Dist::Base>, L<CPANPLUS::Dist::Deb>, L<CPANPLUS::Dist::Mdv>.
 741
 742 =head1 AUTHOR
 743
 744 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 745
 746 You can contact me by mail or on C<irc.perl.org> (vincent).
 747
 748 =head1 BUGS
 749
 750 Please report any bugs or feature requests to C<bug-cpanplus-dist-gentoo at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPANPLUS-Dist-Gentoo>.
 751 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 752
 753 =head1 SUPPORT
 754
 755 You can find documentation for this module with the perldoc command.
 756
 757     perldoc CPANPLUS::Dist::Gentoo
 758
 759 =head1 ACKNOWLEDGEMENTS
 760
 761 The module was inspired by L<CPANPLUS::Dist::Deb> and L<CPANPLUS::Dist::Mdv>.
 762
 763 Kent Fredric, for testing and suggesting improvements.
 764
 765 =head1 COPYRIGHT & LICENSE
 766
 767 Copyright 2008,2009,2010 Vincent Pit, all rights reserved.
 768
 769 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 770
 771 =cut
 772
 773 1; # End of CPANPLUS::Dist::Gentoo