* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; 9+ messages in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: a0cc3228fccccb38c3c5f08c418fdd53dc567818
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Thu Oct 27 19:24:00 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 31 02:45:47 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=a0cc3228
Finally looking like a little progress is being made on generating dependencies
---
scripts/gen_ebuild.pl | 178 +++++++++++++++++++++++++++++++++++++++++++++-
scripts/lib/metacpan.pm | 67 +++++++++++++++++-
2 files changed, 240 insertions(+), 5 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 0d0fa06..1623bb8 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -10,6 +10,9 @@ use FindBin;
use lib "$FindBin::Bin/lib";
use env::gentoo::perl_experimental;
use metacpan qw( mcpan );
+use utf8;
+use Gentoo::PerlMod::Version qw( gentooize_version );
+use Text::Wrap;
my $flags;
my $singleflags;
@@ -36,12 +39,179 @@ if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
# emits Moose/Moose-2.30.100_rc.ebuild
my ($release) = shift(@ARGV);
-my $result = [ map { $_->{as_string} } metacpan->find_dist_simple( $release , {notrim=>1}) ];
+*STDOUT->binmode(':utf8');
+*STDERR->binmode(':utf8');
+
+my %phases;
+my %modules;
+my %providers;
+
+my $dep_phases = get_dep_phases( $release );
+%phases = %{ $dep_phases->{phases} };
+%modules = %{ $dep_phases->{modules} };
use Data::Dump qw( pp );
-use JSON qw( to_json );
-say to_json($result , { pretty => 1 } );
-1;
+use JSON qw( to_json encode_json );
+
+sub provider_map {
+ my ( $module ) = shift;
+ my @providers = metacpan->find_dist_simple( $module );
+ my %moduleprov;
+
+ for my $provider ( @providers ) {
+
+ next if $provider->{status} eq 'backpan';
+ next if $provider->{maturity} eq 'developer';
+# pp $provider;
+
+ my $dist = $provider->{distribution};
+ my $distv = $provider->{version} // 'undef';
+ $moduleprov{$dist} //= [];
+ my @provided_matching_mods;
+ for my $mod ( @{ $provider->{'_source.module' } } ) {
+ next unless $mod->{name} eq $module;
+ my $modv = $mod->{version} // 'undef';
+ my $dv = $distv;
+ if( $distv ne $modv ) {
+ $dv = $distv . " => " . '"' . $modv . '"';
+ }
+ push @provided_matching_mods, $dv
+ if $mod->{name} eq $module;
+ }
+ push @{ $moduleprov{$dist} }, @provided_matching_mods;
+ }
+ return \%moduleprov;
+}
+for my $module ( keys %modules ) {
+ for my $declaration ( @{ $modules{$module} } ) {
+
+ my $depstring = $module;
+ if ( $declaration->[1] ne '0.0.0' ) {
+ $depstring .= " " . $declaration->[0] . " ( " . $declaration->[1] . " ) " ;
+ }
+
+ my $want_string = "$release -> " . $declaration->[2] . " " . $declaration->[3] . " " . $depstring;
+
+
+ my %moduleprov = %{ provider_map( $module ) };
+
+ my $pc = scalar keys %moduleprov;
+
+ my $multi = ( $pc > 1 );
+ my $any = ( $pc > 0 );
+
+ *STDERR->printf("\e[1;93m%s\e[0m\n", $want_string );
+
+
+
+ if ( not $any ) {
+ *STDERR->printf("%sWARNING: NO PROVIDER FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
+ next;
+ }
+ if( $multi ){
+ *STDERR->printf("%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
+ }
+
+ for my $prov ( keys %moduleprov ) {
+ my $prefix = $depstring . ' in ' . $prov;
+ my $lines = xwrap( join q[, ], @{$moduleprov{ $prov } } );
+ my ( @slines ) = split /$/m , $lines;
+ $_ =~ s/[\r\n]*//m for @slines;
+ *STDERR->printf(" %s%s -> %s%s\n", "\e[1;92m", $depstring, "\e[0m\e[92m" ,$prov);
+ for ( @slines ) {
+ *STDERR->print(" \e[1;91m*") if $multi;
+ *STDERR->print(" \e[1;92m*") if not $multi;
+
+ *STDERR->printf(" %s%s -> %s%s\n", "\e[1;94m", $prov , "\e[0m\e[94m", $_ );
+ }
+ }
+ if ( $multi ){
+ *STDERR->print(" \e[1;91m-\n\n");
+ } else {
+ *STDERR->print(" \e[1;92m-\n\n");
+ }
+
+# my ( $prov ) = ( keys %moduleprov );
+# my $prefix = $want_string.q{/}.$prov;
+ #
+# *STDERR->printf("%s -> %s [ \n%s\n] \n", $want_string, $prov, clines("\e[39m", "\e[96m$prefix\e[0m", xwrap( join q[, ], @{$moduleprov{$prov}} ) ));
+# } else {
+# *STDERR->printf("\n%s -> \e[31mMULTIPLE CHOICE: [\e[0m\n", $module);
+# for my $prov ( keys %moduleprov ) {
+# my $prefix = "\e[94m$want_string/$prov\e[0m";
+# *STDERR->printf(" %s -> \e[31m%s \e[0m[\n%s\n]\n", $want_string, $prov, clines("\e[32m",$prefix, xwrap(join q[, ], @{$moduleprov{$prov}})) );
+# }
+# *STDERR->print("\e[31m]\e[0m\n");
+
+# }
+# *STDERR->printf("%s -> %s\n", $module, $providers{$module}->[0]->{as_string} );
+ #push @{ $modules{$module}->[0] }, $providers{$module}->[0]->{as_string};
+}}
+
+use Data::Dump qw( pp );
+use JSON qw( to_json encode_json );
+#say pp( \%modules,);# { pretty => 1 } );
+exit 1;
+
+sub xwrap {
+ local $Text::Wrap::break = qr/,/;
+ local $Text::Wrap::overflow = 'huge';
+ local $Text::Wrap::columns = 128;
+ $Text::Wrap::overflow = 'huge';
+ my $pre = " ";
+ my $lines = wrap( $pre , $pre, @_ );
+ return $lines;
+}
+sub clines {
+ my ( $c, $prefix , $lines ) = @_ ;
+ $lines =~ s/^/$prefix>>$c/mg;
+ $lines =~ s/$/\e[0m/mg;
+ return $lines;
+}
+
+sub get_dep_phases {
+ my ( $release ) = shift;
+ my %phases;
+ my %modules;
+ my ( $result, ) = get_deps($release);
+ for my $dep ( @{ $result->{dependency} } ) {
+ my $phase = $dep->{phase};
+ my $module = $dep->{module};
+ my $required = ( $dep->{relationship} eq 'requires' );
+
+ next unless $required;
+ next if $phase eq 'develop';
+
+ $phases{$phase} //= [];
+ $modules{$module} //= [];
+
+ my $v = gentooize_version( $dep->{version}, { lax => 1 } );
+
+ push @{ $phases{$phase} }, [ $dep->{module} , $dep->{version} , $v, $dep->{relationship} ];
+ push @{ $modules{$module} }, [ $dep->{version}, $v, $dep->{phase} , $dep->{relationship} ];
+ }
+ return { phases => \%phases, modules => \%modules };
+}
+
+sub to_curl {
+ my ( $target, $query ) = @_;
+
+ my $query_json = to_json( $query, { pretty => 1 } );
+ print 'curl -XPOST api.metacpan.org/v0/' . $target . '/_search -d \'';
+ print $query_json;
+ print qq{'\n};
+
+}
+
+sub get_deps {
+ my ($release) = shift;
+
+ my ( $author, $distrelease );
+
+ $release =~ qr{^([^/]+)/(.*$)};
+ ( $author, $distrelease ) = ( "$1", "$2" );
+ return metacpan->find_release( $author, $distrelease );
+}
sub pkg_for_module {
my ($module) = shift;
diff --git a/scripts/lib/metacpan.pm b/scripts/lib/metacpan.pm
index cb02681..58ce0f2 100644
--- a/scripts/lib/metacpan.pm
+++ b/scripts/lib/metacpan.pm
@@ -33,6 +33,25 @@ sub mcpan {
}
}
+#
+# ->find_dist_all( $module::name , \%opts ) # returns an array of results.
+#
+# $opts{notrim} = 1 to skip the postprocessing filter that eliminates false matches.
+#
+# $opts{mangle} = sub {
+# my $query = shift;
+# # You can optionally do this to modify the query before it is performed.
+# };
+#
+# Array items are each a subset of a 'file' entry which contains information
+# about the distribution that file was in.
+#
+# each 'file' entry will have at least one 'file.module' entry that conforms to
+#
+# module.name == $module::name && module.authorized == true && module.indexed == true
+#
+# Essentially returning exactly what CPAN does.
+#
sub find_dist_all {
my ( $class, $module, $opts ) = @_;
@@ -82,7 +101,19 @@ sub find_dist_all {
}
-use Data::Dump qw( pp );
+
+# ->find_dist_simple( $module::name , \%opts ) # returns an array of results.
+#
+# A convenience wrapper around find_dist_all
+#
+# Adds 3 records not already in metacpan to the result for conveninece.
+#
+# $record{mod_path} = "AUTHOR/Release-Name-1.2.3-TRIAL/lib/path/to/module.pm"
+# $record{mod} = [ "path::to::module" , "1.9.9" ]
+#
+# $record{as_string} = "path::to::module 1.9.9 in AUTHOR/Release-Name-1.2.3-TRIAL/lib/path/to/module.pm"
+#
+#
sub find_dist_simple {
my ( $class, $module, $opts ) = @_;
return map {
@@ -110,5 +141,39 @@ sub _skip_result {
return 1;
}
+#
+# ->find_release( 'DOY' , 'Moose-2.0301-TRIAL' )
+#
+# Returns the content of a /release/ entry matching that criteria.
+#
+# Will return an array just in case there's more than one, but its not likely.
+#
+sub find_release {
+ my ( $class, $author, $distrelease , $opts ) = @_ ;
+ my @terms = (
+ { term => { author => $author } },
+ { term => { name => $distrelease } },
+ );
+ my $filter = { filter => { and => [
+ @terms
+ ]}};
+ my $q = {
+ explain => 1,
+ query => { constant_score => $filter },
+ };
+ my @query = (
+ release => $q
+ );
+
+ if ( $opts->{mangle} ) {
+ $opts->{mangle}->( $q, );
+ }
+
+ my $results = mcpan->post(@query);
+
+ return map { $_->{_source} } @{ $results->{hits}->{hits} };
+
+}
+
1;
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/
@ 2011-11-11 14:38 Kent Fredric
0 siblings, 0 replies; 9+ messages in thread
From: Kent Fredric @ 2011-11-11 14:38 UTC (permalink / raw
To: gentoo-commits
commit: 646b6fc60a1881c02ca77beb4cc106e77302c3fc
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Fri Nov 11 14:36:54 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Fri Nov 11 14:36:54 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=646b6fc6
[scripts] +Hack for CGI-Simple, add lgpl-2.1 license map
---
scripts/gen_ebuild.pl | 9 +++++++--
scripts/lib/deptools.pm | 1 +
2 files changed, 8 insertions(+), 2 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index d9c3648..ef9c4c7 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -104,14 +104,19 @@ $fh->say("MODULE_AUTHOR=" . $release_info->{author});
$fh->say("MODULE_VERSION=" . $release_info->{version});
$fh->say('inherit perl-module');
$fh->say('');
-
-$fh->say('DESCRIPTION=\'' . $release_info->{abstract} . '\'');
+if ( not defined $release_info->{abstract} ) {
+ $fh->say('DESCRIPTION=\'' . $release_info->{distribution} . '\'');
+ warn "Missing an ABSTRACT";
+} else {
+ $fh->say('DESCRIPTION=\'' . $release_info->{abstract} . '\'');
+}
my $lics = [];
my $licmap = {
perl_5 => [qw( Artistic GPL-2 )],
apache_2_0 => [qw( Apache-2.0 )],
mit => [qw( MIT )],
+ lgpl_2_1 => [qw( LGPL-2.1 )]
};
for my $lic ( @{ $release_info->{license} } ){
diff --git a/scripts/lib/deptools.pm b/scripts/lib/deptools.pm
index 0a16190..b85c518 100644
--- a/scripts/lib/deptools.pm
+++ b/scripts/lib/deptools.pm
@@ -47,6 +47,7 @@ sub _vmap_perl_strange {
'Net-Ping' => virtual 'net-ping',
'Pod-Parser' => virtual 'PodParser',
'Config-General' => perl 'config-general',
+ 'CGI-Simple' => perl 'Cgi-Simple',
);
}
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/
@ 2012-01-06 16:38 Kent Fredric
0 siblings, 0 replies; 9+ messages in thread
From: Kent Fredric @ 2012-01-06 16:38 UTC (permalink / raw
To: gentoo-commits
commit: 35b9a8c3d05650d4023e7b61ded134314f1f498d
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Fri Jan 6 06:03:38 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Fri Jan 6 06:03:38 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=35b9a8c3
[scripts] optimise package query, fix end-point to _search, add debug options in the WWW layer
---
scripts/lib/metacpan.pm | 19 ++++++++++++++---
scripts/package_log.pl | 48 +++++++++++++++++++++++++++++-----------------
2 files changed, 45 insertions(+), 22 deletions(-)
diff --git a/scripts/lib/metacpan.pm b/scripts/lib/metacpan.pm
index 58ce0f2..702a2a9 100644
--- a/scripts/lib/metacpan.pm
+++ b/scripts/lib/metacpan.pm
@@ -20,11 +20,22 @@ sub mcpan {
root_dir => File::Spec->catdir( File::Spec->tmpdir, 'gentoo-metacpan-cache' ),
);
require WWW::Mechanize::Cached;
- my $mech = WWW::Mechanize::Cached->new(
- cache => $cache,
- timeout => 20000,
+ my $mech;
+
+ if ( defined $ENV{WWW_MECH_NOCACHE} ) {
+ $mech = LWP::UserAgent->new();
+ } else {
+ $mech = WWW::Mechanize::Cached->new(
+ cache => $cache,
+ timeout => 20000,
autocheck => 1,
- );
+ );
+ }
+ if ( defined $ENV{WWW_MECH_DEBUG} ) {
+ $mech->add_handler("request_send", sub { warn shift->dump ; return });
+ $mech->add_handler("response_done", sub { warn shift->dump ; return });
+
+ }
require HTTP::Tiny::Mech;
my $tinymech = HTTP::Tiny::Mech->new( mechua => $mech );
require MetaCPAN::API;
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index 70547b3..a6bc9fb 100755
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -49,34 +49,45 @@ my $singleflags;
if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
-my $oldest_date = '2011-09-01T00:00:00.000Z';
-my $newest_date = '2012-01-01T00:00:00.000Z';
+my $oldest_date = '2011-10-01T00:00:00.000Z';
+my $newest_date = '2012-02-01T00:00:00.000Z';
my $search = {};
-$search->{query} = {
- terms => {
- distribution => [ @ARGV, ],
- minimum_match => 1,
- },
-};
+my $and = [];
if ( not $flags->{all} ) {
- $search->{filter} = {
- range => {
- date => {
- from => $oldest_date,
- to => $newest_date,
- },
- },
- };
+ push @{$and}, {
+ range => {
+ date => {
+ from => $oldest_date,
+ to => $newest_date,
+ }
+ }
+ };
}
+
+push @{$and} , {
+ term => {
+ 'distribution' => @ARGV,
+# minimum_match => 1,
+ }
+};
+
+$search->{query} = {
+ constant_score => {
+ filter => {
+ and => $and,
+ }
+ }
+};
+
$search->{sort} = [
# { 'author' => 'asc', },
{ 'date' => 'desc', },
];
-$search->{size} = 1024;
+$search->{size} = 10;
$search->{fields} = [qw( author name date distribution version )];
@@ -84,9 +95,10 @@ if ( $flags->{deps} ) {
push @{ $search->{fields} }, '_source.dependency';
}
+
_log( ['initialized: fetching search results'] );
-my $results = mcpan->post( 'release', $search );
+my $results = mcpan->post( 'release/_search', $search );
_log( [ 'fetched %s results', scalar @{ $results->{hits}->{hits} } ] );
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/
@ 2012-02-24 7:13 Kent Fredric
0 siblings, 0 replies; 9+ messages in thread
From: Kent Fredric @ 2012-02-24 7:13 UTC (permalink / raw
To: gentoo-commits
commit: 44c6fa80efd5c039a11904ab6a64640fe0270ece
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Fri Feb 24 07:12:41 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Fri Feb 24 07:12:41 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=44c6fa80
[scripts] misc module lookup/resolver fixes
---
scripts/gen_ebuild.pl | 2 +-
scripts/lib/deptools.pm | 17 +++---
scripts/lib/metacpan.pm | 158 +++++++++++++++++++++++++++++------------------
scripts/module_log.pl | 23 +++----
4 files changed, 117 insertions(+), 83 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 8d83bc5..ab0dc2d 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -89,7 +89,7 @@ require dep::handler::bashcode;
my $handler;
-if ( defined $flags->{debug} and $flags->{debug} ne "1" or $flags->{debug} ne "2" ) {
+if ( defined $flags->{debug} and ( $flags->{debug} ne "1" or $flags->{debug} ne "2" ) ) {
$flags->{debug} = 1;
}
diff --git a/scripts/lib/deptools.pm b/scripts/lib/deptools.pm
index 947d5b0..f734251 100644
--- a/scripts/lib/deptools.pm
+++ b/scripts/lib/deptools.pm
@@ -55,14 +55,15 @@ sub _vmap_perl_strange {
sub _vmap_overlay_native {
return (
(
- 'Archive-Extract', 'B-Debug', 'B-Lint', 'constant',
- 'CPAN', 'CPANPLUS', 'CPANPLUS-Dist-Build', 'Devel-DProf',
- 'Devel-PPPort', 'Devel-SelfStubber', 'Dumpvalue', 'ExtUtils-Constant',
- 'ExtUtils-MakeMaker', 'File-Fetch', 'Filter-Simple', 'HTTP-Tiny',
- 'i18n-langtags', 'if', 'IPC-SysV', 'Log-Message',
- 'Log-Message-Simple', 'Math-Complex', 'Module-CoreList', 'NEXT',
- 'Object-Accessor', 'Pod-LaTeX', 'Pod-Perldoc', 'Pod-Plainer',
- 'SelfLoader', 'Term-UI', 'Unicode-Collate', 'Unicode-Normalize',
+ 'Archive-Extract', 'B-Debug', 'B-Lint', 'constant',
+ 'CPAN', 'CPANPLUS', 'CPANPLUS-Dist-Build', 'Devel-DProf',
+ 'Devel-PPPort', 'Devel-SelfStubber', 'Dumpvalue', 'ExtUtils-Constant',
+ 'ExtUtils-MakeMaker', 'File-Fetch', 'Filter-Simple', 'HTTP-Tiny',
+ 'i18n-langtags', 'if', 'IPC-SysV', 'Locale-Maketext-Simple',
+ 'Log-Message', 'Log-Message-Simple', 'Math-Complex', 'Module-CoreList',
+ 'NEXT', 'Object-Accessor', 'Pod-LaTeX', 'Pod-Perldoc',
+ 'Pod-Plainer', 'SelfLoader', 'Term-UI', 'Unicode-Collate',
+ 'Unicode-Normalize',
),
( 'Exporter', 'base', )
);
diff --git a/scripts/lib/metacpan.pm b/scripts/lib/metacpan.pm
index 804fb29..e732cae 100644
--- a/scripts/lib/metacpan.pm
+++ b/scripts/lib/metacpan.pm
@@ -16,33 +16,38 @@ sub mcpan {
$mcpan ||= do {
require CHI;
my $cache = CHI->new(
- driver => 'File',
- root_dir => File::Spec->catdir( File::Spec->tmpdir, 'gentoo-metacpan-cache' ),
- expires_in => '6 hour',
+ driver => 'File',
+ root_dir => File::Spec->catdir( File::Spec->tmpdir, 'gentoo-metacpan-cache' ),
+ expires_in => '6 hour',
expires_variance => 0.2,
);
require WWW::Mechanize::Cached;
my $mech;
if ( defined $ENV{WWW_MECH_NOCACHE} ) {
- $mech = LWP::UserAgent->new();
- } else {
+ $mech = LWP::UserAgent->new();
+ }
+ else {
$mech = WWW::Mechanize::Cached->new(
- cache => $cache,
- timeout => 20000,
- autocheck => 1,
- );
+ cache => $cache,
+ timeout => 20000,
+ autocheck => 1,
+ );
}
if ( defined $ENV{WWW_MECH_DEBUG} ) {
- $mech->add_handler("request_send", sub { warn shift->dump ; return });
- $mech->add_handler("response_done", sub {
- if( $ENV{WWW_MECH_DEBUG} > 1 ){
- warn shift->content;
- } else {
- warn shift->dump;
- }
- return;
- });
+ $mech->add_handler( "request_send", sub { warn shift->dump; return } );
+ $mech->add_handler(
+ "response_done",
+ sub {
+ if ( $ENV{WWW_MECH_DEBUG} > 1 ) {
+ warn shift->content;
+ }
+ else {
+ warn shift->dump;
+ }
+ return;
+ }
+ );
}
require HTTP::Tiny::Mech;
my $tinymech = HTTP::Tiny::Mech->new( mechua => $mech );
@@ -65,8 +70,8 @@ sub mcpan {
# Array items are each a subset of a 'file' entry which contains information
# about the distribution that file was in.
#
-# each 'file' entry will have at least one 'file.module' entry that conforms to
-#
+# each 'file' entry will have at least one 'file.module' entry that conforms to
+#
# module.name == $module::name && module.authorized == true && module.indexed == true
#
# Essentially returning exactly what CPAN does.
@@ -74,38 +79,79 @@ sub mcpan {
sub find_dist_all {
my ( $class, $module, $opts ) = @_;
- my @wanted_terms = (
- { term => { 'file.module.authorized' => 1 } },
- { term => { 'file.module.indexed' => 1 } },
- { term => { 'file.module.name' => $module } },
- );
-
- my @unwanted_terms = ( { terms => { 'file.distribution' => [qw( libwww-perl HTTP-Message )] } } );
-
- my $simple_filter = { bool => { must => [@wanted_terms] } };
- my $nested_filer = {
- nested => {
- path => 'file.module',
- query => { bool => { must => [@wanted_terms] } },
- }
- };
-
- my $query_nondirs = { term => { directory => 0 } };
+ # my @unwanted_terms = ( { terms => { 'file.distribution' => [qw( libwww-perl HTTP-Message )] } } );
my $fields = [
'status', 'date', 'author', 'maturity', 'indexed', 'documentation',
'id', '_source.module', 'authorized', 'release_id', 'version', 'name',
'release', 'path', 'version_numified', '_source.stat', 'distribution', 'level',
- 'sloc', 'abstract', 'slop', 'mime'
+ 'sloc', 'abstract', 'slop', 'mime', 'directory',
];
+ my $simple_filter = {
+ bool => {
+ must => [
+ { term => { 'file.module.authorized' => 1 } },
+ { term => { 'file.module.indexed' => 1 } },
+ { term => { 'file.module.name' => $module } },
+ { term => { 'directory' => 0 } },
+ ]
+ }
+ };
+
my $q = {
- query => $query_nondirs,
- filter => $simple_filter,
- fields => $fields,
- sort => { 'file.date' => 'desc' },
- size => 9999,
+ sort => { 'file.date' => 'desc' },
+ size => 9999,
};
+ if ( not defined $opts->{method} or $opts->{method} eq 'nested' ) {
+ $q->{query} = {
+ constant_score => {
+ query => {
+ nested => {
+ path => 'module',
+ query => {
+ constant_score => {
+ filter => {
+ bool => {
+ must => [
+ { term => { 'module.authorized' => 1 } },
+ { term => { 'module.indexed' => 1 } },
+ { term => { 'module.name' => $module } },
+ ]
+ }
+ }
+ }
+ },
+ size => 5,
+ }
+ }
+ }
+ };
+ }
+ else {
+ $q->{query} = {
+ constant_score => {
+ filter => {
+ bool => {
+ must => [
+ { term => { 'file.module.authorized' => 1 } },
+ { term => { 'file.module.indexed' => 1 } },
+ { term => { 'file.module.name' => $module } },
+ { term => { 'directory' => 0 } },
+ ]
+ }
+ }
+ }
+ };
+ }
+
+ if ( $opts->{version} ) {
+ $q->{version} = 1;
+ push @{$fields}, '_version';
+ }
+
+ $q->{fields} = $fields;
+
if ( $opts->{mangle} ) {
$opts->{mangle}->( $q, );
}
@@ -118,14 +164,13 @@ sub find_dist_all {
return map { $_->{fields} } @{ $results->{hits}->{hits} };
-
}
# ->find_dist_simple( $module::name , \%opts ) # returns an array of results.
#
# A convenience wrapper around find_dist_all
#
-# Adds 3 records not already in metacpan to the result for conveninece.
+# Adds 3 records not already in metacpan to the result for conveninece.
#
# $record{mod_path} = "AUTHOR/Release-Name-1.2.3-TRIAL/lib/path/to/module.pm"
# $record{mod} = [ "path::to::module" , "1.9.9" ]
@@ -137,13 +182,13 @@ sub find_dist_simple {
my ( $class, $module, $opts ) = @_;
return map {
my $i = $_;
- my ( $j ) = grep { $_->{name} eq $module } @{ $i->{'_source.module'} };
+ my ($j) = grep { $_->{name} eq $module } @{ $i->{'_source.module'} };
my $x = {
%{$i},
mod_path => ( sprintf q{%s/%s/%s}, $i->{author}, $i->{release}, $i->{path} ),
mod => [ $j->{name}, $j->{version} ],
};
- $x->{as_string} = $j->{name} . ' ' . ($j->{version}//'') . ' in ' . $x->{mod_path};
+ $x->{as_string} = $j->{name} . ' ' . ( $j->{version} // '' ) . ' in ' . $x->{mod_path};
$x;
} $class->find_dist_all( $module, $opts );
}
@@ -168,21 +213,14 @@ sub _skip_result {
# Will return an array just in case there's more than one, but its not likely.
#
sub find_release {
- my ( $class, $author, $distrelease , $opts ) = @_ ;
- my @terms = (
- { term => { author => $author } },
- { term => { name => $distrelease } },
- );
- my $filter = { filter => { and => [
- @terms
- ]}};
+ my ( $class, $author, $distrelease, $opts ) = @_;
+ my @terms = ( { term => { author => $author } }, { term => { name => $distrelease } }, );
+ my $filter = { filter => { and => [ @terms ] } };
my $q = {
- explain => 1,
- query => { constant_score => $filter },
+ explain => 1,
+ query => { constant_score => $filter },
};
- my @query = (
- "release/_search" => $q
- );
+ my @query = ( "release/_search" => $q );
if ( $opts->{mangle} ) {
$opts->{mangle}->( $q, );
diff --git a/scripts/module_log.pl b/scripts/module_log.pl
index ff012af..ef1c592 100755
--- a/scripts/module_log.pl
+++ b/scripts/module_log.pl
@@ -85,20 +85,15 @@ use Data::Dump qw( pp );
my ($release) = shift(@ARGV);
-my $result = [ map { $_->{as_string} } metacpan->find_dist_simple( $release, $flags ) ];
-
-use JSON qw( to_json );
-say to_json( $result, { pretty => 1 } );
-1;
-
-sub pkg_for_module {
- my ($module) = shift;
-
+my (@data) = metacpan->find_dist_simple( $release, $flags );
+if( not $flags->{dump} ) {
+ my $result = [ map { $_->{as_string} } @data ];
+
+ use JSON qw( to_json );
+ say to_json( $result, { pretty => 1 } );
+} else {
+ pp $_ for @data;
}
+1;
-sub gen_dep {
- state $template = qq{\t# %s%s\n\techo %s\n};
- my ( $module, $version ) = @_;
-
-}
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/
@ 2012-02-25 22:14 Kent Fredric
0 siblings, 0 replies; 9+ messages in thread
From: Kent Fredric @ 2012-02-25 22:14 UTC (permalink / raw
To: gentoo-commits
commit: a77d38585dc75d783976b84656939c357d4d6308
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sat Feb 25 22:09:03 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sat Feb 25 22:09:03 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=a77d3858
[scripts] enhanced metacpan requests:
find_dist_all now supports filtering to report only the "latest" release
of a dist. ( --latest )
Also supports sorting by status=latest first ( --sort-latest )
module_log.pl can now resort to the simple non-nested query which
doesn't do server-side "authorised" based reduction via (
--method=simple )
\x02
---
scripts/lib/metacpan.pm | 115 +++++++++++++++++++++++++++--------------------
scripts/module_log.pl | 9 +++-
2 files changed, 73 insertions(+), 51 deletions(-)
diff --git a/scripts/lib/metacpan.pm b/scripts/lib/metacpan.pm
index e732cae..ccc267a 100644
--- a/scripts/lib/metacpan.pm
+++ b/scripts/lib/metacpan.pm
@@ -35,7 +35,19 @@ sub mcpan {
);
}
if ( defined $ENV{WWW_MECH_DEBUG} ) {
- $mech->add_handler( "request_send", sub { warn shift->dump; return } );
+ require Data::Dump;
+ $mech->add_handler(
+ "request_send",
+ sub {
+ if ( $ENV{WWW_MECH_DEBUG} > 1 ) {
+ warn shift->as_string;
+ }
+ else {
+ warn shift->dump;
+ }
+ return;
+ }
+ );
$mech->add_handler(
"response_done",
sub {
@@ -67,6 +79,15 @@ sub mcpan {
# # You can optionally do this to modify the query before it is performed.
# };
#
+# $opts{latest} = 1 # return only latest versions of dists
+#
+# $opts{method} = 'simple' # non-nested query ( introduces bad results )
+# $opts{method} = 'nested' # works like notrim but serverside
+#
+# $opts{version} = 1 # return version information
+#
+# $opts{'sort-latest'} = 1 # sort by status == latest first.
+#
# Array items are each a subset of a 'file' entry which contains information
# about the distribution that file was in.
#
@@ -79,7 +100,6 @@ sub mcpan {
sub find_dist_all {
my ( $class, $module, $opts ) = @_;
- # my @unwanted_terms = ( { terms => { 'file.distribution' => [qw( libwww-perl HTTP-Message )] } } );
my $fields = [
'status', 'date', 'author', 'maturity', 'indexed', 'documentation',
'id', '_source.module', 'authorized', 'release_id', 'version', 'name',
@@ -87,62 +107,59 @@ sub find_dist_all {
'sloc', 'abstract', 'slop', 'mime', 'directory',
];
- my $simple_filter = {
- bool => {
- must => [
- { term => { 'file.module.authorized' => 1 } },
- { term => { 'file.module.indexed' => 1 } },
- { term => { 'file.module.name' => $module } },
- { term => { 'directory' => 0 } },
- ]
- }
- };
-
my $q = {
- sort => { 'file.date' => 'desc' },
+
+ script_fields => { 'latest' => { script => q{ doc[ 'status' ].value == 'latest' } } },
+ sort => [
+ (
+ $opts->{'sort-latest'}
+ ? (
+ {
+ '_script' => {
+ script => q{ doc['status'].value == 'latest' ? 1 : 0 },
+ type => 'number',
+ order => 'desc',
+ }
+ }
+ )
+ : ()
+ ),
+ { 'file.date' => 'desc' },
+ ],
size => 9999,
};
- if ( not defined $opts->{method} or $opts->{method} eq 'nested' ) {
+ if ( not defined $opts->{method}
+ or $opts->{method} eq 'nested' )
+ {
+ my $module_rules = [
+ { term => { 'module.authorized' => 1 } },
+ { term => { 'module.indexed' => 1 } },
+ { term => { 'module.name' => $module } },
+ ];
+ my $nest = {
+ path => 'module',
+ query => { constant_score => { filter => { bool => { must => $module_rules, } } } },
+ size => 5,
+ };
$q->{query} = {
constant_score => {
- query => {
- nested => {
- path => 'module',
- query => {
- constant_score => {
- filter => {
- bool => {
- must => [
- { term => { 'module.authorized' => 1 } },
- { term => { 'module.indexed' => 1 } },
- { term => { 'module.name' => $module } },
- ]
- }
- }
- }
- },
- size => 5,
- }
- }
+ query =>
+ { bool => { must => [ ( $opts->{latest} ? { term => { 'status' => 'latest' } } : () ), { nested => $nest }, ], } }
}
};
}
else {
- $q->{query} = {
- constant_score => {
- filter => {
- bool => {
- must => [
- { term => { 'file.module.authorized' => 1 } },
- { term => { 'file.module.indexed' => 1 } },
- { term => { 'file.module.name' => $module } },
- { term => { 'directory' => 0 } },
- ]
- }
- }
- }
- };
+
+ my $document_rules = [
+ { term => { 'file.module.authorized' => 1 } },
+ { term => { 'file.module.indexed' => 1 } },
+ { term => { 'file.module.name' => $module } },
+ { term => { 'directory' => 0 } },
+ ( $opts->{latest} ? { term => { 'status' => 'latest' } } : () ),
+ ];
+
+ $q->{query} = { constant_score => { filter => { bool => { must => $document_rules } } } };
}
if ( $opts->{version} ) {
@@ -215,7 +232,7 @@ sub _skip_result {
sub find_release {
my ( $class, $author, $distrelease, $opts ) = @_;
my @terms = ( { term => { author => $author } }, { term => { name => $distrelease } }, );
- my $filter = { filter => { and => [ @terms ] } };
+ my $filter = { filter => { and => [@terms] } };
my $q = {
explain => 1,
query => { constant_score => $filter },
diff --git a/scripts/module_log.pl b/scripts/module_log.pl
index ef1c592..92f976b 100755
--- a/scripts/module_log.pl
+++ b/scripts/module_log.pl
@@ -15,14 +15,19 @@ my $flags;
my $singleflags;
@ARGV = grep { defined } map {
- $_ =~ /^--(\w+)/
+ $_ =~ /^--(.+)/
? do { $flags->{$1}++; undef }
: do {
- $_ =~ /^-(\w+)/
+ $_ =~ /^-(.+)/
? do { $singleflags->{$1}++; undef }
: do { $_ }
}
} @ARGV;
+for my $f ( keys %{$flags} ) {
+ if ( $f =~ /^([^=]+)=(.*$)/ ) {
+ $flags->{$1} = $2;
+ }
+}
if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/
@ 2012-04-06 20:43 Kent Fredric
0 siblings, 0 replies; 9+ messages in thread
From: Kent Fredric @ 2012-04-06 20:43 UTC (permalink / raw
To: gentoo-commits
commit: f1aad2cfb0e119e0af0d02685e5e56501a9be794
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Fri Apr 6 15:53:15 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Fri Apr 6 15:53:15 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=f1aad2cf
[scripts] Reduce size limit to 5000, as its upstreams maximum
---
scripts/lib/metacpan.pm | 2 +-
scripts/package_log.pl | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/scripts/lib/metacpan.pm b/scripts/lib/metacpan.pm
index ccc267a..f3191ef 100644
--- a/scripts/lib/metacpan.pm
+++ b/scripts/lib/metacpan.pm
@@ -126,7 +126,7 @@ sub find_dist_all {
),
{ 'file.date' => 'desc' },
],
- size => 9999,
+ size => 5000,
};
if ( not defined $opts->{method}
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index 0528d93..34f4934 100755
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -92,7 +92,7 @@ $search->{sort} = [
# { 'author' => 'asc', },
{ 'date' => 'desc', },
];
-$search->{size} = 10000;
+$search->{size} = 5000;
$search->{fields} = [qw( author name date distribution version )];
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/
@ 2012-04-08 23:11 Kent Fredric
0 siblings, 0 replies; 9+ messages in thread
From: Kent Fredric @ 2012-04-08 23:11 UTC (permalink / raw
To: gentoo-commits
commit: cf746e3c3f2fe8dca044012cca603464688cd289
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Apr 8 23:00:29 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sun Apr 8 23:00:29 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=cf746e3c
[scripts] add package_map_all which creates a JSON listing of all basic metadata of all available versions of all tracked packages
---
scripts/lib/optparse.pm | 17 ++++-
scripts/package_map_all.pl | 184 ++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 199 insertions(+), 2 deletions(-)
diff --git a/scripts/lib/optparse.pm b/scripts/lib/optparse.pm
index 296184b..a12ccc9 100644
--- a/scripts/lib/optparse.pm
+++ b/scripts/lib/optparse.pm
@@ -12,8 +12,20 @@ use Moose;
has 'help' => ( isa => 'CodeRef', is => 'rw', required => 1 );
has 'argv' => ( isa => 'ArrayRef', is => 'rw', required => 1 );
-has 'long_opts' => ( isa => 'HashRef', is => 'rw', 'lazy_build' => 1 );
-has 'opts' => ( isa => 'HashRef', is => 'rw', lazy_build => 1 );
+has 'long_opts' => ( isa => 'HashRef', is => 'rw', 'lazy_build' => 1 ,
+ traits => [qw( Hash )],
+ handles => {
+ has_long_opt => 'exists',
+ long_opt => 'get',
+ },
+);
+has 'opts' => ( isa => 'HashRef', is => 'rw', lazy_build => 1,
+ traits => [qw( Hash )],
+ handles => {
+ has_opt => 'exists',
+ opt => 'get',
+ },
+);
has 'extra_opts' => ( isa => 'ArrayRef', is => 'rw', 'lazy_build' => 1 );
sub _build_extra_opts {
@@ -21,6 +33,7 @@ sub _build_extra_opts {
return [ grep { $_ !~ /^--(.+)/ and $_ !~ /^-(\w+)/ } @{ $self->argv } ];
}
+
sub _build_opts {
my $self = shift;
my $hash = {};
diff --git a/scripts/package_map_all.pl b/scripts/package_map_all.pl
new file mode 100755
index 0000000..62a9c5b
--- /dev/null
+++ b/scripts/package_map_all.pl
@@ -0,0 +1,184 @@
+#!/usr/bin/env perl
+
+eval 'echo "Called with something not perl"' && exit 1 # Non-Perl protection.
+ if 0;
+
+use 5.12.2;
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use env::gentoo::perl_experimental;
+use metacpan qw( mcpan );
+use Try::Tiny;
+use utf8;
+use optparse;
+use Path::Class::Dir;
+my $optparse = optparse->new(
+ argv => \@ARGV,
+ help => sub { print help(); },
+);
+
+my $env = env::gentoo::perl_experimental->new();
+my $root = $env->root;
+
+if ( $optparse->has_long_opt('root') ) {
+ $root = Path::Class::Dir->new( $optparse->long_opt('root') );
+}
+
+my $size = 300;
+
+my $metadata = $root->subdir( 'metadata', 'perl' );
+my $distmap = $metadata->subdir('distmap');
+#my $distinfo = $metadata->subdir('distinfo');
+$distinfo->mkpath();
+my (@json_files) = grep { not $_->is_dir and $_->basename =~ /\.json$/ } $distmap->children();
+
+use JSON;
+my $decoder = JSON->new()->utf8->relaxed;
+my $encoder = JSON->new()->pretty->utf8->canonical;
+
+my %lookup;
+
+{
+ for my $file (@json_files) {
+ say "* Reading " . $file->relative;
+ my $hash = $decoder->decode( scalar $file->slurp );
+ say " Found " . ( scalar keys %{$hash} ) . " repositories indexed in " . $file->relative;
+ for my $repo ( keys %{$hash} ) {
+ my $nodes = $hash->{$repo};
+ say " ${repo}: " . ( scalar keys %{$nodes} ) . " distributions";
+ $lookup{$_}++ for keys %{$nodes};
+ }
+ }
+ say "* Found: " . ( scalar keys %lookup ) . " unique distributions";
+ my ( @dup ) = grep { $lookup{$_} > 1 } keys %lookup;
+ if ( @dup > 0 ) {
+ say " " . ( scalar @dup ) ." items listed more than once";
+ say " > $_" for @dup;
+ }
+}
+
+my @dists = keys %lookup;
+
+my $search = {};
+$search->{query} = { constant_score => { filter => { terms => {
+ distribution => [ @dists ]
+} } } };
+$search->{sort} = [ { 'date' => 'desc', }, ];
+$search->{size} = $size;
+$search->{fields} = [
+ qw(
+ abstract
+ archive
+ author
+ authorized
+ date
+ distribution
+ download_url
+ license
+ maturity
+ name
+ status
+ version
+ )
+];
+
+$ENV{WWW_MECH_NOCACHE} = 1;
+
+my $results_string = mcpan->ua->request(
+ 'POST',
+ mcpan->base_url . 'release/_search?search_type=scan&scroll=30s&size=' . $size,
+ {
+ content => $encoder->encode( $search ),
+ }
+);
+
+say $results_string->{content};
+
+my $results = $decoder->decode( $results_string->{content} );
+my $scroll_id = $results->{_scroll_id};
+
+my $total_results = $results->{hits}->{total};
+
+say "Found: $total_results releases";
+
+
+my $dtree;
+my $seen = 0;
+
+while( 1 ) {
+ my ( $result, $scroll ) = scroll( $scroll_id );
+ last unless scalar @{$result->{hits}->{hits}};
+ collate_resultset( $result );
+ $scroll_id = $scroll;
+ say "Seen $seen of $total_results";
+}
+
+for my $package ( sort keys %{$dtree} ) {
+ say "Sorting $package";
+ $dtree->{$package} = [ sort { $b->{date} cmp $a->{date} } @{ $dtree->{$package} } ];
+}
+
+my $fh = $metadata->file('distinfo.json')->openw;
+$fh->print( $encoder->encode( $dtree ));
+
+exit 0;
+
+sub scroll {
+ my ( $id ) = @_ ;
+ my $result = mcpan->ua->request(
+ 'GET',
+ 'http://api.metacpan.org/_search/scroll/?scroll=30s&size=' . $size . '&scroll_id=' . $id
+ );
+
+ my $data = $decoder->decode( $result->{content} );
+ return $data, $data->{_scroll_id};
+}
+
+sub collate_resultset {
+ my ( $results ) = @_;
+ for my $result ( @{ $results->{hits}->{hits} } ) {
+ if ( not $result->{fields} ) {
+ $result->{fields} = $result->{_source};
+ }
+ delete $result->{fields}->{dependency} if exists $result->{fields}->{dependency};
+ my $fields = $result->{fields};
+
+ my $cversion = $fields->{name};
+ my $cdistrib = $fields->{distribution};
+ $cversion =~ s/^${cdistrib}-//;
+ $seen++;
+ $fields->{version_canon} = $cversion;
+ $fields->{version_gentoo} = scalar try { gv( $cversion, { lax => 1 } ) };
+ $fields->{archive_canon} = $fields->{author} . '/' . $fields->{archive};
+ #say $fields->{author} . '/' . $fields->{archive};
+ $dtree->{$cdistrib} = [] unless exists $dtree->{$cdistrib};
+ push @{ $dtree->{$cdistrib} }, $fields;
+ }
+}
+
+# Utils
+
+sub gv { require Gentoo::PerlMod::Version; goto \&Gentoo::PerlMod::Version::gentooize_version }
+
+sub help {
+ return <<"EOF";
+package_map_all.pl
+
+USAGE:
+
+ package_map_all.pl [--help]
+
+ ie:
+
+ package_map_all.pl
+
+ --help Show this message
+
+EOF
+
+}
+
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/
@ 2012-04-08 23:12 Kent Fredric
0 siblings, 0 replies; 9+ messages in thread
From: Kent Fredric @ 2012-04-08 23:12 UTC (permalink / raw
To: gentoo-commits
commit: 2f61ed01847aa30530ce2fe7805245f73ac12c9a
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Apr 8 23:04:04 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sun Apr 8 23:04:04 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=2f61ed01
[scripts] document/tidy
---
scripts/lib/optparse.pm | 23 ++++++++++++++---------
scripts/package_map_all.pl | 42 ++++++++++++++++++++----------------------
2 files changed, 34 insertions(+), 31 deletions(-)
diff --git a/scripts/lib/optparse.pm b/scripts/lib/optparse.pm
index a12ccc9..b3c44ec 100644
--- a/scripts/lib/optparse.pm
+++ b/scripts/lib/optparse.pm
@@ -12,18 +12,24 @@ use Moose;
has 'help' => ( isa => 'CodeRef', is => 'rw', required => 1 );
has 'argv' => ( isa => 'ArrayRef', is => 'rw', required => 1 );
-has 'long_opts' => ( isa => 'HashRef', is => 'rw', 'lazy_build' => 1 ,
- traits => [qw( Hash )],
- handles => {
+has 'long_opts' => (
+ isa => 'HashRef',
+ is => 'rw',
+ 'lazy_build' => 1,
+ traits => [qw( Hash )],
+ handles => {
has_long_opt => 'exists',
- long_opt => 'get',
+ long_opt => 'get',
},
);
-has 'opts' => ( isa => 'HashRef', is => 'rw', lazy_build => 1,
- traits => [qw( Hash )],
- handles => {
+has 'opts' => (
+ isa => 'HashRef',
+ is => 'rw',
+ lazy_build => 1,
+ traits => [qw( Hash )],
+ handles => {
has_opt => 'exists',
- opt => 'get',
+ opt => 'get',
},
);
has 'extra_opts' => ( isa => 'ArrayRef', is => 'rw', 'lazy_build' => 1 );
@@ -33,7 +39,6 @@ sub _build_extra_opts {
return [ grep { $_ !~ /^--(.+)/ and $_ !~ /^-(\w+)/ } @{ $self->argv } ];
}
-
sub _build_opts {
my $self = shift;
my $hash = {};
diff --git a/scripts/package_map_all.pl b/scripts/package_map_all.pl
index 62a9c5b..a22355b 100755
--- a/scripts/package_map_all.pl
+++ b/scripts/package_map_all.pl
@@ -31,7 +31,8 @@ if ( $optparse->has_long_opt('root') ) {
my $size = 300;
my $metadata = $root->subdir( 'metadata', 'perl' );
-my $distmap = $metadata->subdir('distmap');
+my $distmap = $metadata->subdir('distmap');
+
#my $distinfo = $metadata->subdir('distinfo');
$distinfo->mkpath();
my (@json_files) = grep { not $_->is_dir and $_->basename =~ /\.json$/ } $distmap->children();
@@ -54,9 +55,9 @@ my %lookup;
}
}
say "* Found: " . ( scalar keys %lookup ) . " unique distributions";
- my ( @dup ) = grep { $lookup{$_} > 1 } keys %lookup;
+ my (@dup) = grep { $lookup{$_} > 1 } keys %lookup;
if ( @dup > 0 ) {
- say " " . ( scalar @dup ) ." items listed more than once";
+ say " " . ( scalar @dup ) . " items listed more than once";
say " > $_" for @dup;
}
}
@@ -64,9 +65,7 @@ my %lookup;
my @dists = keys %lookup;
my $search = {};
-$search->{query} = { constant_score => { filter => { terms => {
- distribution => [ @dists ]
-} } } };
+$search->{query} = { constant_score => { filter => { terms => { distribution => [@dists] } } } };
$search->{sort} = [ { 'date' => 'desc', }, ];
$search->{size} = $size;
$search->{fields} = [
@@ -91,28 +90,25 @@ $ENV{WWW_MECH_NOCACHE} = 1;
my $results_string = mcpan->ua->request(
'POST',
mcpan->base_url . 'release/_search?search_type=scan&scroll=30s&size=' . $size,
- {
- content => $encoder->encode( $search ),
- }
+ { content => $encoder->encode($search), }
);
say $results_string->{content};
-my $results = $decoder->decode( $results_string->{content} );
+my $results = $decoder->decode( $results_string->{content} );
my $scroll_id = $results->{_scroll_id};
my $total_results = $results->{hits}->{total};
say "Found: $total_results releases";
-
my $dtree;
my $seen = 0;
-while( 1 ) {
- my ( $result, $scroll ) = scroll( $scroll_id );
- last unless scalar @{$result->{hits}->{hits}};
- collate_resultset( $result );
+while (1) {
+ my ( $result, $scroll ) = scroll($scroll_id);
+ last unless scalar @{ $result->{hits}->{hits} };
+ collate_resultset($result);
$scroll_id = $scroll;
say "Seen $seen of $total_results";
}
@@ -123,23 +119,21 @@ for my $package ( sort keys %{$dtree} ) {
}
my $fh = $metadata->file('distinfo.json')->openw;
-$fh->print( $encoder->encode( $dtree ));
+$fh->print( $encoder->encode($dtree) );
exit 0;
sub scroll {
- my ( $id ) = @_ ;
- my $result = mcpan->ua->request(
- 'GET',
- 'http://api.metacpan.org/_search/scroll/?scroll=30s&size=' . $size . '&scroll_id=' . $id
- );
+ my ($id) = @_;
+ my $result =
+ mcpan->ua->request( 'GET', 'http://api.metacpan.org/_search/scroll/?scroll=30s&size=' . $size . '&scroll_id=' . $id );
my $data = $decoder->decode( $result->{content} );
return $data, $data->{_scroll_id};
}
sub collate_resultset {
- my ( $results ) = @_;
+ my ($results) = @_;
for my $result ( @{ $results->{hits}->{hits} } ) {
if ( not $result->{fields} ) {
$result->{fields} = $result->{_source};
@@ -154,6 +148,7 @@ sub collate_resultset {
$fields->{version_canon} = $cversion;
$fields->{version_gentoo} = scalar try { gv( $cversion, { lax => 1 } ) };
$fields->{archive_canon} = $fields->{author} . '/' . $fields->{archive};
+
#say $fields->{author} . '/' . $fields->{archive};
$dtree->{$cdistrib} = [] unless exists $dtree->{$cdistrib};
push @{ $dtree->{$cdistrib} }, $fields;
@@ -176,6 +171,9 @@ USAGE:
package_map_all.pl
+ --root=/usr/portage
+ # Specify the metadata is in /usr/portage/metadata/perl/distmap/*
+ # And to emit /usr/portage/metadata/perl/distinfo.json
--help Show this message
EOF
^ permalink raw reply related [flat|nested] 9+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/
@ 2013-05-01 22:23 Kent Fredric
0 siblings, 0 replies; 9+ messages in thread
From: Kent Fredric @ 2013-05-01 22:23 UTC (permalink / raw
To: gentoo-commits
commit: 97a9f54ae24685b93b209ad1878c309436de5847
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Apr 30 16:32:23 2013 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Tue Apr 30 16:32:23 2013 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=97a9f54a
[scripts] deptools.pm : add ExtUtils-Depends to exception list
---
scripts/gen_metadata.pl | 79 ++++++++++++++++++++++++++++++++++++
scripts/lib/deptools.pm | 59 ++++++++++++++-------------
scripts/virtualmap.pl | 102 +++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 211 insertions(+), 29 deletions(-)
diff --git a/scripts/gen_metadata.pl b/scripts/gen_metadata.pl
new file mode 100644
index 0000000..ba31fd8
--- /dev/null
+++ b/scripts/gen_metadata.pl
@@ -0,0 +1,79 @@
+use 5.12.2;
+use strict;
+use warnings;
+
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use env::gentoo::perl_experimental;
+use optparse;
+use utf8;
+use XML::Smart;
+
+my $env = env::gentoo::perl_experimental->new();
+my $opts = optparse->new(
+ argv => \@ARGV,
+ help => sub { print <DATA>; return }
+);
+
+my $root = $env->root;
+use Path::Class::Dir;
+
+my $cwd = Path::Class::Dir->new('.')->absolute;
+
+my $package_dir = $cwd;
+
+if( $opts->has_long_opt('package-dir') ) {
+ $package_dir = Path::Class::Dir->new($opts->long_opt('package-dir'))->absolute;
+}
+if( not scalar grep { not $_->is_dir and $_->basename =~ /\.ebuild$/ } $package_dir->children ) {
+ die "Sorry, there are no .ebuild files in this directory, not going to create a metadata.xml file here!";
+}
+
+if( $opts->has_long_opt('new') ) {
+ say "Generating a new metdata.xml";
+ if ( -e $package_dir->file('metadata.xml')->stat ){
+ # die "Error: metadata.xml already exists here";
+ }
+ my $herd = 'perl';
+ my $maintainer_name;
+ my $maintainer_email;
+ my $cpan_id;
+
+ if( $opts->has_long_opt('herd') ) {
+ $herd = $opts->long_opt('herd');
+ }
+ if( $opts->has_long_opt('maintainer-name') ){
+ $maintainer_name = $opts->long_opt('maintainer-name');
+ }
+ if( $opts->has_long_opt('maintainer-email') ){
+ $maintainer_email = $opts->long_opt('maintainer-email');
+ }
+ if( $opts->has_long_opt('cpan-id') ) {
+ $cpan_id = $opts->long_opt('cpan-id');
+ }
+ my $xml = XML::Smart->new('<?xml version="1.0" encoding="UTF-8"?><!DOCTYPE pkgmetadata SYSTEM "http://www.gentoo.org/dtd/metadata.dtd"><pkgmetadata></pkgmetadata>');
+ $xml->{pkgmetadata}->{herd}->[0] = $herd;
+ # $xml->{pkgmetadata}->{herd}->set_node(1);
+ if ( defined $maintainer_name ) {
+ $xml->{pkgmetadata}->{maintainer}->{name} = $maintainer_name;
+ # $xml->{pkgmetadata}->{maintainer}->{name}->set_node(1);
+ }
+ if( defined $maintainer_email ) {
+ $xml->{pkgmetadata}->{maintainer}->{email} = $maintainer_email;
+ # $xml->{pkgmetadata}->{maintainer}->{email}->set_node(1);
+ }
+ if( defined $cpan_id ) {
+ $xml->{pkgmetadata}->{upstream}->{'remote-id'}->content($cpan_id);
+ $xml->{pkgmetadata}->{upstream}->{'remote-id'}->{type} = 'cpan';
+ }
+
+ $xml->apply_dtd('http://www.gentoo.org/dtd/metadata.dtd');
+
+ print scalar $xml->data( nodtd => 1, meta => { 'script' => 'perl-experimental/scripts/gen_metadata.pl' } );
+}
+
+
+__DATA__
+
+__END__
diff --git a/scripts/lib/deptools.pm b/scripts/lib/deptools.pm
index 2618ae7..8bd5595 100644
--- a/scripts/lib/deptools.pm
+++ b/scripts/lib/deptools.pm
@@ -40,35 +40,36 @@ sub _vmap_perl_native {
# ::gentoo Exceptions
sub _vmap_perl_strange {
return (
- 'App-SVN-Bisect' => 'dev-util/App-SVN-Bisect',
- 'Autodia' => 'dev-utils/autodia',
- 'BioPerl' => 'sci-biology/bioperl',
- 'BioPerl-DB' => 'sci-biology/bioperl-db',
- 'BioPerl-Network' => 'sci-biology/bioperl-network',
- 'BioPerl-Run' => 'sci-biology/bioperl-run',
- 'CGI-Simple' => perl 'Cgi-Simple',
- 'Config-General' => perl 'config-general',
- 'Crypt-CBC' => perl 'crypt-cbc',
- 'Digest' => virtual 'digest-base',
- 'Date-Manip' => perl 'DateManip',
- 'GBrowse' => 'sci-biology/GBrowse',
- 'Glib' => perl 'glib-perl',
- 'I18N-LangTags' => virtual 'i18n-langtags',
- 'Image-ExifTool' => 'media-libs/exiftool',
- 'Locale-Maketext' => virtual 'locale-maketext',
- 'Net-Ping' => virtual 'net-ping',
- 'Net-Server' => perl 'net-server',
- 'Padre' => 'app-editors/padre',
- 'PathTools' => virtual 'File-Spec',
- 'Perl-Tidy' => perl 'perltidy',
- 'Pod-Parser' => virtual 'PodParser',
- 'SVK' => 'dev-vcs/svk',
- 'Set-Scalar' => perl 'set-scalar',
- 'Snapback2' => 'app-backup/snapback2',
- 'Text-Template' => perl 'text-template',
- 'XML-XSH2' => 'app-editors/XML-XSH2',
- 'YAML' => perl 'yaml',
- 'ack' => 'sys-apps/ack',
+ 'App-SVN-Bisect' => 'dev-util/App-SVN-Bisect',
+ 'Autodia' => 'dev-utils/autodia',
+ 'BioPerl' => 'sci-biology/bioperl',
+ 'BioPerl-DB' => 'sci-biology/bioperl-db',
+ 'BioPerl-Network' => 'sci-biology/bioperl-network',
+ 'BioPerl-Run' => 'sci-biology/bioperl-run',
+ 'CGI-Simple' => perl 'Cgi-Simple',
+ 'Config-General' => perl 'config-general',
+ 'Crypt-CBC' => perl 'crypt-cbc',
+ 'Date-Manip' => perl 'DateManip',
+ 'Digest' => virtual 'digest-base',
+ 'ExtUtils-Depends' => perl 'extutils-depends',
+ 'GBrowse' => 'sci-biology/GBrowse',
+ 'Glib' => perl 'glib-perl',
+ 'I18N-LangTags' => virtual 'i18n-langtags',
+ 'Image-ExifTool' => 'media-libs/exiftool',
+ 'Locale-Maketext' => virtual 'locale-maketext',
+ 'Net-Ping' => virtual 'net-ping',
+ 'Net-Server' => perl 'net-server',
+ 'Padre' => 'app-editors/padre',
+ 'PathTools' => virtual 'File-Spec',
+ 'Perl-Tidy' => perl 'perltidy',
+ 'Pod-Parser' => virtual 'PodParser',
+ 'SVK' => 'dev-vcs/svk',
+ 'Set-Scalar' => perl 'set-scalar',
+ 'Snapback2' => 'app-backup/snapback2',
+ 'Text-Template' => perl 'text-template',
+ 'XML-XSH2' => 'app-editors/XML-XSH2',
+ 'YAML' => perl 'yaml',
+ 'ack' => 'sys-apps/ack',
);
}
diff --git a/scripts/virtualmap.pl b/scripts/virtualmap.pl
new file mode 100644
index 0000000..2ace064
--- /dev/null
+++ b/scripts/virtualmap.pl
@@ -0,0 +1,102 @@
+
+{
+
+ package VirtualRecord;
+ use 5.16.0;
+ use Moo;
+
+ has virtual_name => ( is => rw =>, required => 1, );
+ has virtual_corepackage => ( is => rw =>, required => 1, );
+ has virtual_check_module => ( is => rw =>, required => 1, );
+ has repo => ( is => rw =>, required => 1, );
+
+
+}
+{
+ package VDB;
+ use 5.16.0;
+ use Quote::Sub;
+ has items => ( is => rw => , default => quote_sub(q{ [] });
+
+ sub add_item {
+ my ( $self , @args ) = @_ ;
+ my $rec = VirtualRecord->new(
+ virtual_name => $args[0],
+ virtual_corepackage => $args[1],
+ virtual_check_moodule => $args[2],
+ repo => $args[3];
+ );
+ push @{ $self->items }, $rec;
+ }
+ sub add_items {
+ my ( $self, @args ) = @_;
+ for my $rec ( @args ){
+ $self->add_item( @{$rec} );
+ }
+ }
+}
+
+sub atom_expand {
+ my $atom = shift;
+ my $package = $atom =~ s/::/-/gr;
+ my $virtual = $package =~ s/^/perl-/r;
+ return ( $virtual, $package, $atom );
+}
+my $vdb = VDB->new();
+$vdb->add_items(
+ ( map { [ atom_expand($_), 'perl-experimental' ] } qw(
+ Archive::Extract
+ B::Debug
+ B::Lint
+ constant
+ CPAN
+ CPANPLUS
+ CPANPLUS::Dist::Build
+ Devel::DProf
+ Devel::PPPort
+ Devel::SelfStubber
+ Dumpvalue
+ Exporter
+ ExtUtils::MakeMaker
+ File::Fetch
+ Filter::Simple
+ HTTP::Tiny
+ if
+ IPC::SysV
+ Log::Message
+ Log::Message::Simple
+ Math::Complex
+ Module::CoreList
+ NEXT
+ Object::Accessor
+ Pod::LaTeX
+ Pod::Perldoc
+ Pod::Plainer
+ SelfLoader
+ Term::UI
+ Unicode::Collate
+ Unicode::Normalize
+ )),
+ [ 'perl-i18n-langtags' , 'i18n-langtags', 'I18N::LangTags' , 'perl-experimental']
+);
+$vdb->add_items(
+ ( map { [ atom_expand($_), 'gentoo' ] } qw(
+ Archive::Tar
+ Attribute::Handlers
+ AutoLoader
+ CGI
+ Class::ISA
+ Compress::Raw::Bzip2
+ Compress::Raw::Zlib
+ CPAN::Meta
+ CPAN::Meta::Requirements
+ CPAN::Meta::YAML
+ Data::Dumper
+ DB_File
+ )),
+ [ 'perl-digest-base' , 'digest-base', 'Digest' , 'gentoo'],
+ ( map { [ atom_expand($_), 'gentoo' ] } qw(
+ )),
+
+);
+
^ permalink raw reply related [flat|nested] 9+ messages in thread
end of thread, other threads:[~2013-05-01 22:23 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-10-31 2:48 [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/ Kent Fredric
-- strict thread matches above, loose matches on Subject: below --
2011-11-11 14:38 Kent Fredric
2012-01-06 16:38 Kent Fredric
2012-02-24 7:13 Kent Fredric
2012-02-25 22:14 Kent Fredric
2012-04-06 20:43 Kent Fredric
2012-04-08 23:11 Kent Fredric
2012-04-08 23:12 Kent Fredric
2013-05-01 22:23 Kent Fredric
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox