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