X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FCPANPLUS-Dist-Gentoo.git;a=blobdiff_plain;f=lib%2FCPANPLUS%2FDist%2FGentoo.pm;h=c86573c0e17f3053f009551419643bfce310e19f;hp=243253e227f33b9c6cc3c14b9bb64332a5d19134;hb=df1df6f85cf0d3f58fdeccc27e2fcfccc3083ec3;hpb=befc67bc91691a8ee10b9696d61ea3bb49e5b3d0 diff --git a/lib/CPANPLUS/Dist/Gentoo.pm b/lib/CPANPLUS/Dist/Gentoo.pm index 243253e..c86573c 100644 --- a/lib/CPANPLUS/Dist/Gentoo.pm +++ b/lib/CPANPLUS/Dist/Gentoo.pm @@ -3,17 +3,21 @@ package CPANPLUS::Dist::Gentoo; use strict; use warnings; -use Cwd qw/abs_path/; +use Cwd (); +use List::Util qw; use File::Copy (); use File::Path (); use File::Spec; -use IPC::Cmd qw/run can_run/; +use IPC::Cmd (); +use Parse::CPAN::Meta (); use CPANPLUS::Error (); -use base qw/CPANPLUS::Dist::Base/; +use base qw; +use CPANPLUS::Dist::Gentoo::Atom; +use CPANPLUS::Dist::Gentoo::Guard; use CPANPLUS::Dist::Gentoo::Maps; =head1 NAME @@ -22,11 +26,11 @@ CPANPLUS::Dist::Gentoo - CPANPLUS backend generating Gentoo ebuilds. =head1 VERSION -Version 0.07 +Version 0.10 =cut -our $VERSION = '0.07'; +our $VERSION = '0.10'; =head1 SYNOPSIS @@ -50,7 +54,54 @@ They favour depending on a C, on C, C or C to your F file. +Before installing this module, you should append C to your F file. + +You have two ways for installing this module : + +=over 4 + +=item * + +Use the perl overlay located at L. +It contains an ebuild for L which will most likely be up-to-date given the reactivity of Gentoo's Perl herd. + +=item * + +Bootstrap an ebuild for L using itself. + +First, make sure your system C is C<5.10> or greater, so that the L toolchain is available. + + $ perl -v + This is perl 5, version 12, subversion 2 (v5.12.2)... + +C C<5.12> is the current stable Perl version in Gentoo. +If you still have C C<5.8.x>, you can upgrade it by running the following commands as root : + + # emerge -tv ">=dev-lang/perl-5.10" + # perl-cleaner --all + +Then, fetch the L tarball : + + $ cd /tmp + $ wget http://search.cpan.org/CPAN/authors/id/V/VP/VPIT/CPANPLUS-Dist-Gentoo-0.10.tar.gz + +Log in as root and unpack it in e.g. your home directory : + + # cd + # tar xzf /tmp/CPANPLUS-Dist-Gentoo-0.10.tar.gz + # cd CPANPLUS-Dist-Gentoo-0.10 + +Bootstrap L using the bundled shell script C : + + # perl Makefile.PL + # make + # PERL5LIB=blib/lib samples/g-cpanp CPANPLUS::Dist::Gentoo + +Finally, emerge the C ebuild you've just generated : + + # emerge -tv CPANPLUS-Dist-Gentoo + +=back =head1 METHODS @@ -66,6 +117,7 @@ my $default_keywords; my $default_distdir; my $main_portdir; +my %dependencies; my %forced; my $unquote = sub { @@ -80,8 +132,8 @@ my $format_available; sub format_available { return $format_available if defined $format_available; - for my $prog (qw/emerge ebuild/) { - unless (can_run($prog)) { + for my $prog (qw) { + unless (IPC::Cmd::can_run($prog)) { __PACKAGE__->_abort("$prog is required to write ebuilds"); return $format_available = 0; } @@ -89,24 +141,27 @@ sub format_available { if (IPC::Cmd->can_capture_buffer) { my $buffers; - my ($success, $errmsg) = run command => [ qw/emerge --info/ ], - verbose => 0, - buffer => \$buffers; + my ($success, $errmsg) = IPC::Cmd::run( + command => [ qw ], + verbose => 0, + buffer => \$buffers, + ); if ($success) { if ($buffers =~ /^PORTDIR_OVERLAY=(.*)$/m) { - $overlays = [ map abs_path($_), split ' ', $unquote->($1) ]; + $overlays = [ map Cwd::abs_path($_), split ' ', $unquote->($1) ]; } if ($buffers =~ /^ACCEPT_KEYWORDS=(.*)$/m) { $default_keywords = [ split ' ', $unquote->($1) ]; } if ($buffers =~ /^DISTDIR=(.*)$/m) { - $default_distdir = abs_path($unquote->($1)); + $default_distdir = Cwd::abs_path($unquote->($1)); } if ($buffers =~ /^PORTDIR=(.*)$/m) { - $main_portdir = abs_path($unquote->($1)); + $main_portdir = Cwd::abs_path($unquote->($1)); } } else { __PACKAGE__->_abort($errmsg); + return $format_available = 0; } } @@ -121,12 +176,15 @@ sub init { my $stat = $self->status; my $conf = $self->parent->parent->configure_object; - $stat->mk_accessors(qw/name version author distribution desc uri src license - fetched_arch deps - ebuild_name ebuild_version ebuild_dir ebuild_file - portdir_overlay - overlay distdir keywords do_manifest header footer - force verbose/); + $stat->mk_accessors(qw< + name version author distribution desc uri src license + meta min_perl + fetched_arch + requires configure_requires recursive_requires + ebuild_name ebuild_version ebuild_dir ebuild_file + portdir_overlay overlay distdir keywords do_manifest header footer + force verbose + >); $stat->force($conf->get_conf('force')); $stat->verbose($conf->get_conf('verbose')); @@ -134,6 +192,25 @@ sub init { return 1; } +my $filter_prereqs = sub { + my ($int, $prereqs) = @_; + + my @requires; + for my $prereq (sort keys %$prereqs) { + next if $prereq =~ /^perl(?:-|\z)/; + + my $obj = $int->module_tree($prereq); + next unless $obj; # Not in the module tree (e.g. Config) + next if $obj->package_is_perl_core; + + my $version = $prereqs->{$prereq} || undef; + + push @requires, [ $obj->package_name, $version ]; + } + + return \@requires; +}; + sub prepare { my $self = shift; my $mod = $self->parent; @@ -145,8 +222,9 @@ sub prepare { my $OK = sub { $stat->prepared(1); 1 }; my $FAIL = sub { $stat->prepared(0); $self->_abort(@_) if @_; 0 }; + my $SKIP = sub { $stat->prepared(1); $stat->created(1); $self->_skip(@_) if @_; 1 }; - my $keywords = delete $opts{'keywords'}; + my $keywords = delete $opts{keywords}; if (defined $keywords) { $keywords = [ split ' ', $keywords ]; } else { @@ -154,21 +232,26 @@ sub prepare { } $stat->keywords($keywords); - my $manifest = delete $opts{'manifest'}; + my $manifest = delete $opts{manifest}; $manifest = 1 unless defined $manifest; $manifest = 0 if $manifest =~ /^\s*no?\s*$/i; $stat->do_manifest($manifest); - my $header = delete $opts{'header'}; + my $header = delete $opts{header}; if (defined $header) { 1 while chomp $header; $header .= "\n\n"; } else { - $header = ''; + my $year = (localtime)[5] + 1900; + $header = <<" DEF_HEADER"; +# Copyright 1999-$year Gentoo Foundation +# Distributed under the terms of the GNU General Public License v2 +# \$Header: \$ + DEF_HEADER } $stat->header($header); - my $footer = delete $opts{'footer'}; + my $footer = delete $opts{footer}; if (defined $footer) { $footer = "\n" . $footer; } else { @@ -176,17 +259,16 @@ sub prepare { } $stat->footer($footer); - my $overlay = delete $opts{'overlay'}; - $overlay = (defined $overlay) ? abs_path $overlay : '/usr/local/portage'; + my $overlay = delete $opts{overlay}; + $overlay = (defined $overlay) ? Cwd::abs_path($overlay) : '/usr/local/portage'; $stat->overlay($overlay); - my $distdir = delete $opts{'distdir'}; - $distdir = (defined $distdir) ? abs_path $distdir : $default_distdir; + my $distdir = delete $opts{distdir}; + $distdir = (defined $distdir) ? Cwd::abs_path($distdir) : $default_distdir; $stat->distdir($distdir); - if ($stat->do_manifest && !-w $stat->distdir) { - return $FAIL->('distdir isn\'t writable'); - } + return $FAIL->("distdir isn't writable") if $stat->do_manifest && !-w $distdir; + $stat->fetched_arch($mod->status->fetch); my $cur = File::Spec->curdir(); @@ -211,7 +293,7 @@ sub prepare { $stat->distribution($name . '-' . $version); - $stat->ebuild_version(CPANPLUS::Dist::Gentoo::Maps::version_c2g($version)); + $stat->ebuild_version(CPANPLUS::Dist::Gentoo::Maps::version_c2g($name, $version)); $stat->ebuild_name(CPANPLUS::Dist::Gentoo::Maps::name_c2g($name)); @@ -227,75 +309,163 @@ sub prepare { ); $stat->ebuild_file($file); - if (-e $file) { - my $skip = 1; - if ($stat->force and not $forced{$file}) { - if (-w $file) { - 1 while unlink $file; - $forced{$file} = 1; - $skip = 0; - } else { - $self->_skip("Can't force rewriting of $file"); + if ($stat->force) { + # Always generate an ebuild in our category when forcing + if ($forced{$file}) { + $stat->dist($file); + return $SKIP->('Ebuild already forced for', $stat->distribution); + } + ++$forced{$file}; + if (-e $file) { + unless (-w $file) { + $stat->dist($file); + return $SKIP->("Can't force rewriting of $file"); } - } else { - $self->_skip('Ebuild already generated for', $stat->distribution); + 1 while unlink $file; } - if ($skip) { - $stat->prepared(1); - $stat->created(1); - $stat->dist($file); - return 1; + } else { + if (my $atom = $self->_cpan2portage($name, $version)) { + $stat->dist($atom->ebuild); + return $SKIP->('Ebuild already generated for', $stat->distribution); } } - $self->SUPER::prepare(%opts); - $stat->prepared(0); + $self->SUPER::prepare(@_); + + return $FAIL->() unless $stat->prepared; + my $desc = $mod->description; - ($desc = $name) =~ s/-+/::/g unless $desc; + $desc = $mod->comment unless $desc; + $desc = "$name Perl distribution (provides " . $mod->module . ')' + unless $desc; + $desc = substr($desc, 0, 77) . '...' if length $desc > 80; $stat->desc($desc); $stat->uri('http://search.cpan.org/dist/' . $name); - unless ($author =~ /^(.)(.)/) { - return $FAIL->('Wrong author name'); - } - $stat->src("mirror://cpan/modules/by-authors/id/$1/$1$2/$author/" - . $mod->package); + $author =~ /^(.)(.)/ or return $FAIL->('Wrong author name'); + $stat->src("mirror://cpan/modules/by-authors/id/$1/$1$2/$author/" . $mod->package); - $stat->license([ qw/Artistic GPL-2/ ]); + $stat->license($self->intuit_license); - my $prereqs = $mod->status->prereqs; - my @depends; - for my $prereq (sort keys %$prereqs) { - next if $prereq =~ /^perl(?:-|\z)/; - my $obj = $int->module_tree($prereq); - return $FAIL->('Wrong module object') unless $obj; - next if $obj->package_is_perl_core; - { - my $version; - if ($prereqs->{$prereq}) { - if ($obj->installed_version && $obj->installed_version < $obj->version) { - $version = $obj->installed_version; - } else { - $version = $obj->package_version; - } - } - push @depends, [ $obj->package_name, $version ]; + my $mstat = $mod->status; + $stat->configure_requires($int->$filter_prereqs($mstat->configure_requires)); + $stat->requires($int->$filter_prereqs($mstat->requires)); + $stat->recursive_requires([ ]); + + $dependencies{$name} = [ map $_->[0], @{ $stat->requires } ]; + + my $meta = $self->meta; + $stat->min_perl(CPANPLUS::Dist::Gentoo::Maps::perl_version_c2g( + $meta->{requires}->{perl}, + )); + + return $OK->(); +} + +=head2 C + +Returns the contents of the F or F files as parsed by L. + +=cut + +sub meta { + my $self = shift; + my $mod = $self->parent; + my $stat = $self->status; + + my $meta = $stat->meta; + return $meta if defined $meta; + + my $extract_dir = $mod->status->extract; + + for my $name (qw) { + my $meta_file = File::Spec->catdir($extract_dir, $name); + next unless -e $meta_file; + + local $@; + my $meta = eval { Parse::CPAN::Meta::LoadFile($meta_file) }; + if (defined $meta) { + $stat->meta($meta); + return $meta; } } - $stat->deps(\@depends); - return $OK->(); + return; +} + +=head2 C + +Returns an array reference to a list of Gentoo licences identifiers under which the current distribution is released. + +=cut + +my %dslip_license = ( + p => 'perl', + g => 'gpl', + l => 'lgpl', + b => 'bsd', + a => 'artistic', + 2 => 'artistic_2', +); + +sub intuit_license { + my $self = shift; + my $mod = $self->parent; + + my $dslip = $mod->dslip; + if (defined $dslip and $dslip =~ /\S{4}(\S)/) { + my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($dslip_license{$1}); + return \@licenses if @licenses; + } + + my $meta = $self->meta; + my $license = $meta->{license}; + if (defined $license) { + my @licenses = CPANPLUS::Dist::Gentoo::Maps::license_c2g($license); + return \@licenses if @licenses; + } + + return [ CPANPLUS::Dist::Gentoo::Maps::license_c2g('perl') ]; } sub create { my $self = shift; my $stat = $self->status; - my $OK = sub { $stat->created(1); $stat->dist($stat->ebuild_file); 1 }; - my $FAIL = sub { $stat->created(0); $stat->dist(undef); $self->_abort(@_) if @_; 0 }; + my $file; + + my $guard = CPANPLUS::Dist::Gentoo::Guard->new(sub { + if (defined $file and -e $file and -w _) { + 1 while unlink $file; + } + }); + + my $SIG_INT = $SIG{INT}; + local $SIG{INT} = sub { + if ($SIG_INT) { + local $@; + eval { $SIG_INT->() }; + die $@ if $@; + } + die 'Caught SIGINT'; + }; + + my $OK = sub { + $guard->unarm; + $stat->created(1); + $stat->dist($file) if defined $file; + 1; + }; + + my $FAIL = sub { + $stat->created(0); + $stat->dist(undef); + $self->_abort(@_) if @_; + 0; + }; unless ($stat->prepared) { return $FAIL->( @@ -305,6 +475,7 @@ sub create { if ($stat->created) { $self->_skip($stat->distribution, 'was already created'); + $file = $stat->dist; # Keep the existing one. return $OK->(); } @@ -314,21 +485,30 @@ sub create { return $FAIL->("mkpath($dir): $@") if $@; } - my $file = $stat->ebuild_file; - open my $eb, '>', $file or return $FAIL->("open($file): $!"); - print $eb $self->ebuild_source; - close $eb; + $file = $stat->ebuild_file; + + # Create a placeholder ebuild to prevent recursion with circular dependencies. + { + open my $eb, '>', $file or return $FAIL->("open($file): $!"); + print $eb "PLACEHOLDER\n"; + } $stat->created(0); $stat->dist(undef); $self->SUPER::create(@_); - if ($stat->do_manifest and not $self->update_manifest) { - 1 while unlink $file; - return $FAIL->(); + return $FAIL->() unless $stat->created; + + { + open my $eb, '>', $file or return $FAIL->("open($file): $!"); + my $source = $self->ebuild_source; + return $FAIL->() unless defined $source; + print $eb $source; } + return $FAIL->() if $stat->do_manifest and not $self->update_manifest; + return $OK->(); } @@ -343,7 +523,7 @@ sub update_manifest { my $stat = $self->status; my $file = $stat->ebuild_file; - unless ($file and -e $file) { + unless (defined $file and -e $file) { return $self->_abort('The ebuild file is invalid or does not exist'); } @@ -353,27 +533,92 @@ sub update_manifest { $self->_notify('Adding Manifest entry for', $stat->distribution); - return $self->_run([ 'ebuild', $stat->ebuild_file, 'manifest' ], 0); + return $self->_run([ 'ebuild', $file, 'manifest' ], 0); } =head2 C -Returns the source of the ebuild for the current dist object. +Returns the source of the ebuild for the current dist object, or C when one of the dependencies couldn't be mapped to an existing ebuild. =cut +my $dep_tree_contains; +{ + my %seen; + + $dep_tree_contains = sub { + my ($dist, $target) = @_; + + return 0 if $seen{$dist}; + local $seen{$dist} = 1; + + for my $kid (@{ $dependencies{$dist} }) { + return 1 if $kid eq $target + or $dep_tree_contains->($kid, $target); + } + + return 0; + } +} + sub ebuild_source { my $self = shift; my $stat = $self->status; + { + my $name = $stat->name; + my %recursive_kids = map { $_ => 1 } + grep $dep_tree_contains->($_, $name), + @{ $dependencies{$name} }; + if (%recursive_kids) { + my (@requires, @recursive_requires); + for (@{ $stat->requires }) { + if ($recursive_kids{$_->[0]}) { + push @recursive_requires, $_; + } else { + push @requires, $_; + } + } + $stat->requires(\@requires); + $stat->recursive_requires(\@recursive_requires); + } + } + # We must resolve the deps now and not inside prepare because _cpan2portage # has to see the ebuilds already generated for the dependencies of the current # dist. - my @deps = do { - my %seen; - sort grep !$seen{$_}++, 'dev-lang/perl', - map $self->_cpan2portage(@$_), @{$stat->deps} - }; + + my (@configure_requires, @requires, @recursive_requires); + + my @phases = ( + [ configure_requires => \@configure_requires ], + [ requires => \@requires ], + [ recursive_requires => \@recursive_requires ], + ); + + push @requires, CPANPLUS::Dist::Gentoo::Atom->new( + category => 'dev-lang', + name => 'perl', + version => $stat->min_perl, + ); + + for (@phases) { + my ($phase, $list) = @$_; + + for (@{ $stat->$phase }) { + my $atom = $self->_cpan2portage(@$_); + unless (defined $atom) { + $self->_abort( + "Couldn't find an appropriate ebuild for $_->[0] in the portage tree" + ); + return; + } + + push @$list, $atom; + } + + @$list = CPANPLUS::Dist::Gentoo::Atom->fold(@$list); + } my $d = $stat->header; $d .= "# Generated by CPANPLUS::Dist::Gentoo version $VERSION\n\n"; @@ -385,7 +630,10 @@ sub ebuild_source { $d .= "SLOT=\"0\"\n"; $d .= 'LICENSE="|| ( ' . join(' ', sort @{$stat->license}) . " )\"\n"; $d .= 'KEYWORDS="' . join(' ', sort @{$stat->keywords}) . "\"\n"; - $d .= 'DEPEND="' . join("\n", @deps) . "\"\n"; + $d .= 'RDEPEND="' . join("\n", sort @requires) . "\"\n" if @requires; + $d .= 'PDEPEND="' . join("\n", sort @recursive_requires) . "\"\n" + if @recursive_requires; + $d .= 'DEPEND="' . join("\n", '${RDEPEND}', sort @configure_requires) . "\"\n"; $d .= "SRC_TEST=\"do\"\n"; $d .= $stat->footer; @@ -393,45 +641,40 @@ sub ebuild_source { } sub _cpan2portage { - my ($self, $name, $version) = @_; + my ($self, $dist_name, $dist_version) = @_; - $name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($name); - my $ver; - $ver = CPANPLUS::Dist::Gentoo::Maps::version_c2g($version) if defined $version; + my $name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name); + my $version = CPANPLUS::Dist::Gentoo::Maps::version_c2g($dist_name, $dist_version); my @portdirs = ($main_portdir, @{$self->status->portdir_overlay}); - for my $category (qw/virtual perl-core dev-perl perl-gcpan/, CATEGORY) { - my $atom = ($category eq 'virtual' ? 'perl-' : '') . $name; + for my $category (qw, CATEGORY) { + my $name = ($category eq 'virtual' ? 'perl-' : '') . $name; for my $portdir (@portdirs) { my @ebuilds = glob File::Spec->catfile( $portdir, $category, - $atom, - "$atom-*.ebuild", + $name, + "$name-*.ebuild", ) or next; - if (defined $ver) { # implies that $version is defined - for (@ebuilds) { - my ($eb_ver) = /\Q$atom\E-v?([\d._pr-]+).*?\.ebuild$/; - return ">=$category/$atom-$ver" - if defined $eb_ver - and CPANPLUS::Dist::Gentoo::Maps::version_gcmp($eb_ver, $ver) > 0; - } - } else { - return "$category/$atom"; - } - + my $last = reduce { $a < $b ? $b : $a } # handles overloading + map CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($_), + @ebuilds; + next if defined $version and $last < $version; + + return CPANPLUS::Dist::Gentoo::Atom->new( + category => $last->category, + name => $last->name, + version => $version, + ebuild => $last->ebuild, + ); } } - $self->_skip( - "Couldn't find an appropriate ebuild for $name in the portage tree" - ); - - return ''; + return; } sub install { @@ -471,7 +714,10 @@ sub _run { my ($success, $errmsg, $output) = do { local $ENV{PORTDIR_OVERLAY} = join ' ', @{$stat->portdir_overlay}; local $ENV{PORTAGE_RO_DISTDIRS} = $stat->distdir; - run command => $cmd, verbose => $verbose; + IPC::Cmd::run( + command => $cmd, + verbose => $verbose, + ); }; unless ($success) { @@ -508,9 +754,9 @@ sub _skip { shift->_notify(@_, '-- skipping') } Gentoo (L). -L, L (core modules since 5.9.5). +L, L (core modules since 5.9.5), L (since 5.10.1). -L, L (since perl 5), L (5.001), L (5.002), L (5.00405). +L, L (since perl 5), L (5.001), L (5.002), L (5.00405), L (5.007003). =head1 SEE ALSO @@ -543,7 +789,7 @@ Kent Fredric, for testing and suggesting improvements. =head1 COPYRIGHT & LICENSE -Copyright 2008-2009 Vincent Pit, all rights reserved. +Copyright 2008,2009,2010 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.