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