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