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 = $prereqs->{$prereq} || undef;
 222
 223   push @requires, [ $obj->package_name, $version ];
 224  }
 225
 226  return \@requires;
 227 };
 228
 229 sub prepare {
 230  my $self = shift;
 231  my $mod  = $self->parent;
 232  my $stat = $self->status;
 233  my $int  = $mod->parent;
 234  my $conf = $int->configure_object;
 235
 236  my %opts = @_;
 237
 238  my $OK   = sub { $stat->prepared(1); 1 };
 239  my $FAIL = sub { $stat->prepared(0); $self->_abort(@_) if @_; 0 };
 240  my $SKIP = sub { $stat->prepared(1); $stat->created(1); $self->_skip(@_) if @_; 1 };
 241
 242  my $keywords = delete $opts{keywords};
 243  if (defined $keywords) {
 244   $keywords = [ split ' ', $keywords ];
 245  } else {
 246   $keywords = $default_keywords;
 247  }
 248  $stat->keywords($keywords);
 249
 250  my $manifest = delete $opts{manifest};
 251  $manifest = 1 unless defined $manifest;
 252  $manifest = 0 if $manifest =~ /^\s*no?\s*$/i;
 253  $stat->do_manifest($manifest);
 254
 255  my $header = delete $opts{header};
 256  if (defined $header) {
 257   1 while chomp $header;
 258   $header .= "\n\n";
 259  } else {
 260   my $year = (localtime)[5] + 1900;
 261   $header = <<"  DEF_HEADER";
 262 # Copyright 1999-$year Gentoo Foundation
 263 # Distributed under the terms of the GNU General Public License v2
 264 # \$Header: \$
 265   DEF_HEADER
 266  }
 267  $stat->header($header);
 268
 269  my $footer = delete $opts{footer};
 270  if (defined $footer) {
 271   $footer = "\n" . $footer;
 272  } else {
 273   $footer = '';
 274  }
 275  $stat->footer($footer);
 276
 277  my $overlay = delete $opts{overlay};
 278  $overlay = (defined $overlay) ? Cwd::abs_path($overlay) : '/usr/local/portage';
 279  $stat->overlay($overlay);
 280
 281  my $distdir = delete $opts{distdir};
 282  $distdir = (defined $distdir) ? Cwd::abs_path($distdir) : $default_distdir;
 283  $stat->distdir($distdir);
 284
 285  return $FAIL->("distdir isn't writable") if $stat->do_manifest && !-w $distdir;
 286
 287  $stat->fetched_arch($mod->status->fetch);
 288
 289  my $cur = File::Spec->curdir();
 290  my $portdir_overlay;
 291  for (@$overlays) {
 292   if ($_ eq $overlay or File::Spec->abs2rel($overlay, $_) eq $cur) {
 293    $portdir_overlay = [ @$overlays ];
 294    last;
 295   }
 296  }
 297  $portdir_overlay = [ @$overlays, $overlay ] unless $portdir_overlay;
 298  $stat->portdir_overlay($portdir_overlay);
 299
 300  my $name = $mod->package_name;
 301  $stat->name($name);
 302
 303  my $version = $mod->package_version;
 304  $stat->version($version);
 305
 306  my $author = $mod->author->cpanid;
 307  $stat->author($author);
 308
 309  $stat->distribution($name . '-' . $version);
 310
 311  $stat->ebuild_version(CPANPLUS::Dist::Gentoo::Maps::version_c2g($name, $version));
 312
 313  $stat->ebuild_name(CPANPLUS::Dist::Gentoo::Maps::name_c2g($name));
 314
 315  $stat->ebuild_dir(File::Spec->catdir(
 316   $stat->overlay,
 317   CATEGORY,
 318   $stat->ebuild_name,
 319  ));
 320
 321  my $file = File::Spec->catfile(
 322   $stat->ebuild_dir,
 323   $stat->ebuild_name . '-' . $stat->ebuild_version . '.ebuild',
 324  );
 325  $stat->ebuild_file($file);
 326
 327  if ($stat->force) {
 328   # Always generate an ebuild in our category when forcing
 329   if ($forced{$file}) {
 330    $stat->dist($file);
 331    return $SKIP->('Ebuild already forced for', $stat->distribution);
 332   }
 333   ++$forced{$file};
 334   if (-e $file) {
 335    unless (-w $file) {
 336     $stat->dist($file);
 337     return $SKIP->("Can't force rewriting of $file");
 338    }
 339    1 while unlink $file;
 340   }
 341  } else {
 342   if (my $atom = $self->_cpan2portage($name, $version)) {
 343    $stat->dist($atom->ebuild);
 344    return $SKIP->('Ebuild already generated for', $stat->distribution);
 345   }
 346  }
 347
 348  $stat->prepared(0);
 349
 350  $self->SUPER::prepare(@_);
 351
 352  return $FAIL->() unless $stat->prepared;
 353
 354  my $desc = $mod->description;
 355  $desc    = $mod->comment                unless $desc;
 356  $desc    = "$name Perl distribution (provides " . $mod->module . ')'
 357                                          unless $desc;
 358  $desc    = substr($desc, 0, 77) . '...' if length $desc > 80;
 359  $stat->desc($desc);
 360
 361  $stat->uri('http://search.cpan.org/dist/' . $name);
 362
 363  $author =~ /^(.)(.)/ or return $FAIL->('Wrong author name');
 364  $stat->src("mirror://cpan/modules/by-authors/id/$1/$1$2/$author/" . $mod->package);
 365
 366  $stat->license($self->intuit_license);
 367
 368  my $mstat = $mod->status;
 369  $stat->configure_requires($int->$filter_prereqs($mstat->configure_requires));
 370  $stat->requires($int->$filter_prereqs($mstat->requires));
 371
 372  my $meta = $self->meta;
 373  $stat->min_perl(CPANPLUS::Dist::Gentoo::Maps::perl_version_c2g(
 374   $meta->{requires}->{perl},
 375  ));
 376
 377  return $OK->();
 378 }
 379
 380 =head2 C<meta>
 381
 382 Returns the contents of the F<META.yml> or F<META.json> files as parsed by L<Parse::CPAN::Meta>.
 383
 384 =cut
 385
 386 sub meta {
 387  my $self = shift;
 388  my $mod  = $self->parent;
 389  my $stat = $self->status;
 390
 391  my $meta = $stat->meta;
 392  return $meta if defined $meta;
 393
 394  my $extract_dir = $mod->status->extract;
 395
 396  for my $name (qw/META.json META.yml/) {
 397   my $meta_file = File::Spec->catdir($extract_dir, $name);
 398   next unless -e $meta_file;
 399
 400   local $@;
 401   my $meta = eval { Parse::CPAN::Meta::LoadFile($meta_file) };
 402   if (defined $meta) {
 403    $stat->meta($meta);
 404    return $meta;
 405   }
 406  }
 407
 408  return;
 409 }
 410
 411 =head2 C<intuit_license>
 412
 413 Returns an array reference to a list of Gentoo licences identifiers under which the current distribution is released.
 414
 415 =cut
 416
 417 my %dslip_license = (
 418  p => 'perl',
 419  g => 'gpl',
 420  l => 'lgpl',
 421  b => 'bsd',
 422  a => 'artistic',
 423  2 => 'artistic_2',
 424 );
 425
 426 sub intuit_license {
 427  my $self = shift;
 428  my $mod  = $self->parent;
 429
 430  my $dslip = $mod->dslip;
 431  if (defined $dslip and $dslip =~ /\S{4}(\S)/) {
 432   my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($dslip_license{$1});
 433   return \@licenses if @licenses;
 434  }
 435
 436  my $meta    = $self->meta;
 437  my $license = $meta->{license};
 438  if (defined $license) {
 439   my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($license);
 440   return \@licenses if @licenses;
 441  }
 442
 443  return [ CPANPLUS::Dist::Gentoo::Maps::license_c2g('perl') ];
 444 }
 445
 446 sub create {
 447  my $self = shift;
 448  my $stat = $self->status;
 449
 450  my $file;
 451
 452  my $guard = CPANPLUS::Dist::Gentoo::Guard->new(sub {
 453   if (defined $file and -e $file and -w _) {
 454    1 while unlink $file;
 455   }
 456  });
 457
 458  my $SIG_INT = $SIG{INT};
 459  local $SIG{INT} = sub {
 460   if ($SIG_INT) {
 461    local $@;
 462    eval { $SIG_INT->() };
 463    die $@ if $@;
 464   }
 465   die 'Caught SIGINT';
 466  };
 467
 468  my $OK   = sub {
 469   $guard->unarm;
 470   $stat->created(1);
 471   $stat->dist($file) if defined $file;
 472   1;
 473  };
 474
 475  my $FAIL = sub {
 476   $stat->created(0);
 477   $stat->dist(undef);
 478   $self->_abort(@_) if @_;
 479   0;
 480  };
 481
 482  unless ($stat->prepared) {
 483   return $FAIL->(
 484    'Can\'t create', $stat->distribution, 'since it was never prepared'
 485   );
 486  }
 487
 488  if ($stat->created) {
 489   $self->_skip($stat->distribution, 'was already created');
 490   $file = $stat->dist; # Keep the existing one.
 491   return $OK->();
 492  }
 493
 494  my $dir = $stat->ebuild_dir;
 495  unless (-d $dir) {
 496   eval { File::Path::mkpath($dir) };
 497   return $FAIL->("mkpath($dir): $@") if $@;
 498  }
 499
 500  $file = $stat->ebuild_file;
 501
 502  # Create a placeholder ebuild to prevent recursion with circular dependencies.
 503  {
 504   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 505   print $eb "PLACEHOLDER\n";
 506  }
 507
 508  $stat->created(0);
 509  $stat->dist(undef);
 510
 511  $self->SUPER::create(@_);
 512
 513  return $FAIL->() unless $stat->created;
 514
 515  {
 516   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 517   my $source = $self->ebuild_source;
 518   return $FAIL->() unless defined $source;
 519   print $eb $source;
 520  }
 521
 522  return $FAIL->() if $stat->do_manifest and not $self->update_manifest;
 523
 524  return $OK->();
 525 }
 526
 527 =head2 C<update_manifest>
 528
 529 Updates the F<Manifest> file for the ebuild associated to the current dist object.
 530
 531 =cut
 532
 533 sub update_manifest {
 534  my $self = shift;
 535  my $stat = $self->status;
 536
 537  my $file = $stat->ebuild_file;
 538  unless (defined $file and -e $file) {
 539   return $self->_abort('The ebuild file is invalid or does not exist');
 540  }
 541
 542  unless (File::Copy::copy($stat->fetched_arch => $stat->distdir)) {
 543   return $self->_abort("Couldn\'t copy the distribution file to distdir ($!)");
 544  }
 545
 546  $self->_notify('Adding Manifest entry for', $stat->distribution);
 547
 548  return $self->_run([ 'ebuild', $file, 'manifest' ], 0);
 549 }
 550
 551 =head2 C<ebuild_source>
 552
 553 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.
 554
 555 =cut
 556
 557 sub ebuild_source {
 558  my $self = shift;
 559  my $stat = $self->status;
 560
 561  # We must resolve the deps now and not inside prepare because _cpan2portage
 562  # has to see the ebuilds already generated for the dependencies of the current
 563  # dist.
 564
 565  my (@configure_requires, @requires);
 566
 567  my @phases = (
 568   [ configure_requires => \@configure_requires ],
 569   [ requires           => \@requires           ],
 570  );
 571
 572  push @requires, CPANPLUS::Dist::Gentoo::Atom->new(
 573   category => 'dev-lang',
 574   name     => 'perl',
 575   version  => $stat->min_perl,
 576  );
 577
 578  for (@phases) {
 579   my ($phase, $list) = @$_;
 580
 581   for (@{ $stat->$phase }) {
 582    my $atom = $self->_cpan2portage(@$_);
 583    unless (defined $atom) {
 584     $self->_abort(
 585      "Couldn't find an appropriate ebuild for $_->[0] in the portage tree"
 586     );
 587     return;
 588    }
 589
 590    push @$list, $atom;
 591   }
 592
 593   @$list = CPANPLUS::Dist::Gentoo::Atom->fold(@$list);
 594  }
 595
 596  my $d = $stat->header;
 597  $d   .= "# Generated by CPANPLUS::Dist::Gentoo version $VERSION\n\n";
 598  $d   .= 'MODULE_AUTHOR="' . $stat->author . "\"\ninherit perl-module\n\n";
 599  $d   .= 'S="${WORKDIR}/' . $stat->distribution . "\"\n";
 600  $d   .= 'DESCRIPTION="' . $stat->desc . "\"\n";
 601  $d   .= 'HOMEPAGE="' . $stat->uri . "\"\n";
 602  $d   .= 'SRC_URI="' . $stat->src . "\"\n";
 603  $d   .= "SLOT=\"0\"\n";
 604  $d   .= 'LICENSE="|| ( ' . join(' ', sort @{$stat->license}) . " )\"\n";
 605  $d   .= 'KEYWORDS="' . join(' ', sort @{$stat->keywords}) . "\"\n";
 606  $d   .= 'RDEPEND="' . join("\n", sort @requires) . "\"\n";
 607  $d   .= 'DEPEND="' . join("\n", '${RDEPEND}', sort @configure_requires) . "\"\n";
 608  $d   .= "SRC_TEST=\"do\"\n";
 609  $d   .= $stat->footer;
 610
 611  return $d;
 612 }
 613
 614 sub _cpan2portage {
 615  my ($self, $dist_name, $dist_version) = @_;
 616
 617  my $name    = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name);
 618  my $version = CPANPLUS::Dist::Gentoo::Maps::version_c2g($dist_name, $dist_version);
 619
 620  my @portdirs = ($main_portdir, @{$self->status->portdir_overlay});
 621
 622  for my $category (qw/virtual perl-core dev-perl perl-gcpan/, CATEGORY) {
 623   my $name = ($category eq 'virtual' ? 'perl-' : '') . $name;
 624
 625   for my $portdir (@portdirs) {
 626    my @ebuilds = glob File::Spec->catfile(
 627     $portdir,
 628     $category,
 629     $name,
 630     "$name-*.ebuild",
 631    ) or next;
 632
 633    my $last = reduce { $a < $b ? $b : $a } # handles overloading
 634                map CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($_),
 635                 @ebuilds;
 636    next if defined $version and $last < $version;
 637
 638    return CPANPLUS::Dist::Gentoo::Atom->new(
 639     category => $last->category,
 640     name     => $last->name,
 641     version  => $version,
 642     ebuild   => $last->ebuild,
 643    );
 644   }
 645
 646  }
 647
 648  return;
 649 }
 650
 651 sub install {
 652  my $self = shift;
 653  my $stat = $self->status;
 654  my $conf = $self->parent->parent->configure_object;
 655
 656  my $sudo = $conf->get_program('sudo');
 657  my @cmd = ('emerge', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 658  unshift @cmd, $sudo if $sudo;
 659
 660  my $success = $self->_run(\@cmd, 1);
 661  $stat->installed($success);
 662
 663  return $success;
 664 }
 665
 666 sub uninstall {
 667  my $self = shift;
 668  my $stat = $self->status;
 669  my $conf = $self->parent->parent->configure_object;
 670
 671  my $sudo = $conf->get_program('sudo');
 672  my @cmd = ('emerge', '-C', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 673  unshift @cmd, $sudo if $sudo;
 674
 675  my $success = $self->_run(\@cmd, 1);
 676  $stat->uninstalled($success);
 677
 678  return $success;
 679 }
 680
 681 sub _run {
 682  my ($self, $cmd, $verbose) = @_;
 683  my $stat = $self->status;
 684
 685  my ($success, $errmsg, $output) = do {
 686   local $ENV{PORTDIR_OVERLAY}     = join ' ', @{$stat->portdir_overlay};
 687   local $ENV{PORTAGE_RO_DISTDIRS} = $stat->distdir;
 688   IPC::Cmd::run(
 689    command => $cmd,
 690    verbose => $verbose,
 691   );
 692  };
 693
 694  unless ($success) {
 695   $self->_abort($errmsg);
 696   if (not $verbose and defined $output and $stat->verbose) {
 697    my $msg = join '', @$output;
 698    1 while chomp $msg;
 699    CPANPLUS::Error::error($msg);
 700   }
 701  }
 702
 703  return $success;
 704 }
 705
 706 sub _abort {
 707  my $self = shift;
 708
 709  CPANPLUS::Error::error("@_ -- aborting");
 710
 711  return 0;
 712 }
 713
 714 sub _notify {
 715  my $self = shift;
 716
 717  CPANPLUS::Error::msg("@_");
 718
 719  return 1;
 720 }
 721
 722 sub _skip { shift->_notify(@_, '-- skipping') }
 723
 724 =head1 DEPENDENCIES
 725
 726 Gentoo (L<http://gentoo.org>).
 727
 728 L<CPANPLUS>, L<IPC::Cmd> (core modules since 5.9.5), L<Parse::CPAN::Meta> (since 5.10.1).
 729
 730 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).
 731
 732 =head1 SEE ALSO
 733
 734 L<cpan2dist>.
 735
 736 L<CPANPLUS::Dist::Base>, L<CPANPLUS::Dist::Deb>, L<CPANPLUS::Dist::Mdv>.
 737
 738 =head1 AUTHOR
 739
 740 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 741
 742 You can contact me by mail or on C<irc.perl.org> (vincent).
 743
 744 =head1 BUGS
 745
 746 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>.
 747 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 748
 749 =head1 SUPPORT
 750
 751 You can find documentation for this module with the perldoc command.
 752
 753     perldoc CPANPLUS::Dist::Gentoo
 754
 755 =head1 ACKNOWLEDGEMENTS
 756
 757 The module was inspired by L<CPANPLUS::Dist::Deb> and L<CPANPLUS::Dist::Mdv>.
 758
 759 Kent Fredric, for testing and suggesting improvements.
 760
 761 =head1 COPYRIGHT & LICENSE
 762
 763 Copyright 2008,2009,2010 Vincent Pit, all rights reserved.
 764
 765 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 766
 767 =cut
 768
 769 1; # End of CPANPLUS::Dist::Gentoo