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=24e1e357637016eac27c318695904956097673fe;hb=df1df6f85cf0d3f58fdeccc27e2fcfccc3083ec3;hpb=667d0c86a602a24e6c948443557ebfb9700c83fa diff --git a/lib/CPANPLUS/Dist/Gentoo.pm b/lib/CPANPLUS/Dist/Gentoo.pm index 24e1e35..c86573c 100644 --- a/lib/CPANPLUS/Dist/Gentoo.pm +++ b/lib/CPANPLUS/Dist/Gentoo.pm @@ -3,16 +3,22 @@ package CPANPLUS::Dist::Gentoo; use strict; use warnings; -use Cwd qw/abs_path/; -use File::Copy qw/copy/; -use File::Path qw/mkpath/; -use File::Spec::Functions qw/catdir catfile/; +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 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 @@ -20,11 +26,11 @@ CPANPLUS::Dist::Gentoo - CPANPLUS backend generating Gentoo ebuilds. =head1 VERSION -Version 0.04 +Version 0.10 =cut -our $VERSION = '0.04'; +our $VERSION = '0.10'; =head1 SYNOPSIS @@ -39,30 +45,130 @@ our $VERSION = '0.04'; =head1 DESCRPITON -This module is a CPANPLUS backend that recursively generates Gentoo ebuilds for a given package in the specified overlay (defaults to F), updates the manifest, and even emerges it (together with its dependencies) if the user requires it. You need write permissions on the directory where Gentoo fetches its source files (usually F). You also need to specify the correct keyword for your architecture if it differs from the default C. +This module is a CPANPLUS backend that recursively generates Gentoo ebuilds for a given package in the specified overlay (defaults to F), updates the manifest, and even emerges it (together with its dependencies) if the user requires it. +You need write permissions on the directory where Gentoo fetches its source files (usually F). +The valid C for the generated ebuilds are by default those given in C, but you can specify your own with the C dist-option. -The generated ebuilds are placed into the C category. They favour depending on C, C or C (in that order) rather than C. +The generated ebuilds are placed into the C category. +They favour depending on a C, on C, C or C (in that order) rather than C. =head1 INSTALLATION -After installing this module, you should append 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 -All the methods are inherited from L. Please refer to its documentation for precise information on what's done at each step. +This module inherits all the methods from L. +Please refer to its documentation for precise information on what's done at each step. =cut use constant CATEGORY => 'perl-gcpanp'; +my $overlays; +my $default_keywords; +my $default_distdir; +my $main_portdir; + +my %dependencies; +my %forced; + +my $unquote = sub { + my $s = shift; + $s =~ s/^["']*//; + $s =~ s/["']*$//; + return $s; +}; + +my $format_available; + sub format_available { - for my $prog (qw/emerge ebuild/) { - unless (can_run($prog)) { - error "$prog is required to write ebuilds -- aborting"; - return 0; + return $format_available if defined $format_available; + + for my $prog (qw) { + unless (IPC::Cmd::can_run($prog)) { + __PACKAGE__->_abort("$prog is required to write ebuilds"); + return $format_available = 0; } } - return 1; + + if (IPC::Cmd->can_capture_buffer) { + my $buffers; + my ($success, $errmsg) = IPC::Cmd::run( + command => [ qw ], + verbose => 0, + buffer => \$buffers, + ); + if ($success) { + if ($buffers =~ /^PORTDIR_OVERLAY=(.*)$/m) { + $overlays = [ map Cwd::abs_path($_), split ' ', $unquote->($1) ]; + } + if ($buffers =~ /^ACCEPT_KEYWORDS=(.*)$/m) { + $default_keywords = [ split ' ', $unquote->($1) ]; + } + if ($buffers =~ /^DISTDIR=(.*)$/m) { + $default_distdir = Cwd::abs_path($unquote->($1)); + } + if ($buffers =~ /^PORTDIR=(.*)$/m) { + $main_portdir = Cwd::abs_path($unquote->($1)); + } + } else { + __PACKAGE__->_abort($errmsg); + return $format_available = 0; + } + } + + $default_keywords = [ 'x86' ] unless defined $default_keywords; + $default_distdir = '/usr/portage/distfiles' unless defined $default_distdir; + + return $format_available = 1; } sub init { @@ -70,10 +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 - deps eb_name eb_version eb_dir eb_file fetched_arch - 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')); @@ -81,18 +192,24 @@ sub init { return 1; } -my %gentooism = ( - 'Crypt-RSA' => 'crypt-rsa', - 'Digest' => 'digest-base', - 'Locale-Maketext' => 'locale-maketext', - 'Math-Pari' => 'math-pari', - 'Net-Ping' => 'net-ping', - 'PathTools' => 'File-Spec', - 'PodParser' => 'Pod-Parser', - 'Set-Scalar' => 'set-scalar', - 'Tie-EncryptedHash' => 'tie-encryptedhash', - 'YAML' => 'yaml', -); +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; @@ -103,28 +220,38 @@ sub prepare { my %opts = @_; - $stat->prepared(0); + 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'}; - $keywords = 'x86' unless defined $keywords; - $keywords = [ split ' ', $keywords ]; + my $keywords = delete $opts{keywords}; + if (defined $keywords) { + $keywords = [ split ' ', $keywords ]; + } else { + $keywords = $default_keywords; + } $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 { @@ -132,20 +259,29 @@ 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 : '/usr/portage/distfiles'; + my $distdir = delete $opts{distdir}; + $distdir = (defined $distdir) ? Cwd::abs_path($distdir) : $default_distdir; $stat->distdir($distdir); - if ($stat->do_manifest && !-w $stat->distdir) { - error 'distdir isn\'t writable -- aborting'; - return 0; - } + return $FAIL->("distdir isn't writable") if $stat->do_manifest && !-w $distdir; + $stat->fetched_arch($mod->status->fetch); + my $cur = File::Spec->curdir(); + my $portdir_overlay; + for (@$overlays) { + if ($_ eq $overlay or File::Spec->abs2rel($overlay, $_) eq $cur) { + $portdir_overlay = [ @$overlays ]; + last; + } + } + $portdir_overlay = [ @$overlays, $overlay ] unless $portdir_overlay; + $stat->portdir_overlay($portdir_overlay); + my $name = $mod->package_name; $stat->name($name); @@ -157,116 +293,333 @@ sub prepare { $stat->distribution($name . '-' . $version); - $version =~ s/[^\d._]+//g; - $version =~ s/^[._]*//; - $version =~ s/[._]*$//; - $version =~ s/[._]*_[._]*/_/g; - { - ($version, my $patch, my @rest) = split /_/, $version; - $version .= '_p' . $patch if defined $patch; - $version .= join('.', '', @rest) if @rest; - } - $stat->eb_version($version); - - $stat->eb_name($gentooism{$name} || $name); - - $stat->eb_dir(catdir($stat->overlay, CATEGORY, $stat->eb_name)); - - my $file = catfile($stat->eb_dir, - $stat->eb_name . '-' . $stat->eb_version . '.ebuild'); - if (-e $file) { - my $skip = 1; - if ($stat->force) { - if (-w $file) { - 1 while unlink $file; - $skip = 0; - } else { - error "Can't force rewriting of $file -- skipping"; + $stat->ebuild_version(CPANPLUS::Dist::Gentoo::Maps::version_c2g($name, $version)); + + $stat->ebuild_name(CPANPLUS::Dist::Gentoo::Maps::name_c2g($name)); + + $stat->ebuild_dir(File::Spec->catdir( + $stat->overlay, + CATEGORY, + $stat->ebuild_name, + )); + + my $file = File::Spec->catfile( + $stat->ebuild_dir, + $stat->ebuild_name . '-' . $stat->ebuild_version . '.ebuild', + ); + $stat->ebuild_file($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 { - msg 'Ebuild already generated for ' . $stat->distribution . ' -- skipping'; + 1 while unlink $file; } - if ($skip) { - $stat->prepared(1); - $stat->created(1); - return 1; + } else { + if (my $atom = $self->_cpan2portage($name, $version)) { + $stat->dist($atom->ebuild); + return $SKIP->('Ebuild already generated for', $stat->distribution); } } - $stat->eb_file($file); - $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 =~ /^(.)(.)/) { - error 'Wrong author name -- aborting'; - return 0; - } - $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); - unless ($obj) { - error 'Wrong module object -- aborting'; - return 0; - } - 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 , $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); - $stat->prepared(1); - return 1; + 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; - unless ($stat->prepared) { - error 'Can\'t create ' . $stat->distribution . ' since it was never prepared -- aborting'; + 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); - return 0; + $stat->dist(undef); + $self->_abort(@_) if @_; + 0; + }; + + unless ($stat->prepared) { + return $FAIL->( + 'Can\'t create', $stat->distribution, 'since it was never prepared' + ); } if ($stat->created) { - msg $stat->distribution . ' was already created -- skipping'; - return 1; + $self->_skip($stat->distribution, 'was already created'); + $file = $stat->dist; # Keep the existing one. + return $OK->(); + } + + my $dir = $stat->ebuild_dir; + unless (-d $dir) { + eval { File::Path::mkpath($dir) }; + return $FAIL->("mkpath($dir): $@") if $@; + } + + $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(@_); - my $dir = $stat->eb_dir; - unless (-d $dir) { - eval { mkpath $dir }; - if ($@) { - error "mkpath($dir): $@"; - return 0; + 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->(); +} + +=head2 C + +Updates the F file for the ebuild associated to the current dist object. + +=cut + +sub update_manifest { + my $self = shift; + my $stat = $self->status; + + my $file = $stat->ebuild_file; + unless (defined $file and -e $file) { + return $self->_abort('The ebuild file is invalid or does not exist'); + } + + unless (File::Copy::copy($stat->fetched_arch => $stat->distdir)) { + return $self->_abort("Couldn\'t copy the distribution file to distdir ($!)"); + } + + $self->_notify('Adding Manifest entry for', $stat->distribution); + + return $self->_run([ 'ebuild', $file, 'manifest' ], 0); +} + +=head2 C + +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 (@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"; $d .= 'MODULE_AUTHOR="' . $stat->author . "\"\ninherit perl-module\n\n"; @@ -277,48 +630,51 @@ sub create { $d .= "SLOT=\"0\"\n"; $d .= 'LICENSE="|| ( ' . join(' ', sort @{$stat->license}) . " )\"\n"; $d .= 'KEYWORDS="' . join(' ', sort @{$stat->keywords}) . "\"\n"; - $d .= 'DEPEND="' . join "\n", - 'dev-lang/perl', - map { - my $a = $_->[0]->package_name; - $a = $gentooism{$a} || $a; - my $x = ''; - if (defined $_->[1]) { - $x = '>='; - $a .= '-' . $_->[1]; - } - '|| ( ' . join(' ', map "$x$_/$a", - qw/perl-core dev-perl perl-gcpan/, CATEGORY) - . ' )'; - } @{$stat->deps}; - $d .= "\"\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; - my $file = $stat->eb_file; - open my $eb, '>', $file or do { - error "open($file): $! -- aborting"; - return 0; - }; - print $eb $d; - close $eb; + return $d; +} - if ($stat->do_manifest) { - unless (copy $stat->fetched_arch, $stat->distdir) { - error "Couldn\'t copy the distribution file to distdir ($!) -- aborting"; - 1 while unlink $file; - return 0; - } +sub _cpan2portage { + my ($self, $dist_name, $dist_version) = @_; - msg 'Adding Manifest entry for ' . $stat->distribution; - unless ($self->_run([ 'ebuild', $file, 'manifest' ], 0)) { - 1 while unlink $file; - return 0; + 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, CATEGORY) { + my $name = ($category eq 'virtual' ? 'perl-' : '') . $name; + + for my $portdir (@portdirs) { + my @ebuilds = glob File::Spec->catfile( + $portdir, + $category, + $name, + "$name-*.ebuild", + ) or next; + + 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, + ); } + } - $stat->created(1); - return 1; + return; } sub install { @@ -327,7 +683,7 @@ sub install { my $conf = $self->parent->parent->configure_object; my $sudo = $conf->get_program('sudo'); - my @cmd = ('emerge', '=' . $stat->eb_name . '-' . $stat->eb_version); + my @cmd = ('emerge', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version); unshift @cmd, $sudo if $sudo; my $success = $self->_run(\@cmd, 1); @@ -342,7 +698,7 @@ sub uninstall { my $conf = $self->parent->parent->configure_object; my $sudo = $conf->get_program('sudo'); - my @cmd = ('emerge', '-C', '=' . $stat->eb_name . '-' . $stat->eb_version); + my @cmd = ('emerge', '-C', '=' . $stat->ebuild_name . '-' . $stat->ebuild_version); unshift @cmd, $sudo if $sudo; my $success = $self->_run(\@cmd, 1); @@ -356,30 +712,51 @@ sub _run { my $stat = $self->status; my ($success, $errmsg, $output) = do { - local $ENV{PORTDIR_OVERLAY} = $stat->overlay; + 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) { - error "$errmsg -- aborting"; - if (not $verbose and defined $output and $self->status->verbose) { + $self->_abort($errmsg); + if (not $verbose and defined $output and $stat->verbose) { my $msg = join '', @$output; 1 while chomp $msg; - error $msg; + CPANPLUS::Error::error($msg); } } return $success; } +sub _abort { + my $self = shift; + + CPANPLUS::Error::error("@_ -- aborting"); + + return 0; +} + +sub _notify { + my $self = shift; + + CPANPLUS::Error::msg("@_"); + + return 1; +} + +sub _skip { shift->_notify(@_, '-- skipping') } + =head1 DEPENDENCIES Gentoo (L). -L, L (core modules since 5.9.5). +L, L (core modules since 5.9.5), L (since 5.10.1). -L (since perl 5) L (5.001), L (5.002), L (5.00504). +L, L (since perl 5), L (5.001), L (5.002), L (5.00405), L (5.007003). =head1 SEE ALSO @@ -395,7 +772,8 @@ You can contact me by mail or on C (vincent). =head1 BUGS -Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. +Please report any bugs or feature requests to C, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT @@ -405,13 +783,13 @@ You can find documentation for this module with the perldoc command. =head1 ACKNOWLEDGEMENTS -The module is to some extend cargo-culted from L and L. +The module was inspired by L and L. Kent Fredric, for testing and suggesting improvements. =head1 COPYRIGHT & LICENSE -Copyright 2008 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.