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