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