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.07
  28
  29 =cut
  30
  31 our $VERSION = '0.07';
  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);
 347   1;
 348  };
 349
 350  my $FAIL = sub {
 351   $stat->created(0);
 352   $stat->dist(undef);
 353   $self->_abort(@_) if @_;
 354   if ($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   return $OK->();
 369  }
 370
 371  my $dir = $stat->ebuild_dir;
 372  unless (-d $dir) {
 373   eval { File::Path::mkpath($dir) };
 374   return $FAIL->("mkpath($dir): $@") if $@;
 375  }
 376
 377  $file = $stat->ebuild_file;
 378
 379  # Create a placeholder ebuild to prevent recursion with circular dependencies.
 380  {
 381   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 382   print $eb "PLACEHOLDER\n";
 383  }
 384
 385  $stat->created(0);
 386  $stat->dist(undef);
 387
 388  $self->SUPER::create(@_);
 389
 390  return $FAIL->() unless $stat->created;
 391
 392  {
 393   open my $eb, '>', $file or return $FAIL->("open($file): $!");
 394   my $source = $self->ebuild_source;
 395   return $FAIL->() unless defined $source;
 396   print $eb $source;
 397  }
 398
 399  return $FAIL->() if $stat->do_manifest and not $self->update_manifest;
 400
 401  return $OK->();
 402 }
 403
 404 =head2 C<update_manifest>
 405
 406 Updates the F<Manifest> file for the ebuild associated to the current dist object.
 407
 408 =cut
 409
 410 sub update_manifest {
 411  my $self = shift;
 412  my $stat = $self->status;
 413
 414  my $file = $stat->ebuild_file;
 415  unless ($file and -e $file) {
 416   return $self->_abort('The ebuild file is invalid or does not exist');
 417  }
 418
 419  unless (File::Copy::copy($stat->fetched_arch => $stat->distdir)) {
 420   return $self->_abort("Couldn\'t copy the distribution file to distdir ($!)");
 421  }
 422
 423  $self->_notify('Adding Manifest entry for', $stat->distribution);
 424
 425  return $self->_run([ 'ebuild', $stat->ebuild_file, 'manifest' ], 0);
 426 }
 427
 428 =head2 C<ebuild_source>
 429
 430 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.
 431
 432 =cut
 433
 434 sub ebuild_source {
 435  my $self = shift;
 436  my $stat = $self->status;
 437
 438  # We must resolve the deps now and not inside prepare because _cpan2portage
 439  # has to see the ebuilds already generated for the dependencies of the current
 440  # dist.
 441  my @deps;
 442  for (@{$stat->deps}) {
 443   my $dep = $self->_cpan2portage(@$_);
 444   unless (defined $dep) {
 445    $self->_abort(
 446     "Couldn't find an appropriate ebuild for $_->[0] in the portage tree"
 447    );
 448    return;
 449   }
 450   push @deps, $dep;
 451  }
 452
 453  @deps = do { my %seen; sort grep !$seen{$_}++, 'dev-lang/perl', @deps };
 454
 455  my $d = $stat->header;
 456  $d   .= "# Generated by CPANPLUS::Dist::Gentoo version $VERSION\n\n";
 457  $d   .= 'MODULE_AUTHOR="' . $stat->author . "\"\ninherit perl-module\n\n";
 458  $d   .= 'S="${WORKDIR}/' . $stat->distribution . "\"\n";
 459  $d   .= 'DESCRIPTION="' . $stat->desc . "\"\n";
 460  $d   .= 'HOMEPAGE="' . $stat->uri . "\"\n";
 461  $d   .= 'SRC_URI="' . $stat->src . "\"\n";
 462  $d   .= "SLOT=\"0\"\n";
 463  $d   .= 'LICENSE="|| ( ' . join(' ', sort @{$stat->license}) . " )\"\n";
 464  $d   .= 'KEYWORDS="' . join(' ', sort @{$stat->keywords}) . "\"\n";
 465  $d   .= 'DEPEND="' . join("\n", @deps) . "\"\n";
 466  $d   .= "SRC_TEST=\"do\"\n";
 467  $d   .= $stat->footer;
 468
 469  return $d;
 470 }
 471
 472 sub _cpan2portage {
 473  my ($self, $name, $version) = @_;
 474
 475  $name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($name);
 476  my $ver;
 477  $ver = CPANPLUS::Dist::Gentoo::Maps::version_c2g($version) if defined $version;
 478
 479  my @portdirs = ($main_portdir, @{$self->status->portdir_overlay});
 480
 481  for my $category (qw/virtual perl-core dev-perl perl-gcpan/, CATEGORY) {
 482   my $atom = ($category eq 'virtual' ? 'perl-' : '') . $name;
 483
 484   for my $portdir (@portdirs) {
 485    my @ebuilds = glob File::Spec->catfile(
 486     $portdir,
 487     $category,
 488     $atom,
 489     "$atom-*.ebuild",
 490    ) or next;
 491
 492    my $last = reduce {
 493     CPANPLUS::Dist::Gentoo::Maps::version_gcmp($b->[1], $a->[1]) >= 0 ? $b : $a
 494    } map [ $_, /\Q$atom\E-v?([\d._pr-]+).*?\.ebuild$/ ? $1 : 0 ], @ebuilds;
 495
 496    my $dep;
 497    if (defined $ver) { # implies that $version is defined
 498     next unless
 499               CPANPLUS::Dist::Gentoo::Maps::version_gcmp($last->[1], $ver) >= 0;
 500     $dep = ">=$category/$atom-$ver";
 501    } else {
 502     $dep = "$category/$atom";
 503    }
 504
 505    return wantarray ? ($dep, $last->[0]) : $dep;
 506   }
 507
 508  }
 509
 510  return;
 511 }
 512
 513 sub install {
 514  my $self = shift;
 515  my $stat = $self->status;
 516  my $conf = $self->parent->parent->configure_object;
 517
 518  my $sudo = $conf->get_program('sudo');
 519  my @cmd = ('emerge', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 520  unshift @cmd, $sudo if $sudo;
 521
 522  my $success = $self->_run(\@cmd, 1);
 523  $stat->installed($success);
 524
 525  return $success;
 526 }
 527
 528 sub uninstall {
 529  my $self = shift;
 530  my $stat = $self->status;
 531  my $conf = $self->parent->parent->configure_object;
 532
 533  my $sudo = $conf->get_program('sudo');
 534  my @cmd = ('emerge', '-C', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 535  unshift @cmd, $sudo if $sudo;
 536
 537  my $success = $self->_run(\@cmd, 1);
 538  $stat->uninstalled($success);
 539
 540  return $success;
 541 }
 542
 543 sub _run {
 544  my ($self, $cmd, $verbose) = @_;
 545  my $stat = $self->status;
 546
 547  my ($success, $errmsg, $output) = do {
 548   local $ENV{PORTDIR_OVERLAY}     = join ' ', @{$stat->portdir_overlay};
 549   local $ENV{PORTAGE_RO_DISTDIRS} = $stat->distdir;
 550   run command => $cmd, verbose => $verbose;
 551  };
 552
 553  unless ($success) {
 554   $self->_abort($errmsg);
 555   if (not $verbose and defined $output and $stat->verbose) {
 556    my $msg = join '', @$output;
 557    1 while chomp $msg;
 558    CPANPLUS::Error::error($msg);
 559   }
 560  }
 561
 562  return $success;
 563 }
 564
 565 sub _abort {
 566  my $self = shift;
 567
 568  CPANPLUS::Error::error("@_ -- aborting");
 569
 570  return 0;
 571 }
 572
 573 sub _notify {
 574  my $self = shift;
 575
 576  CPANPLUS::Error::msg("@_");
 577
 578  return 1;
 579 }
 580
 581 sub _skip { shift->_notify(@_, '-- skipping') }
 582
 583 =head1 DEPENDENCIES
 584
 585 Gentoo (L<http://gentoo.org>).
 586
 587 L<CPANPLUS>, L<IPC::Cmd> (core modules since 5.9.5), L<Parse::CPAN::Meta> (since 5.10.1).
 588
 589 L<Cwd>, L<Carp> (since perl 5), L<File::Path> (5.001), L<File::Copy> (5.002), L<File::Spec> (5.00405).
 590
 591 =head1 SEE ALSO
 592
 593 L<cpan2dist>.
 594
 595 L<CPANPLUS::Dist::Base>, L<CPANPLUS::Dist::Deb>, L<CPANPLUS::Dist::Mdv>.
 596
 597 =head1 AUTHOR
 598
 599 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 600
 601 You can contact me by mail or on C<irc.perl.org> (vincent).
 602
 603 =head1 BUGS
 604
 605 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>.
 606 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 607
 608 =head1 SUPPORT
 609
 610 You can find documentation for this module with the perldoc command.
 611
 612     perldoc CPANPLUS::Dist::Gentoo
 613
 614 =head1 ACKNOWLEDGEMENTS
 615
 616 The module was inspired by L<CPANPLUS::Dist::Deb> and L<CPANPLUS::Dist::Mdv>.
 617
 618 Kent Fredric, for testing and suggesting improvements.
 619
 620 =head1 COPYRIGHT & LICENSE
 621
 622 Copyright 2008-2009 Vincent Pit, all rights reserved.
 623
 624 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 625
 626 =cut
 627
 628 1; # End of CPANPLUS::Dist::Gentoo