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 (defined $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', $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   .= 'RDEPEND="' . join("\n", @deps) . "\"\n";
 467  $d   .= "DEPEND=\"\${RDEPEND}\"\n";
 468  $d   .= "SRC_TEST=\"do\"\n";
 469  $d   .= $stat->footer;
 470
 471  return $d;
 472 }
 473
 474 sub _cpan2portage {
 475  my ($self, $name, $version) = @_;
 476
 477  $name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($name);
 478  my $ver;
 479  $ver = CPANPLUS::Dist::Gentoo::Maps::version_c2g($version) if defined $version;
 480
 481  my @portdirs = ($main_portdir, @{$self->status->portdir_overlay});
 482
 483  for my $category (qw/virtual perl-core dev-perl perl-gcpan/, CATEGORY) {
 484   my $atom = ($category eq 'virtual' ? 'perl-' : '') . $name;
 485
 486   for my $portdir (@portdirs) {
 487    my @ebuilds = glob File::Spec->catfile(
 488     $portdir,
 489     $category,
 490     $atom,
 491     "$atom-*.ebuild",
 492    ) or next;
 493
 494    my $last = reduce {
 495     CPANPLUS::Dist::Gentoo::Maps::version_gcmp($b->[1], $a->[1]) >= 0 ? $b : $a
 496    } map [ $_, /\Q$atom\E-v?([\d._pr-]+).*?\.ebuild$/ ? $1 : 0 ], @ebuilds;
 497
 498    my $dep;
 499    if (defined $ver) { # implies that $version is defined
 500     next unless
 501               CPANPLUS::Dist::Gentoo::Maps::version_gcmp($last->[1], $ver) >= 0;
 502     $dep = ">=$category/$atom-$ver";
 503    } else {
 504     $dep = "$category/$atom";
 505    }
 506
 507    return wantarray ? ($dep, $last->[0]) : $dep;
 508   }
 509
 510  }
 511
 512  return;
 513 }
 514
 515 sub install {
 516  my $self = shift;
 517  my $stat = $self->status;
 518  my $conf = $self->parent->parent->configure_object;
 519
 520  my $sudo = $conf->get_program('sudo');
 521  my @cmd = ('emerge', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 522  unshift @cmd, $sudo if $sudo;
 523
 524  my $success = $self->_run(\@cmd, 1);
 525  $stat->installed($success);
 526
 527  return $success;
 528 }
 529
 530 sub uninstall {
 531  my $self = shift;
 532  my $stat = $self->status;
 533  my $conf = $self->parent->parent->configure_object;
 534
 535  my $sudo = $conf->get_program('sudo');
 536  my @cmd = ('emerge', '-C', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 537  unshift @cmd, $sudo if $sudo;
 538
 539  my $success = $self->_run(\@cmd, 1);
 540  $stat->uninstalled($success);
 541
 542  return $success;
 543 }
 544
 545 sub _run {
 546  my ($self, $cmd, $verbose) = @_;
 547  my $stat = $self->status;
 548
 549  my ($success, $errmsg, $output) = do {
 550   local $ENV{PORTDIR_OVERLAY}     = join ' ', @{$stat->portdir_overlay};
 551   local $ENV{PORTAGE_RO_DISTDIRS} = $stat->distdir;
 552   run command => $cmd, verbose => $verbose;
 553  };
 554
 555  unless ($success) {
 556   $self->_abort($errmsg);
 557   if (not $verbose and defined $output and $stat->verbose) {
 558    my $msg = join '', @$output;
 559    1 while chomp $msg;
 560    CPANPLUS::Error::error($msg);
 561   }
 562  }
 563
 564  return $success;
 565 }
 566
 567 sub _abort {
 568  my $self = shift;
 569
 570  CPANPLUS::Error::error("@_ -- aborting");
 571
 572  return 0;
 573 }
 574
 575 sub _notify {
 576  my $self = shift;
 577
 578  CPANPLUS::Error::msg("@_");
 579
 580  return 1;
 581 }
 582
 583 sub _skip { shift->_notify(@_, '-- skipping') }
 584
 585 =head1 DEPENDENCIES
 586
 587 Gentoo (L<http://gentoo.org>).
 588
 589 L<CPANPLUS>, L<IPC::Cmd> (core modules since 5.9.5), L<Parse::CPAN::Meta> (since 5.10.1).
 590
 591 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).
 592
 593 =head1 SEE ALSO
 594
 595 L<cpan2dist>.
 596
 597 L<CPANPLUS::Dist::Base>, L<CPANPLUS::Dist::Deb>, L<CPANPLUS::Dist::Mdv>.
 598
 599 =head1 AUTHOR
 600
 601 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 602
 603 You can contact me by mail or on C<irc.perl.org> (vincent).
 604
 605 =head1 BUGS
 606
 607 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>.
 608 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 609
 610 =head1 SUPPORT
 611
 612 You can find documentation for this module with the perldoc command.
 613
 614     perldoc CPANPLUS::Dist::Gentoo
 615
 616 =head1 ACKNOWLEDGEMENTS
 617
 618 The module was inspired by L<CPANPLUS::Dist::Deb> and L<CPANPLUS::Dist::Mdv>.
 619
 620 Kent Fredric, for testing and suggesting improvements.
 621
 622 =head1 COPYRIGHT & LICENSE
 623
 624 Copyright 2008-2009 Vincent Pit, all rights reserved.
 625
 626 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 627
 628 =cut
 629
 630 1; # End of CPANPLUS::Dist::Gentoo