From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from pigeon.gentoo.org ([208.92.234.80] helo=lists.gentoo.org) by finch.gentoo.org with esmtp (Exim 4.60) (envelope-from ) id 1RImxe-0004Rv-40 for garchives@archives.gentoo.org; Tue, 25 Oct 2011 19:47:03 +0000 Received: from pigeon.gentoo.org (localhost [127.0.0.1]) by pigeon.gentoo.org (Postfix) with SMTP id 4800421C023; Tue, 25 Oct 2011 19:46:49 +0000 (UTC) Received: from smtp.gentoo.org (smtp.gentoo.org [140.211.166.183]) by pigeon.gentoo.org (Postfix) with ESMTP id 07EF521C023 for ; Tue, 25 Oct 2011 19:46:48 +0000 (UTC) Received: from pelican.gentoo.org (unknown [66.219.59.40]) (using TLSv1 with cipher AECDH-AES256-SHA (256/256 bits)) (No client certificate requested) by smtp.gentoo.org (Postfix) with ESMTPS id 4E1481B4022 for ; Tue, 25 Oct 2011 19:46:48 +0000 (UTC) Received: from localhost.localdomain (localhost [127.0.0.1]) by pelican.gentoo.org (Postfix) with ESMTP id 8777980042 for ; Tue, 25 Oct 2011 19:46:47 +0000 (UTC) From: "Kent Fredric" To: gentoo-commits@lists.gentoo.org Content-type: text/plain; charset=UTF-8 Reply-To: gentoo-dev@lists.gentoo.org, "Kent Fredric" Message-ID: <855a4532db432147fefd7dccad97e1ec75f9abe2.kent@gentoo> Subject: [gentoo-commits] proj/perl-overlay:master commit in: scripts/lib/ X-VCS-Repository: proj/perl-overlay X-VCS-Files: scripts/lib/metacpan.pm X-VCS-Directories: scripts/lib/ X-VCS-Committer: kent X-VCS-Committer-Name: Kent Fredric X-VCS-Revision: 855a4532db432147fefd7dccad97e1ec75f9abe2 Date: Tue, 25 Oct 2011 19:46:47 +0000 (UTC) Precedence: bulk List-Post: List-Help: List-Unsubscribe: List-Subscribe: List-Id: Gentoo Linux mail X-BeenThere: gentoo-commits@lists.gentoo.org Content-Transfer-Encoding: quoted-printable X-Archives-Salt: X-Archives-Hash: 93baace3ada5a4799cd99fb2a358388a commit: 855a4532db432147fefd7dccad97e1ec75f9abe2 Author: Kent Fredric gmail com> AuthorDate: Tue Oct 25 13:40:46 2011 +0000 Commit: Kent Fredric gmail com> CommitDate: Tue Oct 25 19:44:43 2011 +0000 URL: http://git.overlays.gentoo.org/gitweb/?p=3Dproj/perl-overlay.= git;a=3Dcommit;h=3D855a4532 [scripts/lib/metacpan.pm] add interesting reverse lookup code --- scripts/lib/metacpan.pm | 121 +++++++++++++++++++++++++++++++++++++----= ----- 1 files changed, 97 insertions(+), 24 deletions(-) diff --git a/scripts/lib/metacpan.pm b/scripts/lib/metacpan.pm index f80d7db..cb02681 100644 --- a/scripts/lib/metacpan.pm +++ b/scripts/lib/metacpan.pm @@ -8,33 +8,106 @@ use warnings; package metacpan; use File::Spec; =20 -use Sub::Exporter -setup =3D> { exports =3D> [ mcpan =3D> \&build_mcpan = ], }; - -sub build_mcpan { - my $mcpan; - return sub { - $mcpan ||=3D do { - require CHI; - my $cache =3D CHI->new( - driver =3D> 'File', - root_dir =3D> File::Spec->catdir( File::Spec->tmpdir, 'gentoo-me= tacpan-cache' ), - ); - require WWW::Mechanize::Cached; - my $mech =3D WWW::Mechanize::Cached->new( - cache =3D> $cache, - timeout =3D> 20000, - autocheck =3D> 1, - ); - require HTTP::Tiny::Mech; - my $tinymech =3D HTTP::Tiny::Mech->new( mechua =3D> $mech ); - require MetaCPAN::API; - - MetaCPAN::API->new( ua =3D> $tinymech ); +use Sub::Exporter -setup =3D> { exports =3D> ['mcpan'], }; =20 - }; - return $mcpan; +my $mcpan; + +sub mcpan { + $mcpan ||=3D do { + require CHI; + my $cache =3D CHI->new( + driver =3D> 'File', + root_dir =3D> File::Spec->catdir( File::Spec->tmpdir, 'gentoo-meta= cpan-cache' ), + ); + require WWW::Mechanize::Cached; + my $mech =3D WWW::Mechanize::Cached->new( + cache =3D> $cache, + timeout =3D> 20000, + autocheck =3D> 1, + ); + require HTTP::Tiny::Mech; + my $tinymech =3D HTTP::Tiny::Mech->new( mechua =3D> $mech ); + require MetaCPAN::API; + + MetaCPAN::API->new( ua =3D> $tinymech ); + } +} + +sub find_dist_all { + my ( $class, $module, $opts ) =3D @_; + + my @wanted_terms =3D ( + { term =3D> { 'file.module.authorized' =3D> 1 } }, + { term =3D> { 'file.module.indexed' =3D> 1 } }, + { term =3D> { 'file.module.name' =3D> $module } }, + ); + + my @unwanted_terms =3D ( { terms =3D> { 'file.distribution' =3D> [qw( = libwww-perl HTTP-Message )] } } ); + + my $simple_filter =3D { bool =3D> { must =3D> [@wanted_terms] } }; + my $nested_filer =3D { + nested =3D> { + path =3D> 'file.module', + query =3D> { bool =3D> { must =3D> [@wanted_terms] } }, + } + }; + + my $query_nondirs =3D { term =3D> { directory =3D> 0 } }; + my $fields =3D [ + 'status', 'date', 'author', 'maturity', 'in= dexed', 'documentation', + 'id', '_source.module', 'authorized', 'release_id', 've= rsion', 'name', + 'release', 'path', 'version_numified', '_source.stat', 'di= stribution', 'level', + 'sloc', 'abstract', 'slop', 'mime' + ]; =20 + my $q =3D { + query =3D> $query_nondirs, + filter =3D> $simple_filter, + fields =3D> $fields, + sort =3D> { 'file.date' =3D> 'desc' }, + size =3D> 9999, }; + + if ( $opts->{mangle} ) { + $opts->{mangle}->( $q, ); + } + + my $results =3D mcpan->post( file =3D> $q ); + + if ( not $opts->{notrim} ) { + $results->{hits}->{hits} =3D [ grep { _skip_result( $_, $module ) } = @{ $results->{hits}->{hits} } ]; + } + + return map { $_->{fields} } @{ $results->{hits}->{hits} }; + + +} +use Data::Dump qw( pp ); +sub find_dist_simple { + my ( $class, $module, $opts ) =3D @_; + return map { + my $i =3D $_; + my ( $j ) =3D grep { $_->{name} eq $module } @{ $i->{'_source.module= '} }; + my $x =3D { + %{$i}, + mod_path =3D> ( sprintf q{%s/%s/%s}, $i->{author}, $i->{release}, = $i->{path} ), + mod =3D> [ $j->{name}, $j->{version} ], + }; + $x->{as_string} =3D $j->{name} . ' ' . ($j->{version}//'') . ' in ' = . $x->{mod_path}; + $x; + } $class->find_dist_all( $module, $opts ); +} + +sub _skip_result { + my ( $result, $module ) =3D @_; + return 1 if not $result->{fields}; + return 1 if not $result->{fields}->{'_source.module'}; + for my $package ( @{ $result->{fields}->{'_source.module'} } ) { + return + if $package->{name} eq $module + and ( ( not $package->{authorized} ) or ( not $package->{indexed= } ) ); + } + return 1; } =20 1;