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