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   $header = '';
 171  }
 172  $stat->header($header);
 173
 174  my $footer = delete $opts{footer};
 175  if (defined $footer) {
 176   $footer = "\n" . $footer;
 177  } else {
 178   $footer = '';
 179  }
 180  $stat->footer($footer);
 181
 182  my $overlay = delete $opts{overlay};
 183  $overlay = (defined $overlay) ? abs_path $overlay : '/usr/local/portage';
 184  $stat->overlay($overlay);
 185
 186  my $distdir = delete $opts{distdir};
 187  $distdir = (defined $distdir) ? abs_path $distdir : $default_distdir;
 188  $stat->distdir($distdir);
 189
 190  return $FAIL->("distdir isn't writable") if $stat->do_manifest && !-w $distdir;
 191
 192  $stat->fetched_arch($mod->status->fetch);
 193
 194  my $cur = File::Spec->curdir();
 195  my $portdir_overlay;
 196  for (@$overlays) {
 197   if ($_ eq $overlay or File::Spec->abs2rel($overlay, $_) eq $cur) {
 198    $portdir_overlay = [ @$overlays ];
 199    last;
 200   }
 201  }
 202  $portdir_overlay = [ @$overlays, $overlay ] unless $portdir_overlay;
 203  $stat->portdir_overlay($portdir_overlay);
 204
 205  my $name = $mod->package_name;
 206  $stat->name($name);
 207
 208  my $version = $mod->package_version;
 209  $stat->version($version);
 210
 211  my $author = $mod->author->cpanid;
 212  $stat->author($author);
 213
 214  $stat->distribution($name . '-' . $version);
 215
 216  $stat->ebuild_version(CPANPLUS::Dist::Gentoo::Maps::version_c2g($version));
 217
 218  $stat->ebuild_name(CPANPLUS::Dist::Gentoo::Maps::name_c2g($name));
 219
 220  $stat->ebuild_dir(File::Spec->catdir(
 221   $stat->overlay,
 222   CATEGORY,
 223   $stat->ebuild_name,
 224  ));
 225
 226  my $file = File::Spec->catfile(
 227   $stat->ebuild_dir,
 228   $stat->ebuild_name . '-' . $stat->ebuild_version . '.ebuild',
 229  );
 230  $stat->ebuild_file($file);
 231
 232  if ($stat->force) {
 233   # Always generate an ebuild in our category when forcing
 234   if ($forced{$file}) {
 235    $stat->dist($file);
 236    return $SKIP->('Ebuild already forced for', $stat->distribution);
 237   }
 238   ++$forced{$file};
 239   if (-e $file) {
 240    unless (-w $file) {
 241     $stat->dist($file);
 242     return $SKIP->("Can't force rewriting of $file");
 243    }
 244    1 while unlink $file;
 245   }
 246  } else {
 247   if (my @match = $self->_cpan2portage($name, $version)) {
 248    $stat->dist($match[1]);
 249    return $SKIP->('Ebuild already generated for', $stat->distribution);
 250   }
 251  }
 252
 253  $stat->prepared(0);
 254
 255  $self->SUPER::prepare(%opts);
 256
 257  return $FAIL->() unless $stat->prepared;
 258
 259  my $desc = $mod->description;
 260  ($desc = $name) =~ s/-+/::/g unless $desc;
 261  $stat->desc($desc);
 262
 263  $stat->uri('http://search.cpan.org/dist/' . $name);
 264
 265  $author =~ /^(.)(.)/ or return $FAIL->('Wrong author name');
 266  $stat->src("mirror://cpan/modules/by-authors/id/$1/$1$2/$author/" . $mod->package);
 267
 268  $stat->license($self->intuit_license);
 269
 270  my $prereqs = $mod->status->prereqs;
 271  my @depends;
 272  for my $prereq (sort keys %$prereqs) {
 273   next if $prereq =~ /^perl(?:-|\z)/;
 274   my $obj = $int->module_tree($prereq);
 275   next unless $obj; # Not in the module tree (e.g. Config)
 276   next if $obj->package_is_perl_core;
 277   {
 278    my $version;
 279    if ($prereqs->{$prereq}) {
 280     if ($obj->installed_version && $obj->installed_version < $obj->version) {
 281      $version = $obj->installed_version;
 282     } else {
 283      $version = $obj->package_version;
 284     }
 285    }
 286    push @depends, [ $obj->package_name, $version ];
 287   }
 288  }
 289  $stat->deps(\@depends);
 290
 291  return $OK->();
 292 }
 293
 294 =head2 C<intuit_license>
 295
 296 Returns an array reference to a list of Gentoo licences identifiers under which the current distribution is released.
 297
 298 =cut
 299
 300 my %dslip_license = (
 301  p => 'perl',
 302  g => 'gpl',
 303  l => 'lgpl',
 304  b => 'bsd',
 305  a => 'artistic',
 306  2 => 'artistic_2',
 307 );
 308
 309 sub intuit_license {
 310  my $self = shift;
 311  my $mod  = $self->parent;
 312
 313  my $dslip = $mod->dslip;
 314  if (defined $dslip and $dslip =~ /\S{4}(\S)/) {
 315   my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($dslip_license{$1});
 316   return \@licenses if @licenses;
 317  }
 318
 319  my $extract_dir = $mod->status->extract;
 320
 321  for my $meta_file (qw/META.json META.yml/) {
 322   my $meta = eval {
 323    Parse::CPAN::Meta::LoadFile(File::Spec->catdir(
 324     $extract_dir,
 325     $meta_file,
 326    ));
 327   } or next;
 328   my $license = $meta->{license};
 329   if (defined $license) {
 330    my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($license);
 331    return \@licenses if @licenses;
 332   }
 333  }
 334
 335  return [ CPANPLUS::Dist::Gentoo::Maps::license_c2g('perl') ];
 336 }
 337
 338 sub create {
 339  my $self = shift;
 340  my $stat = $self->status;
 341
 342  my $file;
 343
 344  my $OK   = sub {
 345   $stat->created(1);
 346   $stat->dist($file) if defined $file;
 347   1;
 348  };
 349
 350  my $FAIL = sub {
 351   $stat->created(0);
 352   $stat->dist(undef);
 353   $self->_abort(@_) if @_;
 354   if (defined $file and -f $file) {
 355    1 while unlink $file;
 356   }
 357   0;
 358  };
 359
 360  unless ($stat->prepared) {
 361   return $FAIL->(
 362    'Can\'t create', $stat->distribution, 'since it was never prepared'
 363   );
 364  }
 365
 366  if ($stat->created) {
 367   $self->_skip($stat->distribution, 'was already created');
 368   $file = $stat->dist; # Keep the existing one.
 369   return $OK->();
 370  }
 371
 372  my $dir = $stat->ebuild_dir;
 373  unless (-d $dir) {
 374   eval { File::Path::mkpath($dir) };
 375   return $FAIL->("mkpath($dir): $@") if $@;
 376  }
 377
 378  $file = $stat->ebuild_file;
 379
 380  # Create a placeholder ebuild to prevent recursion with circular dependencies.
 381  {
 382   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 383   print $eb "PLACEHOLDER\n";
 384  }
 385
 386  $stat->created(0);
 387  $stat->dist(undef);
 388
 389  $self->SUPER::create(@_);
 390
 391  return $FAIL->() unless $stat->created;
 392
 393  {
 394   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 395   my $source = $self->ebuild_source;
 396   return $FAIL->() unless defined $source;
 397   print $eb $source;
 398  }
 399
 400  return $FAIL->() if $stat->do_manifest and not $self->update_manifest;
 401
 402  return $OK->();
 403 }
 404
 405 =head2 C<update_manifest>
 406
 407 Updates the F<Manifest> file for the ebuild associated to the current dist object.
 408
 409 =cut
 410
 411 sub update_manifest {
 412  my $self = shift;
 413  my $stat = $self->status;
 414
 415  my $file = $stat->ebuild_file;
 416  unless ($file and -e $file) {
 417   return $self->_abort('The ebuild file is invalid or does not exist');
 418  }
 419
 420  unless (File::Copy::copy($stat->fetched_arch => $stat->distdir)) {
 421   return $self->_abort("Couldn\'t copy the distribution file to distdir ($!)");
 422  }
 423
 424  $self->_notify('Adding Manifest entry for', $stat->distribution);
 425
 426  return $self->_run([ 'ebuild', $stat->ebuild_file, 'manifest' ], 0);
 427 }
 428
 429 =head2 C<ebuild_source>
 430
 431 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.
 432
 433 =cut
 434
 435 sub ebuild_source {
 436  my $self = shift;
 437  my $stat = $self->status;
 438
 439  # We must resolve the deps now and not inside prepare because _cpan2portage
 440  # has to see the ebuilds already generated for the dependencies of the current
 441  # dist.
 442  my @deps;
 443  for (@{$stat->deps}) {
 444   my $dep = $self->_cpan2portage(@$_);
 445   unless (defined $dep) {
 446    $self->_abort(
 447     "Couldn't find an appropriate ebuild for $_->[0] in the portage tree"
 448    );
 449    return;
 450   }
 451   push @deps, $dep;
 452  }
 453
 454  @deps = do { my %seen; sort grep !$seen{$_}++, 'dev-lang/perl', @deps };
 455
 456  my $d = $stat->header;
 457  $d   .= "# Generated by CPANPLUS::Dist::Gentoo version $VERSION\n\n";
 458  $d   .= 'MODULE_AUTHOR="' . $stat->author . "\"\ninherit perl-module\n\n";
 459  $d   .= 'S="${WORKDIR}/' . $stat->distribution . "\"\n";
 460  $d   .= 'DESCRIPTION="' . $stat->desc . "\"\n";
 461  $d   .= 'HOMEPAGE="' . $stat->uri . "\"\n";
 462  $d   .= 'SRC_URI="' . $stat->src . "\"\n";
 463  $d   .= "SLOT=\"0\"\n";
 464  $d   .= 'LICENSE="|| ( ' . join(' ', sort @{$stat->license}) . " )\"\n";
 465  $d   .= 'KEYWORDS="' . join(' ', sort @{$stat->keywords}) . "\"\n";
 466  $d   .= 'DEPEND="' . join("\n", @deps) . "\"\n";
 467  $d   .= "SRC_TEST=\"do\"\n";
 468  $d   .= $stat->footer;
 469
 470  return $d;
 471 }
 472
 473 sub _cpan2portage {
 474  my ($self, $name, $version) = @_;
 475
 476  $name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($name);
 477  my $ver;
 478  $ver = CPANPLUS::Dist::Gentoo::Maps::version_c2g($version) if defined $version;
 479
 480  my @portdirs = ($main_portdir, @{$self->status->portdir_overlay});
 481
 482  for my $category (qw/virtual perl-core dev-perl perl-gcpan/, CATEGORY) {
 483   my $atom = ($category eq 'virtual' ? 'perl-' : '') . $name;
 484
 485   for my $portdir (@portdirs) {
 486    my @ebuilds = glob File::Spec->catfile(
 487     $portdir,
 488     $category,
 489     $atom,
 490     "$atom-*.ebuild",
 491    ) or next;
 492
 493    my $last = reduce {
 494     CPANPLUS::Dist::Gentoo::Maps::version_gcmp($b->[1], $a->[1]) >= 0 ? $b : $a
 495    } map [ $_, /\Q$atom\E-v?([\d._pr-]+).*?\.ebuild$/ ? $1 : 0 ], @ebuilds;
 496
 497    my $dep;
 498    if (defined $ver) { # implies that $version is defined
 499     next unless
 500               CPANPLUS::Dist::Gentoo::Maps::version_gcmp($last->[1], $ver) >= 0;
 501     $dep = ">=$category/$atom-$ver";
 502    } else {
 503     $dep = "$category/$atom";
 504    }
 505
 506    return wantarray ? ($dep, $last->[0]) : $dep;
 507   }
 508
 509  }
 510
 511  return;
 512 }
 513
 514 sub install {
 515  my $self = shift;
 516  my $stat = $self->status;
 517  my $conf = $self->parent->parent->configure_object;
 518
 519  my $sudo = $conf->get_program('sudo');
 520  my @cmd = ('emerge', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 521  unshift @cmd, $sudo if $sudo;
 522
 523  my $success = $self->_run(\@cmd, 1);
 524  $stat->installed($success);
 525
 526  return $success;
 527 }
 528
 529 sub uninstall {
 530  my $self = shift;
 531  my $stat = $self->status;
 532  my $conf = $self->parent->parent->configure_object;
 533
 534  my $sudo = $conf->get_program('sudo');
 535  my @cmd = ('emerge', '-C', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 536  unshift @cmd, $sudo if $sudo;
 537
 538  my $success = $self->_run(\@cmd, 1);
 539  $stat->uninstalled($success);
 540
 541  return $success;
 542 }
 543
 544 sub _run {
 545  my ($self, $cmd, $verbose) = @_;
 546  my $stat = $self->status;
 547
 548  my ($success, $errmsg, $output) = do {
 549   local $ENV{PORTDIR_OVERLAY}     = join ' ', @{$stat->portdir_overlay};
 550   local $ENV{PORTAGE_RO_DISTDIRS} = $stat->distdir;
 551   run command => $cmd, verbose => $verbose;
 552  };
 553
 554  unless ($success) {
 555   $self->_abort($errmsg);
 556   if (not $verbose and defined $output and $stat->verbose) {
 557    my $msg = join '', @$output;
 558    1 while chomp $msg;
 559    CPANPLUS::Error::error($msg);
 560   }
 561  }
 562
 563  return $success;
 564 }
 565
 566 sub _abort {
 567  my $self = shift;
 568
 569  CPANPLUS::Error::error("@_ -- aborting");
 570
 571  return 0;
 572 }
 573
 574 sub _notify {
 575  my $self = shift;
 576
 577  CPANPLUS::Error::msg("@_");
 578
 579  return 1;
 580 }
 581
 582 sub _skip { shift->_notify(@_, '-- skipping') }
 583
 584 =head1 DEPENDENCIES
 585
 586 Gentoo (L<http://gentoo.org>).
 587
 588 L<CPANPLUS>, L<IPC::Cmd> (core modules since 5.9.5), L<Parse::CPAN::Meta> (since 5.10.1).
 589
 590 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).
 591
 592 =head1 SEE ALSO
 593
 594 L<cpan2dist>.
 595
 596 L<CPANPLUS::Dist::Base>, L<CPANPLUS::Dist::Deb>, L<CPANPLUS::Dist::Mdv>.
 597
 598 =head1 AUTHOR
 599
 600 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 601
 602 You can contact me by mail or on C<irc.perl.org> (vincent).
 603
 604 =head1 BUGS
 605
 606 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>.
 607 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 608
 609 =head1 SUPPORT
 610
 611 You can find documentation for this module with the perldoc command.
 612
 613     perldoc CPANPLUS::Dist::Gentoo
 614
 615 =head1 ACKNOWLEDGEMENTS
 616
 617 The module was inspired by L<CPANPLUS::Dist::Deb> and L<CPANPLUS::Dist::Mdv>.
 618
 619 Kent Fredric, for testing and suggesting improvements.
 620
 621 =head1 COPYRIGHT & LICENSE
 622
 623 Copyright 2008-2009 Vincent Pit, all rights reserved.
 624
 625 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 626
 627 =cut
 628
 629 1; # End of CPANPLUS::Dist::Gentoo