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  $stat->prepared(0);
 253
 254  $self->SUPER::prepare(%opts);
 255
 256  return $FAIL->() unless $stat->prepared;
 257
 258  my $desc = $mod->description;
 259  ($desc = $name) =~ s/-+/::/g unless $desc;
 260  $stat->desc($desc);
 261
 262  $stat->uri('http://search.cpan.org/dist/' . $name);
 263
 264  unless ($author =~ /^(.)(.)/) {
 265   return $FAIL->('Wrong author name');
 266  }
 267  $stat->src("mirror://cpan/modules/by-authors/id/$1/$1$2/$author/"
 268             . $mod->package);
 269
 270  $stat->license($self->intuit_license);
 271
 272  my $prereqs = $mod->status->prereqs;
 273  my @depends;
 274  for my $prereq (sort keys %$prereqs) {
 275   next if $prereq =~ /^perl(?:-|\z)/;
 276   my $obj = $int->module_tree($prereq);
 277   return $FAIL->('Wrong module object') unless $obj;
 278   next if $obj->package_is_perl_core;
 279   {
 280    my $version;
 281    if ($prereqs->{$prereq}) {
 282     if ($obj->installed_version && $obj->installed_version < $obj->version) {
 283      $version = $obj->installed_version;
 284     } else {
 285      $version = $obj->package_version;
 286     }
 287    }
 288    push @depends, [ $obj->package_name, $version ];
 289   }
 290  }
 291  $stat->deps(\@depends);
 292
 293  return $OK->();
 294 }
 295
 296 =head2 C<intuit_license>
 297
 298 Returns an array reference to a list of Gentoo licences identifiers under which the current distribution is released.
 299
 300 =cut
 301
 302 my %dslip_license = (
 303  p => 'perl',
 304  g => 'gpl',
 305  l => 'lgpl',
 306  b => 'bsd',
 307  a => 'artistic',
 308  2 => 'artistic_2',
 309 );
 310
 311 sub intuit_license {
 312  my $self = shift;
 313  my $mod  = $self->parent;
 314
 315  my $dslip = $mod->dslip;
 316  if (defined $dslip and $dslip =~ /\S{4}(\S)/) {
 317   my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($dslip_license{$1});
 318   return \@licenses if @licenses;
 319  }
 320  my $extract_dir = $mod->status->extract;
 321
 322  for my $meta_file (qw/META.json META.yml/) {
 323   my $meta = eval {
 324    Parse::CPAN::Meta::LoadFile(File::Spec->catdir(
 325     $extract_dir,
 326     $meta_file,
 327    ));
 328   } or next;
 329   my $license = $meta->{license};
 330   if (defined $license) {
 331    my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($license);
 332    return \@licenses if @licenses;
 333   }
 334  }
 335
 336  return [ CPANPLUS::Dist::Gentoo::Maps::license_c2g('perl') ];
 337 }
 338
 339 sub create {
 340  my $self = shift;
 341  my $stat = $self->status;
 342
 343  my $OK   = sub { $stat->created(1); $stat->dist($stat->ebuild_file); 1 };
 344  my $FAIL = sub { $stat->created(0); $stat->dist(undef); $self->_abort(@_) if @_; 0 };
 345
 346  unless ($stat->prepared) {
 347   return $FAIL->(
 348    'Can\'t create', $stat->distribution, 'since it was never prepared'
 349   );
 350  }
 351
 352  if ($stat->created) {
 353   $self->_skip($stat->distribution, 'was already created');
 354   return $OK->();
 355  }
 356
 357  my $dir = $stat->ebuild_dir;
 358  unless (-d $dir) {
 359   eval { File::Path::mkpath($dir) };
 360   return $FAIL->("mkpath($dir): $@") if $@;
 361  }
 362
 363  my $file = $stat->ebuild_file;
 364  open my $eb, '>', $file or return $FAIL->("open($file): $!");
 365  print $eb $self->ebuild_source;
 366  close $eb;
 367
 368  $stat->created(0);
 369  $stat->dist(undef);
 370
 371  $self->SUPER::create(@_);
 372
 373  unless ($stat->created) {
 374   1 while unlink $file;
 375   return $FAIL->();
 376  }
 377
 378  if ($stat->do_manifest and not $self->update_manifest) {
 379   1 while unlink $file;
 380   return $FAIL->();
 381  }
 382
 383  return $OK->();
 384 }
 385
 386 =head2 C<update_manifest>
 387
 388 Updates the F<Manifest> file for the ebuild associated to the current dist object.
 389
 390 =cut
 391
 392 sub update_manifest {
 393  my $self = shift;
 394  my $stat = $self->status;
 395
 396  my $file = $stat->ebuild_file;
 397  unless ($file and -e $file) {
 398   return $self->_abort('The ebuild file is invalid or does not exist');
 399  }
 400
 401  unless (File::Copy::copy($stat->fetched_arch => $stat->distdir)) {
 402   return $self->_abort("Couldn\'t copy the distribution file to distdir ($!)");
 403  }
 404
 405  $self->_notify('Adding Manifest entry for', $stat->distribution);
 406
 407  return $self->_run([ 'ebuild', $stat->ebuild_file, 'manifest' ], 0);
 408 }
 409
 410 =head2 C<ebuild_source>
 411
 412 Returns the source of the ebuild for the current dist object.
 413
 414 =cut
 415
 416 sub ebuild_source {
 417  my $self = shift;
 418  my $stat = $self->status;
 419
 420  # We must resolve the deps now and not inside prepare because _cpan2portage
 421  # has to see the ebuilds already generated for the dependencies of the current
 422  # dist.
 423  my @deps = do {
 424   my %seen;
 425   sort grep !$seen{$_}++, 'dev-lang/perl',
 426                           map $self->_cpan2portage(@$_), @{$stat->deps}
 427  };
 428
 429  my $d = $stat->header;
 430  $d   .= "# Generated by CPANPLUS::Dist::Gentoo version $VERSION\n\n";
 431  $d   .= 'MODULE_AUTHOR="' . $stat->author . "\"\ninherit perl-module\n\n";
 432  $d   .= 'S="${WORKDIR}/' . $stat->distribution . "\"\n";
 433  $d   .= 'DESCRIPTION="' . $stat->desc . "\"\n";
 434  $d   .= 'HOMEPAGE="' . $stat->uri . "\"\n";
 435  $d   .= 'SRC_URI="' . $stat->src . "\"\n";
 436  $d   .= "SLOT=\"0\"\n";
 437  $d   .= 'LICENSE="|| ( ' . join(' ', sort @{$stat->license}) . " )\"\n";
 438  $d   .= 'KEYWORDS="' . join(' ', sort @{$stat->keywords}) . "\"\n";
 439  $d   .= 'DEPEND="' . join("\n", @deps) . "\"\n";
 440  $d   .= "SRC_TEST=\"do\"\n";
 441  $d   .= $stat->footer;
 442
 443  return $d;
 444 }
 445
 446 sub _cpan2portage {
 447  my ($self, $name, $version) = @_;
 448
 449  $name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($name);
 450  my $ver;
 451  $ver = CPANPLUS::Dist::Gentoo::Maps::version_c2g($version) if defined $version;
 452
 453  my @portdirs = ($main_portdir, @{$self->status->portdir_overlay});
 454
 455  for my $category (qw/virtual perl-core dev-perl perl-gcpan/, CATEGORY) {
 456   my $atom = ($category eq 'virtual' ? 'perl-' : '') . $name;
 457
 458   for my $portdir (@portdirs) {
 459    my @ebuilds = glob File::Spec->catfile(
 460     $portdir,
 461     $category,
 462     $atom,
 463     "$atom-*.ebuild",
 464    ) or next;
 465
 466    if (defined $ver) { # implies that $version is defined
 467     for (@ebuilds) {
 468      my ($eb_ver) = /\Q$atom\E-v?([\d._pr-]+).*?\.ebuild$/;
 469      return ">=$category/$atom-$ver"
 470             if  defined $eb_ver
 471             and CPANPLUS::Dist::Gentoo::Maps::version_gcmp($eb_ver, $ver) > 0;
 472     }
 473    } else {
 474     return "$category/$atom";
 475    }
 476
 477   }
 478
 479  }
 480
 481  $self->_skip(
 482   "Couldn't find an appropriate ebuild for $name in the portage tree"
 483  );
 484
 485  return '';
 486 }
 487
 488 sub install {
 489  my $self = shift;
 490  my $stat = $self->status;
 491  my $conf = $self->parent->parent->configure_object;
 492
 493  my $sudo = $conf->get_program('sudo');
 494  my @cmd = ('emerge', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 495  unshift @cmd, $sudo if $sudo;
 496
 497  my $success = $self->_run(\@cmd, 1);
 498  $stat->installed($success);
 499
 500  return $success;
 501 }
 502
 503 sub uninstall {
 504  my $self = shift;
 505  my $stat = $self->status;
 506  my $conf = $self->parent->parent->configure_object;
 507
 508  my $sudo = $conf->get_program('sudo');
 509  my @cmd = ('emerge', '-C', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version);
 510  unshift @cmd, $sudo if $sudo;
 511
 512  my $success = $self->_run(\@cmd, 1);
 513  $stat->uninstalled($success);
 514
 515  return $success;
 516 }
 517
 518 sub _run {
 519  my ($self, $cmd, $verbose) = @_;
 520  my $stat = $self->status;
 521
 522  my ($success, $errmsg, $output) = do {
 523   local $ENV{PORTDIR_OVERLAY}     = join ' ', @{$stat->portdir_overlay};
 524   local $ENV{PORTAGE_RO_DISTDIRS} = $stat->distdir;
 525   run command => $cmd, verbose => $verbose;
 526  };
 527
 528  unless ($success) {
 529   $self->_abort($errmsg);
 530   if (not $verbose and defined $output and $stat->verbose) {
 531    my $msg = join '', @$output;
 532    1 while chomp $msg;
 533    CPANPLUS::Error::error($msg);
 534   }
 535  }
 536
 537  return $success;
 538 }
 539
 540 sub _abort {
 541  my $self = shift;
 542
 543  CPANPLUS::Error::error("@_ -- aborting");
 544
 545  return 0;
 546 }
 547
 548 sub _notify {
 549  my $self = shift;
 550
 551  CPANPLUS::Error::msg("@_");
 552
 553  return 1;
 554 }
 555
 556 sub _skip { shift->_notify(@_, '-- skipping') }
 557
 558 =head1 DEPENDENCIES
 559
 560 Gentoo (L<http://gentoo.org>).
 561
 562 L<CPANPLUS>, L<IPC::Cmd> (core modules since 5.9.5), L<Parse::CPAN::Meta> (since 5.10.1).
 563
 564 L<Cwd>, L<Carp> (since perl 5), L<File::Path> (5.001), L<File::Copy> (5.002), L<File::Spec> (5.00405).
 565
 566 =head1 SEE ALSO
 567
 568 L<cpan2dist>.
 569
 570 L<CPANPLUS::Dist::Base>, L<CPANPLUS::Dist::Deb>, L<CPANPLUS::Dist::Mdv>.
 571
 572 =head1 AUTHOR
 573
 574 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 575
 576 You can contact me by mail or on C<irc.perl.org> (vincent).
 577
 578 =head1 BUGS
 579
 580 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>.
 581 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 582
 583 =head1 SUPPORT
 584
 585 You can find documentation for this module with the perldoc command.
 586
 587     perldoc CPANPLUS::Dist::Gentoo
 588
 589 =head1 ACKNOWLEDGEMENTS
 590
 591 The module was inspired by L<CPANPLUS::Dist::Deb> and L<CPANPLUS::Dist::Mdv>.
 592
 593 Kent Fredric, for testing and suggesting improvements.
 594
 595 =head1 COPYRIGHT & LICENSE
 596
 597 Copyright 2008-2009 Vincent Pit, all rights reserved.
 598
 599 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 600
 601 =cut
 602
 603 1; # End of CPANPLUS::Dist::Gentoo