lib/CPANPLUS/Dist/Gentoo.pm

   1 package CPANPLUS::Dist::Gentoo;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Cwd qw/abs_path/;
   7 use List::Util qw/reduce/;
   8 use File::Copy ();
   9 use File::Path ();
  10 use File::Spec;
  11
  12 use IPC::Cmd qw/run can_run/;
  13 use Parse::CPAN::Meta ();
  14
  15 use CPANPLUS::Error ();
  16
  17 use base qw/CPANPLUS::Dist::Base/;
  18
  19 use CPANPLUS::Dist::Gentoo::Maps;
  20
  21 =head1 NAME
  22
  23 CPANPLUS::Dist::Gentoo - CPANPLUS backend generating Gentoo ebuilds.
  24
  25 =head1 VERSION
  26
  27 Version 0.08
  28
  29 =cut
  30
  31 our $VERSION = '0.08';
  32
  33 =head1 SYNOPSIS
  34
  35     cpan2dist --format=CPANPLUS::Dist::Gentoo \
  36               --dist-opts overlay=/usr/local/portage \
  37               --dist-opts distdir=/usr/portage/distfiles \
  38               --dist-opts manifest=yes \
  39               --dist-opts keywords=x86 \
  40               --dist-opts header="# Copyright 1999-2008 Gentoo Foundation" \
  41               --dist-opts footer="# End" \
  42               Any::Module You::Like
  43
  44 =head1 DESCRPITON
  45
  46 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.
  47 You need write permissions on the directory where Gentoo fetches its source files (usually F</usr/portage/distfiles>).
  48 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.
  49
  50 The generated ebuilds are placed into the C<perl-gcpanp> category.
  51 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>.
  52
  53 =head1 INSTALLATION
  54
  55 After installing this module, you should append C<perl-gcpanp> to your F</etc/portage/categories> file.
  56
  57 =head1 METHODS
  58
  59 This module inherits all the methods from L<CPANPLUS::Dist::Base>.
  60 Please refer to its documentation for precise information on what's done at each step.
  61
  62 =cut
  63
  64 use constant CATEGORY => 'perl-gcpanp';
  65
  66 my $overlays;
  67 my $default_keywords;
  68 my $default_distdir;
  69 my $main_portdir;
  70
  71 my %forced;
  72
  73 my $unquote = sub {
  74  my $s = shift;
  75  $s =~ s/^["']*//;
  76  $s =~ s/["']*$//;
  77  return $s;
  78 };
  79
  80 my $format_available;
  81
  82 sub format_available {
  83  return $format_available if defined $format_available;
  84
  85  for my $prog (qw/emerge ebuild/) {
  86   unless (can_run($prog)) {
  87    __PACKAGE__->_abort("$prog is required to write ebuilds");
  88    return $format_available = 0;
  89   }
  90  }
  91
  92  if (IPC::Cmd->can_capture_buffer) {
  93   my $buffers;
  94   my ($success, $errmsg) = run command => [ qw/emerge --info/ ],
  95                                verbose => 0,
  96                                buffer  => \$buffers;
  97   if ($success) {
  98    if ($buffers =~ /^PORTDIR_OVERLAY=(.*)$/m) {
  99     $overlays = [ map abs_path($_), split ' ', $unquote->($1) ];
 100    }
 101    if ($buffers =~ /^ACCEPT_KEYWORDS=(.*)$/m) {
 102     $default_keywords = [ split ' ', $unquote->($1) ];
 103    }
 104    if ($buffers =~ /^DISTDIR=(.*)$/m) {
 105     $default_distdir = abs_path($unquote->($1));
 106    }
 107    if ($buffers =~ /^PORTDIR=(.*)$/m) {
 108     $main_portdir = abs_path($unquote->($1));
 109    }
 110   } else {
 111    __PACKAGE__->_abort($errmsg);
 112   }
 113  }
 114
 115  $default_keywords = [ 'x86' ] unless defined $default_keywords;
 116  $default_distdir  = '/usr/portage/distfiles' unless defined $default_distdir;
 117
 118  return $format_available = 1;
 119 }
 120
 121 sub init {
 122  my ($self) = @_;
 123  my $stat = $self->status;
 124  my $conf = $self->parent->parent->configure_object;
 125
 126  $stat->mk_accessors(qw/name version author distribution desc uri src license
 127                         fetched_arch deps
 128                         ebuild_name ebuild_version ebuild_dir ebuild_file
 129                         portdir_overlay
 130                         overlay distdir keywords do_manifest header footer
 131                         force verbose/);
 132
 133  $stat->force($conf->get_conf('force'));
 134  $stat->verbose($conf->get_conf('verbose'));
 135
 136  return 1;
 137 }
 138
 139 sub prepare {
 140  my $self = shift;
 141  my $mod  = $self->parent;
 142  my $stat = $self->status;
 143  my $int  = $mod->parent;
 144  my $conf = $int->configure_object;
 145
 146  my %opts = @_;
 147
 148  my $OK   = sub { $stat->prepared(1); 1 };
 149  my $FAIL = sub { $stat->prepared(0); $self->_abort(@_) if @_; 0 };
 150  my $SKIP = sub { $stat->prepared(1); $stat->created(1); $self->_skip(@_) if @_; 1 };
 151
 152  my $keywords = delete $opts{keywords};
 153  if (defined $keywords) {
 154   $keywords = [ split ' ', $keywords ];
 155  } else {
 156   $keywords = $default_keywords;
 157  }
 158  $stat->keywords($keywords);
 159
 160  my $manifest = delete $opts{manifest};
 161  $manifest = 1 unless defined $manifest;
 162  $manifest = 0 if $manifest =~ /^\s*no?\s*$/i;
 163  $stat->do_manifest($manifest);
 164
 165  my $header = delete $opts{header};
 166  if (defined $header) {
 167   1 while chomp $header;
 168   $header .= "\n\n";
 169  } else {
 170   my $year = (localtime)[5] + 1900;
 171   $header = <<"  DEF_HEADER";
 172 # Copyright 1999-$year Gentoo Foundation
 173 # Distributed under the terms of the GNU General Public License v2
 174 # \$Header: \$
 175   DEF_HEADER
 176  }
 177  $stat->header($header);
 178
 179  my $footer = delete $opts{footer};
 180  if (defined $footer) {
 181   $footer = "\n" . $footer;
 182  } else {
 183   $footer = '';
 184  }
 185  $stat->footer($footer);
 186
 187  my $overlay = delete $opts{overlay};
 188  $overlay = (defined $overlay) ? abs_path $overlay : '/usr/local/portage';
 189  $stat->overlay($overlay);
 190
 191  my $distdir = delete $opts{distdir};
 192  $distdir = (defined $distdir) ? abs_path $distdir : $default_distdir;
 193  $stat->distdir($distdir);
 194
 195  return $FAIL->("distdir isn't writable") if $stat->do_manifest && !-w $distdir;
 196
 197  $stat->fetched_arch($mod->status->fetch);
 198
 199  my $cur = File::Spec->curdir();
 200  my $portdir_overlay;
 201  for (@$overlays) {
 202   if ($_ eq $overlay or File::Spec->abs2rel($overlay, $_) eq $cur) {
 203    $portdir_overlay = [ @$overlays ];
 204    last;
 205   }
 206  }
 207  $portdir_overlay = [ @$overlays, $overlay ] unless $portdir_overlay;
 208  $stat->portdir_overlay($portdir_overlay);
 209
 210  my $name = $mod->package_name;
 211  $stat->name($name);
 212
 213  my $version = $mod->package_version;
 214  $stat->version($version);
 215
 216  my $author = $mod->author->cpanid;
 217  $stat->author($author);
 218
 219  $stat->distribution($name . '-' . $version);
 220
 221  $stat->ebuild_version(CPANPLUS::Dist::Gentoo::Maps::version_c2g($version));
 222
 223  $stat->ebuild_name(CPANPLUS::Dist::Gentoo::Maps::name_c2g($name));
 224
 225  $stat->ebuild_dir(File::Spec->catdir(
 226   $stat->overlay,
 227   CATEGORY,
 228   $stat->ebuild_name,
 229  ));
 230
 231  my $file = File::Spec->catfile(
 232   $stat->ebuild_dir,
 233   $stat->ebuild_name . '-' . $stat->ebuild_version . '.ebuild',
 234  );
 235  $stat->ebuild_file($file);
 236
 237  if ($stat->force) {
 238   # Always generate an ebuild in our category when forcing
 239   if ($forced{$file}) {
 240    $stat->dist($file);
 241    return $SKIP->('Ebuild already forced for', $stat->distribution);
 242   }
 243   ++$forced{$file};
 244   if (-e $file) {
 245    unless (-w $file) {
 246     $stat->dist($file);
 247     return $SKIP->("Can't force rewriting of $file");
 248    }
 249    1 while unlink $file;
 250   }
 251  } else {
 252   if (my @match = $self->_cpan2portage($name, $version)) {
 253    $stat->dist($match[1]);
 254    return $SKIP->('Ebuild already generated for', $stat->distribution);
 255   }
 256  }
 257
 258  $stat->prepared(0);
 259
 260  $self->SUPER::prepare(%opts);
 261
 262  return $FAIL->() unless $stat->prepared;
 263
 264  my $desc = $mod->description;
 265  ($desc = $name) =~ s/-+/::/g unless $desc;
 266  $stat->desc($desc);
 267
 268  $stat->uri('http://search.cpan.org/dist/' . $name);
 269
 270  $author =~ /^(.)(.)/ or return $FAIL->('Wrong author name');
 271  $stat->src("mirror://cpan/modules/by-authors/id/$1/$1$2/$author/" . $mod->package);
 272
 273  $stat->license($self->intuit_license);
 274
 275  my $prereqs = $mod->status->prereqs;
 276  my @depends;
 277  for my $prereq (sort keys %$prereqs) {
 278   next if $prereq =~ /^perl(?:-|\z)/;
 279   my $obj = $int->module_tree($prereq);
 280   next unless $obj; # Not in the module tree (e.g. Config)
 281   next if $obj->package_is_perl_core;
 282   {
 283    my $version;
 284    if ($prereqs->{$prereq}) {
 285     if ($obj->installed_version && $obj->installed_version < $obj->version) {
 286      $version = $obj->installed_version;
 287     } else {
 288      $version = $obj->package_version;
 289     }
 290    }
 291    push @depends, [ $obj->package_name, $version ];
 292   }
 293  }
 294  $stat->deps(\@depends);
 295
 296  return $OK->();
 297 }
 298
 299 =head2 C<intuit_license>
 300
 301 Returns an array reference to a list of Gentoo licences identifiers under which the current distribution is released.
 302
 303 =cut
 304
 305 my %dslip_license = (
 306  p => 'perl',
 307  g => 'gpl',
 308  l => 'lgpl',
 309  b => 'bsd',
 310  a => 'artistic',
 311  2 => 'artistic_2',
 312 );
 313
 314 sub intuit_license {
 315  my $self = shift;
 316  my $mod  = $self->parent;
 317
 318  my $dslip = $mod->dslip;
 319  if (defined $dslip and $dslip =~ /\S{4}(\S)/) {
 320   my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($dslip_license{$1});
 321   return \@licenses if @licenses;
 322  }
 323
 324  my $extract_dir = $mod->status->extract;
 325
 326  for my $meta_file (qw/META.json META.yml/) {
 327   my $meta = eval {
 328    Parse::CPAN::Meta::LoadFile(File::Spec->catdir(
 329     $extract_dir,
 330     $meta_file,
 331    ));
 332   } or next;
 333   my $license = $meta->{license};
 334   if (defined $license) {
 335    my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($license);
 336    return \@licenses if @licenses;
 337   }
 338  }
 339
 340  return [ CPANPLUS::Dist::Gentoo::Maps::license_c2g('perl') ];
 341 }
 342
 343 sub create {
 344  my $self = shift;
 345  my $stat = $self->status;
 346
 347  my $file;
 348
 349  my $OK   = sub {
 350   $stat->created(1);
 351   $stat->dist($file) if defined $file;
 352   1;
 353  };
 354
 355  my $FAIL = sub {
 356   $stat->created(0);
 357   $stat->dist(undef);
 358   $self->_abort(@_) if @_;
 359   if (defined $file and -f $file) {
 360    1 while unlink $file;
 361   }
 362   0;
 363  };
 364
 365  unless ($stat->prepared) {
 366   return $FAIL->(
 367    'Can\'t create', $stat->distribution, 'since it was never prepared'
 368   );
 369  }
 370
 371  if ($stat->created) {
 372   $self->_skip($stat->distribution, 'was already created');
 373   $file = $stat->dist; # Keep the existing one.
 374   return $OK->();
 375  }
 376
 377  my $dir = $stat->ebuild_dir;
 378  unless (-d $dir) {
 379   eval { File::Path::mkpath($dir) };
 380   return $FAIL->("mkpath($dir): $@") if $@;
 381  }
 382
 383  $file = $stat->ebuild_file;
 384
 385  # Create a placeholder ebuild to prevent recursion with circular dependencies.
 386  {
 387   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 388   print $eb "PLACEHOLDER\n";
 389  }
 390
 391  $stat->created(0);
 392  $stat->dist(undef);
 393
 394  $self->SUPER::create(@_);
 395
 396  return $FAIL->() unless $stat->created;
 397
 398  {
 399   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 400   my $source = $self->ebuild_source;
 401   return $FAIL->() unless defined $source;
 402   print $eb $source;
 403  }
 404
 405  return $FAIL->() if $stat->do_manifest and not $self->update_manifest;
 406
 407  return $OK->();
 408 }
 409
 410 =head2 C<update_manifest>
 411
 412 Updates the F<Manifest> file for the ebuild associated to the current dist object.
 413
 414 =cut
 415
 416 sub update_manifest {
 417  my $self = shift;
 418  my $stat = $self->status;
 419
 420  my $file = $stat->ebuild_file;
 421  unless (defined $file and -e $file) {
 422   return $self->_abort('The ebuild file is invalid or does not exist');
 423  }
 424
 425  unless (File::Copy::copy($stat->fetched_arch => $stat->distdir)) {
 426   return $self->_abort("Couldn\'t copy the distribution file to distdir ($!)");
 427  }
 428
 429  $self->_notify('Adding Manifest entry for', $stat->distribution);
 430
 431  return $self->_run([ 'ebuild', $file, 'manifest' ], 0);
 432 }
 433
 434 =head2 C<ebuild_source>
 435
 436 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.
 437
 438 =cut
 439
 440 sub ebuild_source {
 441  my $self = shift;
 442  my $stat = $self->status;
 443
 444  # We must resolve the deps now and not inside prepare because _cpan2portage
 445  # has to see the ebuilds already generated for the dependencies of the current
 446  # dist.
 447  my @deps;
 448  for (@{$stat->deps}) {
 449   my $dep = $self->_cpan2portage(@$_);
 450   unless (defined $dep) {
 451    $self->_abort(
 452     "Couldn't find an appropriate ebuild for $_->[0] in the portage tree"
 453    );
 454    return;
 455   }
 456   push @deps, $dep;
 457  }
 458
 459  @deps = do { my %seen; sort grep !$seen{$_}++, 'dev-lang/perl', @deps };
 460
 461  my $d = $stat->header;
 462  $d   .= "# Generated by CPANPLUS::Dist::Gentoo version $VERSION\n\n";
 463  $d   .= 'MODULE_AUTHOR="' . $stat->author . "\"\ninherit perl-module\n\n";
 464  $d   .= 'S="${WORKDIR}/' . $stat->distribution . "\"\n";
 465  $d   .= 'DESCRIPTION="' . $stat->desc . "\"\n";
 466  $d   .= 'HOMEPAGE="' . $stat->uri . "\"\n";
 467  $d   .= 'SRC_URI="' . $stat->src . "\"\n";
 468  $d   .= "SLOT=\"0\"\n";
 469  $d   .= 'LICENSE="|| ( ' . join(' ', sort @{$stat->license}) . " )\"\n";
 470  $d   .= 'KEYWORDS="' . join(' ', sort @{$stat->keywords}) . "\"\n";
 471  $d   .= 'RDEPEND="' . join("\n", @deps) . "\"\n";
 472  $d   .= "DEPEND=\"\${RDEPEND}\"\n";
 473  $d   .= "SRC_TEST=\"do\"\n";
 474  $d   .= $stat->footer;
 475
 476  return $d;
 477 }
 478
 479 sub _cpan2portage {
 480  my ($self, $name, $version) = @_;
 481
 482  $name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($name);
 483  my $ver;
 484  $ver = CPANPLUS::Dist::Gentoo::Maps::version_c2g($version) if defined $version;
 485
 486  my @portdirs = ($main_portdir, @{$self->status->portdir_overlay});
 487
 488  for my $category (qw/virtual perl-core dev-perl perl-gcpan/, CATEGORY) {
 489   my $atom = ($category eq 'virtual' ? 'perl-' : '') . $name;
 490
 491   for my $portdir (@portdirs) {
 492    my @ebuilds = glob File::Spec->catfile(
 493     $portdir,
 494     $category,
 495     $atom,
 496     "$atom-*.ebuild",
 497    ) or next;
 498
 499    my $last = reduce {
 500     CPANPLUS::Dist::Gentoo::Maps::version_gcmp($b->[1], $a->[1]) >= 0 ? $b : $a
 501    } map [ $_, /\Q$atom\E-v?([\d._pr-]+).*?\.ebuild$/ ? $1 : 0 ], @ebuilds;
 502
 503    my $dep;
 504    if (defined $ver) { # implies that $version is defined
 505     next unless
 506               CPANPLUS::Dist::Gentoo::Maps::version_gcmp($last->[1], $ver) >= 0;
 507     $dep = ">=$category/$atom-$ver";
 508    } else {
 509     $dep = "$category/$atom";
 510    }
 511
 512    return wantarray ? ($dep, $last->[0]) : $dep;
 513   }
 514
 515  }
 516
 517  return;
 518 }
 519
 520 sub install {
 521  my $self = shift;
 522  my $stat = $self->status;
 523  my $conf = $self->parent->parent->configure_object;
 524
 525  my $sudo = $conf->get_program('sudo');
 526  my @cmd = ('emerge', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 527  unshift @cmd, $sudo if $sudo;
 528
 529  my $success = $self->_run(\@cmd, 1);
 530  $stat->installed($success);
 531
 532  return $success;
 533 }
 534
 535 sub uninstall {
 536  my $self = shift;
 537  my $stat = $self->status;
 538  my $conf = $self->parent->parent->configure_object;
 539
 540  my $sudo = $conf->get_program('sudo');
 541  my @cmd = ('emerge', '-C', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 542  unshift @cmd, $sudo if $sudo;
 543
 544  my $success = $self->_run(\@cmd, 1);
 545  $stat->uninstalled($success);
 546
 547  return $success;
 548 }
 549
 550 sub _run {
 551  my ($self, $cmd, $verbose) = @_;
 552  my $stat = $self->status;
 553
 554  my ($success, $errmsg, $output) = do {
 555   local $ENV{PORTDIR_OVERLAY}     = join ' ', @{$stat->portdir_overlay};
 556   local $ENV{PORTAGE_RO_DISTDIRS} = $stat->distdir;
 557   run command => $cmd, verbose => $verbose;
 558  };
 559
 560  unless ($success) {
 561   $self->_abort($errmsg);
 562   if (not $verbose and defined $output and $stat->verbose) {
 563    my $msg = join '', @$output;
 564    1 while chomp $msg;
 565    CPANPLUS::Error::error($msg);
 566   }
 567  }
 568
 569  return $success;
 570 }
 571
 572 sub _abort {
 573  my $self = shift;
 574
 575  CPANPLUS::Error::error("@_ -- aborting");
 576
 577  return 0;
 578 }
 579
 580 sub _notify {
 581  my $self = shift;
 582
 583  CPANPLUS::Error::msg("@_");
 584
 585  return 1;
 586 }
 587
 588 sub _skip { shift->_notify(@_, '-- skipping') }
 589
 590 =head1 DEPENDENCIES
 591
 592 Gentoo (L<http://gentoo.org>).
 593
 594 L<CPANPLUS>, L<IPC::Cmd> (core modules since 5.9.5), L<Parse::CPAN::Meta> (since 5.10.1).
 595
 596 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).
 597
 598 =head1 SEE ALSO
 599
 600 L<cpan2dist>.
 601
 602 L<CPANPLUS::Dist::Base>, L<CPANPLUS::Dist::Deb>, L<CPANPLUS::Dist::Mdv>.
 603
 604 =head1 AUTHOR
 605
 606 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 607
 608 You can contact me by mail or on C<irc.perl.org> (vincent).
 609
 610 =head1 BUGS
 611
 612 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>.
 613 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 614
 615 =head1 SUPPORT
 616
 617 You can find documentation for this module with the perldoc command.
 618
 619     perldoc CPANPLUS::Dist::Gentoo
 620
 621 =head1 ACKNOWLEDGEMENTS
 622
 623 The module was inspired by L<CPANPLUS::Dist::Deb> and L<CPANPLUS::Dist::Mdv>.
 624
 625 Kent Fredric, for testing and suggesting improvements.
 626
 627 =head1 COPYRIGHT & LICENSE
 628
 629 Copyright 2008-2009 Vincent Pit, all rights reserved.
 630
 631 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 632
 633 =cut
 634
 635 1; # End of CPANPLUS::Dist::Gentoo