From: Vincent Pit Date: Sun, 19 Sep 2010 22:40:27 +0000 (+0200) Subject: Correctly map exotic Gentoo versions from CPAN versions X-Git-Tag: v0.11~15 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FCPANPLUS-Dist-Gentoo.git;a=commitdiff_plain;h=b43c3fc0fe6291fc7aa4c97c48fe0e29d312c071 Correctly map exotic Gentoo versions from CPAN versions Also improve greatly the gentooisms discovery. --- diff --git a/.gitignore b/.gitignore index 6be9f28..4b44dd6 100644 --- a/.gitignore +++ b/.gitignore @@ -24,4 +24,5 @@ cover_db Debian_CPANTS.txt +gentooisms.sto lib/CPANPLUS/Dist/Gentoo/Maps.pm.bak diff --git a/Makefile.PL b/Makefile.PL index 2aa77dd..e5a8c96 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -61,3 +61,12 @@ WriteMakefile( FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt" }, ); + +package MY; + +sub postamble { + <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)); @@ -366,7 +366,7 @@ sub prepare { my $meta = $self->meta; $stat->min_perl(CPANPLUS::Dist::Gentoo::Maps::perl_version_c2g( - $meta->{requires}->{perl} + $meta->{requires}->{perl}, )); return $OK->(); @@ -595,10 +595,10 @@ sub ebuild_source { } sub _cpan2portage { - my ($self, $name, $version) = @_; + my ($self, $dist_name, $dist_version) = @_; - $name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($name); - $version = CPANPLUS::Dist::Gentoo::Maps::version_c2g($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}); diff --git a/lib/CPANPLUS/Dist/Gentoo/Maps.pm b/lib/CPANPLUS/Dist/Gentoo/Maps.pm index 1aa7d85..0cb1af2 100644 --- a/lib/CPANPLUS/Dist/Gentoo/Maps.pm +++ b/lib/CPANPLUS/Dist/Gentoo/Maps.pm @@ -21,9 +21,9 @@ This is an helper package to L. =cut -our %gentooisms; +my %name_mismatch; -/^\s*([\w-]+)\s+([\w-]+)\s*$/ and $gentooisms{$1} = $2 while ; +/^\s*([\w-]+)\s+([\w-]+)\s*$/ and $name_mismatch{$1} = $2 while ; close DATA; @@ -37,7 +37,7 @@ Maps a CPAN distribution name to its Gentoo counterpart. sub name_c2g { my ($name) = @_; - return $gentooisms{$name} || $name; + return $name_mismatch{$name} || $name; } =head2 C @@ -70,29 +70,187 @@ sub license_c2g { grep !$seen{$_}++, map @{$licenses{+lc} || []}, @_; } -=head2 C +=head2 C -Converts a CPAN version to a Gentoo version. +Converts the C<$version> of a CPAN distribution C<$name> to a Gentoo version. =cut -sub version_c2g { +my $default_mapping = sub { my ($v) = @_; - return unless defined $v; - + $v =~ s/^v//; $v =~ y/-/_/; - $v =~ y/0-9._//cd; $v =~ s/^[._]*//; $v =~ s/[._]*$//; $v =~ s/([._])[._]*/$1/g; - ($v, my $patch, my @rest) = split /_/, $v; - $v .= '_p' . $patch if defined $patch; - $v .= join('.', '', @rest) if @rest; + ($v, my $patch) = split /_/, $v, 2; + if (defined $patch) { + $patch =~ s/_//g; + $v .= "_p$patch"; + } return $v; +}; + +my $insert_dot_at = sub { + my ($v, $pos, $all) = @_; + + my ($int, $frac) = split /\./, $v, 2; + return $v unless defined $frac; + + my @p; + push @p, $-[0] while $frac =~ /[0-9]/g; + my %digit = map { $_ => 1 } @p; + + my $shift = 0; + for (my $i = $pos; $i < @p; $i += $pos) { + if ($digit{$i}) { + substr($frac, $i + $shift, 0) = '.'; + ++$shift; + } + last unless $all; + } + + "$int.$frac"; +}; + +my $insert_dot_at_1 = sub { $insert_dot_at->($_[0], 1, 0) }, +my $insert_dot_at_all_1 = sub { $insert_dot_at->($_[0], 1, 1) }, +my $insert_dot_at_2 = sub { $insert_dot_at->($_[0], 2, 0) }, +my $insert_dot_at_all_2 = sub { $insert_dot_at->($_[0], 2, 1) }, +my $insert_dot_at_all_3 = sub { $insert_dot_at->($_[0], 3, 1) }, + +my $pad_decimals_to = sub { + my ($v, $n) = @_; + + my ($int, $frac) = split /\./, $v, 2; + return $v unless defined $v; + + my $l = length $frac; + if ($l < $n) { + $frac .= '0' x ($n - $l); + } + + "$int.$frac"; +}; + +my $pad_decimals_to_2 = sub { $pad_decimals_to->($_[0], 2) }; +my $pad_decimals_to_4 = sub { $pad_decimals_to->($_[0], 4) }; + +my $correct_suffixes = sub { + my ($v) = @_; + + $v = $default_mapping->($v); + $v =~ s/(?($v); + $v =~ s/(?<=\d)[a-z]+//g; + + return $v; +}; + +my $letters_as_suffix = sub { + my ($v) = @_; + + $v = $default_mapping->($v); + $v =~ s/(?<=\d)b(?=\d)/_beta/g; + + return $v; +}; + +my %version_mismatch; + +$version_mismatch{$_} = $insert_dot_at_1 for qw/ + CGI-Simple +/; + +$version_mismatch{$_} = $insert_dot_at_all_1 for qw/ + AnyEvent + Archive-Rar + IO-AIO + Image-Size + Linux-Inotify2 + PadWalker + Tie-Array-Sorted + Tk-TableMatrix + XML-RSS-Feed +/; + +$version_mismatch{$_} = $insert_dot_at_2 for qw/ + Error +/; + +$version_mismatch{$_} = $insert_dot_at_all_2 for qw/ + Authen-Htpasswd + BSD-Resource + CDDB + Cairo + Curses-UI + DBD-mysql + Email-MessageID + ExtUtils-CBuilder + ExtUtils-ParseXS + FileHandle-Unget + FreezeThaw + Lexical-Persistence + Lingua-EN-Inflect + Mail-Mbox-MessageParser + Module-Build + SQL-Abstract-Limit + Term-ReadLine-Perl + Test-Differences + Time-HiRes + Time-Local + perl-ldap +/; + +$version_mismatch{$_} = $insert_dot_at_all_3 for qw/ + Parse-RecDescent + Return-Value +/; + +$version_mismatch{$_} = $pad_decimals_to_2 for qw/ + Nmap-Parser + XML-AutoWriter +/; + +$version_mismatch{$_} = $pad_decimals_to_4 for qw/ + Convert-BER +/; + +$version_mismatch{$_} = $correct_suffixes for qw/ + Gimp + XML-Grove +/; + +$version_mismatch{$_} = $strip_letters for qw/ + DelimMatch + SGMLSpm +/; + +$version_mismatch{$_} = $letters_as_suffix for qw/ + Frontier-RPC +/; + +sub version_c2g { + my ($n, $v) = @_; + + return unless defined $v; + + my $handler; + $handler = $version_mismatch{$n} if defined $n; + $handler = $default_mapping unless defined $handler; + + return $handler->($v); } =head2 C @@ -154,8 +312,9 @@ This program is free software; you can redistribute it and/or modify it under th __DATA__ ANSIColor Term-ANSIColor AcePerl Ace -Audio-CD Audio-CD-disc-cover CGI-Simple Cgi-Simple +CGI-SpeedyCGI SpeedyCGI +CPAN-Mini-Phalanx100 CPAN-Mini-Phalanx Cache-Mmap cache-mmap Class-Loader class-loader Class-ReturnValue class-returnvalue @@ -181,6 +340,7 @@ ExtUtils-PkgConfig extutils-pkgconfig Frontier-RPC frontier-rpc Gimp gimp-perl Glib glib-perl +Gnome2 gnome2-perl Gnome2-Canvas gnome2-canvas Gnome2-GConf gnome2-gconf Gnome2-Print gnome2-print diff --git a/samples/gengentooisms b/samples/gengentooisms index ca69b23..74a46e9 100755 --- a/samples/gengentooisms +++ b/samples/gengentooisms @@ -1,93 +1,248 @@ #!/usr/bin/env perl -# This scrit is meant to guess gentooisms by looking into the portage tree. -# A really good one would use the CPANPLUS API to check if the dist name -# candidates are really on CPAN. - use strict; use warnings; use Fatal; -use Cwd qw/cwd/; -use List::Util qw/max/; +use File::Spec; use File::Copy qw/copy/; +use List::Util qw/max reduce/; +use Storable (); +use Term::ANSIColor; -use constant PORTAGE => '/usr/portage'; -use constant TARGET => 'lib/CPANPLUS/Dist/Gentoo/Maps.pm'; -use constant BACKUP => TARGET . '.bak'; +use CPAN::DistnameInfo; +use Capture::Tiny qw/capture/; +use LWP::UserAgent; +use Parse::CPAN::Packages::Fast; -my %gentooism; +use lib 'lib'; +use CPANPLUS::Dist::Gentoo::Atom; +use CPANPLUS::Dist::Gentoo::Maps; -my %where = ( - 'Audio-CD-disc-cover' => 1, - 'aww' => 0, - 'frontier-rpc' => 1, - 'gimp-perl' => 1, - 'gnome2-wnck' => 1, - 'HTML-Object' => 0, - 'JKFlow' => 0, - 'PDF-Create' => 0, +use constant PACKAGES => File::Spec->catdir( + $ENV{HOME}, '.cpanplus', '02packages.details.txt.gz' ); +use constant CPAN_MIRROR => 'http://www.cpan.org/'; +use constant PORTAGE => '/usr/portage'; +use constant TARGET => 'lib/CPANPLUS/Dist/Gentoo/Maps.pm'; +use constant BACKUP => TARGET . '.bak'; +use constant STATE_FILE => 'gentooisms.sto'; -my $cwd = cwd(); - -for my $category (qw/perl-core dev-perl/) { - my $dir = PORTAGE . '/' . $category; - chdir $dir; - for my $name (<*>) { - next unless -d $name; - my $eb = (sort glob "$dir/$name/$name-*")[-1]; - open my $fh, '<', $eb; - my ($pn, $on_cpan); - $on_cpan = $where{$name} if exists $where{$name}; - while (<$fh>) { - $on_cpan = 1 if not defined $on_cpan - and /(?:MODULE_AUTHOR|SRC_URI=.*?(?i:cpan))/; - if (not defined $pn and /_PN?=(.*)/) { - $pn = $1; - if ($pn =~ /^\s*["']?\s*\$\{PN?\}/) { - undef $pn; - next; +my %gentooism; + +my %is_on_cpan = map { $_ => 1 } qw/ + Business-FedEx-DirectConnect + CDDB_get + CursesWidgets + SpeedyCGI + WattsUp-Daemon + frontier-rpc + gnome2-perl + gnome2-wnck +/; + +sub p { + my ($indent, $fmt, @args) = @_; + $fmt = (' ' x ($indent * 3)) . $fmt; + printf $fmt, @args; +} + +my (@not_on_cpan, %name_mismatch, %version); + +sub parse_portage_tree { + my $pcp = Parse::CPAN::Packages::Fast->new(PACKAGES); + + my $ua = LWP::UserAgent->new; + $ua->agent('CPANPLUS::Dist::Gentoo gentooisms generator/1.0'); + + for my $category (qw/perl-core dev-perl/) { + p(0, "Browsing the $category category.\n"); + + my $cat_dir = File::Spec->catdir(PORTAGE, $category); + + for my $pkg_dir (glob File::Spec->catdir($cat_dir, '*')) { + next unless -d $pkg_dir; + + my $pkg_name = (File::Spec->splitdir($pkg_dir))[-1]; + + my $last = reduce { $a->[1] > $b->[1] ? $a : $b } + map [ $_, CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($_) ], + glob File::Spec->catfile($pkg_dir, "$pkg_name-*"); + my ($ebuild, $atom) = @$last; + p(1, "%s/%s-%s\n", map $atom->$_, qw/category name version/); + + my @cmd = ('ebuild', $ebuild, 'help', '--debug'); + my ($ret, $code); + (undef, my $err) = capture { + $ret = system { $cmd[0] } @cmd; + $code = $?; + }; + if ($ret != 0 or $code == -1 or $code & 127 or $code >> 8) { + die "system(\"@cmd\") returned $ret and/or failed with status $code"; + } + + my ($uri, $fqn_dist, $path); + while ($err =~ /SRC_URI=((['"]).*?\2|\S+)/gs) { + $uri = $1; + $uri =~ s{^(['"])(.*?)\1$}{$2}s; + } + if (defined $uri) { + if ($uri =~ m{cpan.*?/id/(\S+)}) { + $fqn_dist = $1; + $path = "authors/id/$fqn_dist"; + } elsif ($uri =~ m{mirror://cpan/(\S+)}) { + $path = $1; + } elsif ($is_on_cpan{$pkg_name} and $uri =~ m{/([^/\s]+)(?:\s|$)}) { + my $archive = $1; + my ($top_level) = $archive =~ /^([^-]+)/; + $path = "modules/by-module/$top_level/$archive"; } - $pn =~ s!\$[{(][^/]*?[})]!!g; - $pn =~ s!\$\{P?V.*?\}!!g; - $pn =~ s/^\s*["']?\s*-*\s*//; - $pn =~ s/\s*-*\s*["']?\s*$//; - $pn =~ s/-\d+\..*//; - if ($pn =~ m!\$\{PN?(/.*?/(?:.*/?)?)\}!) { - my $s = $1; - $s .= '/' if $s =~ tr!/!! <= 2; - eval "(\$pn = \$name) =~ s$s"; + } + + unless (defined $path) { + p(2, "doesn't seem to be fetching its tarball from a CPAN mirror.\n"); + p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n"); + push @not_on_cpan, "$category/$pkg_name"; + next; + } + p(2, "fetches $path\n"); + + my $dist; + if (defined $fqn_dist) { + $dist = eval { $pcp->distribution($fqn_dist) }; + p(2, defined $dist ? "is indexed on the CPAN\n" : 'is not indexed, but '); + } else { + p(2, 'is '); + } + unless (defined $dist) { + print 'maybe on a CPAN mirror... '; + my $r = $ua->head(CPAN_MIRROR . $path); + if ($r and $r->code == 200) { + print "yes\n"; + } else { + print "no\n"; + p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n"); + push @not_on_cpan, "$category/$pkg_name"; + next; } + $dist = CPAN::DistnameInfo->new($path); } - } - if ($pn and $pn ne $name) { - if ($on_cpan) { - $gentooism{$pn} = $name; - } elsif (not defined $on_cpan) { - print STDERR "'$pn' => '$name' may not be on CPAN\n"; + + my $dist_name = $dist->dist; + if ($dist_name ne $pkg_name) { + p(2, colored("$dist_name => $pkg_name", 'bright_yellow') . "\n"); + $name_mismatch{$dist_name} = $pkg_name; + } + + my $pkg_version = $atom->version . ''; + $pkg_version =~ s/-r\d+$//; + my $dist_version = $dist->version; + my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g( + undef, # default conversion + $dist_version, + ); + if ($mapped_version ne $pkg_version) { + my $str = "$dist_version => $mapped_version != $pkg_version"; + p(2, colored($str, 'bright_cyan') . "\n"); } + $version{$dist_name} = [ $dist_version => $pkg_version ]; } } } -chdir $cwd; +sub timestamp { + my $tm = File::Spec->catfile(PORTAGE, 'metadata', 'timestamp.chk'); + return unless -e $tm; + open my $fh, '<', $tm; + local $/; + <$fh>; +} + +my $already_parsed = 0; +my $timestamp = timestamp(); + +if (-e STATE_FILE) { + my $data = Storable::retrieve(STATE_FILE); + if ($data->[0] eq $timestamp) { + printf "Data retrieved from %s\n", STATE_FILE; + @not_on_cpan = @{ $data->[1] }; + %name_mismatch = %{ $data->[2] }; + %version = %{ $data->[3] }; + $already_parsed = 1; + } else { + printf "Obsolete data file %s, regenerating data\n", STATE_FILE; + 1 while unlink STATE_FILE; + } +} + +unless ($already_parsed) { + parse_portage_tree(); + print "\n"; + Storable::store([ + $timestamp, + \@not_on_cpan, + \%name_mismatch, + \%version, + ] => STATE_FILE); + printf "Data stored to %s\n", STATE_FILE; +} + +print "\n"; +p(0, "Summary\n"); + +p(1, "Not on the CPAN:\n"); +p(2, "$_\n") for @not_on_cpan; + +p(1, "Name mismatch:\n"); +for my $dist_name (sort keys %name_mismatch) { + my $pkg_name = $name_mismatch{$dist_name}; + my $mapped_name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name); + + my $fixed = $mapped_name eq $pkg_name; + my $eq = $fixed ? '==' : '!='; + my $str = colored( + "$dist_name => $mapped_name $eq $pkg_name", + $fixed ? 'bright_green' : 'bright_red' + ); + p(2, "$str\n"); +} + +p(1, "Version mismatch:\n"); +for (sort keys %version) { + my ($dist_version, $pkg_version) = @{$version{$_}}; + my $default_mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g( + undef, + $dist_version, + ); + my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g( + $_, + $dist_version, + ); + if ($default_mapped_version ne $pkg_version) { + my $fixed = $mapped_version eq $pkg_version; + my $eq = $fixed ? '==' : '!='; + my $str = colored( + "$dist_version => $mapped_version $eq $pkg_version", + $fixed ? 'bright_green' : 'bright_red' + ); + p(2, "$_: $str\n"); + } +} copy TARGET, BACKUP or die "copy failed: $!"; open my $src, '<', BACKUP; open my $dst, '>', TARGET; -my $max = max map length, keys %gentooism; +my $max = max map length, keys %name_mismatch; SRC: while (<$src>) { print $dst $_; if (/^__DATA__$/) { - printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $gentooism{$_} - for sort keys %gentooism; + printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $name_mismatch{$_} + for sort keys %name_mismatch; last SRC; } } -print STDERR +(keys %gentooism) . " gentooisms found\n"; - +print "\n" . +(keys %name_mismatch) . " name mismatches found\n"; diff --git a/t/11-maps-name.t b/t/11-maps-name.t index 884c61f..ca48370 100644 --- a/t/11-maps-name.t +++ b/t/11-maps-name.t @@ -3,17 +3,40 @@ use strict; use warnings; -use Test::More tests => 4; +use Test::More tests => 1 + 7 + 9; use CPANPLUS::Dist::Gentoo::Maps; -our %gentooisms; -*gentooisms = \%CPANPLUS::Dist::Gentoo::Maps::gentooisms; - -is scalar(keys %gentooisms), 76, 'gentooisms are all there'; - -is $gentooisms{PathTools}, 'File-Spec', 'gentooisms were correctly loaded'; - -is CPANPLUS::Dist::Gentoo::Maps::name_c2g('PathTools'), 'File-Spec', 'name_c2g maps gentooisms correctly'; - -is CPANPLUS::Dist::Gentoo::Maps::name_c2g('CPANPLUS-Dist-Gentoo'), 'CPANPLUS-Dist-Gentoo', 'name_c2g returns non gentooisms correctly'; +*nc2g = \&CPANPLUS::Dist::Gentoo::Maps::name_c2g; + +is nc2g('CPANPLUS-Dist-Gentoo'), 'CPANPLUS-Dist-Gentoo', 'name_c2g returns non gentooisms correctly'; + +my %core_gentooisms = ( + 'ANSIColor' => 'Term-ANSIColor', + 'Digest' => 'digest-base', + 'I18N-LangTags' => 'i18n-langtags', + 'Locale-Maketext' => 'locale-maketext', + 'Net-Ping' => 'net-ping', + 'Pod-Parser' => 'PodParser', + 'PathTools' => 'File-Spec', +); + +for my $dist (sort keys %core_gentooisms) { + is nc2g($dist), $core_gentooisms{$dist}, "name_c2g('$dist')"; +} + +my %cpan_gentooisms = ( + 'CGI-Simple' => 'Cgi-Simple', + 'Date-Manip' => 'DateManip', + 'Gtk2' => 'gtk2-perl', + 'Log-Dispatch' => 'log-dispatch', + 'Math-Pari' => 'math-pari', + 'Regexp-Common' => 'regexp-common', + 'Tk' => 'perl-tk', + 'Wx' => 'wxperl', + 'YAML' => 'yaml', +); + +for my $dist (sort keys %cpan_gentooisms) { + is nc2g($dist), $cpan_gentooisms{$dist}, "name_c2g('$dist')"; +} diff --git a/t/12-maps-version.t b/t/12-maps-version.t index 13586ce..da28c32 100644 --- a/t/12-maps-version.t +++ b/t/12-maps-version.t @@ -3,22 +3,39 @@ use strict; use warnings; -use Test::More tests => 10 + 7; +use Test::More tests => 11 + 2 * 5 + 7; use CPANPLUS::Dist::Gentoo::Maps; -*vc2g = \&CPANPLUS::Dist::Gentoo::Maps::version_c2g; +*vc2g = sub { + unshift @_, undef if @_ == 1; + goto &CPANPLUS::Dist::Gentoo::Maps::version_c2g +}; is vc2g('1'), '1', "version_c2g('1')"; -is vc2g('a1b'), '1', "version_c2g('a1b')"; +is vc2g('v1'), '1', "version_c2g('v1')"; is vc2g('..1'), '1', "version_c2g('..1')"; is vc2g('1.0'), '1.0', "version_c2g('1.0')"; +is vc2g('v1.0'), '1.0', "version_c2g('v1.0')"; is vc2g('1._0'), '1.0', "version_c2g('1._0')"; is vc2g('1_1'), '1_p1', "version_c2g('1_1')"; is vc2g('1_.1'), '1_p1', "version_c2g('1_.1')"; is vc2g('1_.1._2'), '1_p1.2', "version_c2g('1_.1._2')"; -is vc2g('1_.1_2'), '1_p1.2', "version_c2g('1_.1_2')"; -is vc2g('1_.1_.2'), '1_p1.2', "version_c2g('1_.1_.2')"; +is vc2g('1_.1_2'), '1_p12', "version_c2g('1_.1_2')"; +is vc2g('1_.1_.2'), '1_p12', "version_c2g('1_.1_.2')"; + +for my $test ([ '0.12' => '0.12' ], [ '0.1234' => '0.12.34' ]) { + my @dists = qw/ + ExtUtils-CBuilder + ExtUtils-ParseXS + Module-Build + Time-HiRes + Time-Local + /; + for my $dist (@dists) { + is vc2g($dist, $test->[0]), $test->[1], "'version_c2g('$dist', '$test->[0]')"; + } +} *pvc2g = \&CPANPLUS::Dist::Gentoo::Maps::perl_version_c2g;