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