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