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