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