* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-24 9:09 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-24 9:09 UTC (permalink / raw
To: gentoo-commits
commit: 9a1c11bd3efa9bdd66060a80ea34418e1bc17b91
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 24 09:06:51 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 24 09:06:51 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=9a1c11bd
[Scripts] Added a utility for getting information about a specific Perl
Distribution.
Allows a 1-stop-shop for seeing the most relevant changes and
dependencies for a list of selected packages.
Uses a few packages currently not in the overlay which you'll need
to suppliment some other way ( ie: cpanm/local-lib )
* MetaCPAN::API
* CHI
* WWW::Mechanize::Cached
* HTTP::Tiny::Mech
* Data::Dump
* Term::ANSIColor
* Gentoo::PerlMod::Version
* CPAN::Changes
---
scripts/package_log.pl | 320 ++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 320 insertions(+), 0 deletions(-)
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
new file mode 100644
index 0000000..595b213
--- /dev/null
+++ b/scripts/package_log.pl
@@ -0,0 +1,320 @@
+#!/usr/bin/env perl
+use 5.14.2;
+use strict;
+use warnings;
+
+# FILENAME: pvlist.pl
+# CREATED: 16/10/11 20:16:03 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Show version history for interesting perl dists
+
+# DEPENDENCIES:
+#
+# * MetaCPAN::API
+# * CHI
+# * WWW::Mechanize::Cached
+# * HTTP::Tiny::Mech
+# * Data::Dump
+# * Term::ANSIColor
+# * Gentoo::PerlMod::Version
+# * CPAN::Changes
+#
+sub mcpan {
+ state $mcpan = do {
+ require MetaCPAN::API;
+ require CHI;
+ my $cache = CHI->new(
+ driver => 'File',
+ root_dir => '/tmp/gentoo-metacpan-cache'
+ );
+ require WWW::Mechanize::Cached;
+ my $mech = WWW::Mechanize::Cached->new(
+ cache => $cache,
+ timeout => 20000,
+ autocheck => 1,
+ );
+ require HTTP::Tiny::Mech;
+ MetaCPAN::API->new(
+ ua => HTTP::Tiny::Mech->new( mechua => $mech )
+ );
+ };
+}
+
+my $flags;
+my $singleflags;
+@ARGV = grep { defined } map {
+ $_ =~ /^--(\w+)/ ?
+ do { $flags->{$1}++ ; undef }
+ :
+ do { $_ =~ /^-(\w+)/ ?
+ do { $singleflags->{$1}++; undef }
+ :
+ do { $_ }
+ }
+} @ARGV;
+
+if( $flags->{help} or $singleflags->{h} ) {
+ print <<"EOF";
+package_log.pl
+
+USAGE:
+
+ package_log.pl PACKAGE [PACKAGE*] [--all] [--help] [--changes] [--deps] [--trace]
+
+ ie:
+
+ # Just show the recent log for Moose, Catalyst-Runtime and Dist-Zilla
+ package_log.pl Moose Catalyst-Runtime Dist-Zilla
+
+ # show all log events for Moose
+ package_log.pl Moose --all
+
+ # show recent Moose log events with attached changelog data and dependenices
+ package_log.pl Moose --changes --deps
+
+ # Be verbose about what we're doing
+ package_log.pl Moose --trace --all
+
+ --all Show all releases in the log.
+ --help Show this message
+ --changes Show ChangeLog Excerpts using CPAN::Changes where possible
+ --deps Show Dependency data ( as reported via metadata )
+ --trace Turn on extra debugging.
+EOF
+exit 0;
+}
+
+my $package = shift @ARGV;
+
+my (@want_dists) = ( $package, @ARGV );
+
+my $oldest_date = '2011-09-01T00:00:00.000Z';
+my $newest_date = '2012-01-01T00:00:00.000Z';
+
+my $search = {};
+$search->{query} = {
+ terms => {
+ distribution => [ @want_dists, ],
+ minimum_match => 1,
+ },
+};
+if ( not $flags->{all} ) {
+ $search->{filter} = {
+ range => {
+ date => {
+ from => $oldest_date,
+ to => $newest_date,
+ },
+ },
+ };
+}
+$search->{sort} = [
+
+ # { 'author' => 'asc', },
+ { 'date' => 'desc', },
+];
+$search->{size} = 1024;
+
+# $flags->{fields} = [qw( author name date distribution )],
+_log(['initialized: fetching search results']);
+
+my $results = mcpan->post( 'release', $search );
+
+_log(['fetched %s results', scalar @{$results->{hits}->{hits}} ]);
+
+sub pp {
+ require Data::Dump;
+ goto \&Data::Dump::pp;
+}
+sub _log {
+ return unless $flags->{trace};
+ if ( not ref $_[0] ) {
+ return *STDERR->print(@_);
+ }
+ my $conf = $_[0];
+ my ( $str, @args ) = @{$conf};
+ $str =~ s/\n?$/\n/;
+ return *STDERR->print(sprintf "\e[7m* %s:\e[0m " . $str , 'package_log.pl', @args );
+}
+
+use Term::ANSIColor qw( :constants );
+
+for my $result ( @{ $results->{hits}->{hits} } ) {
+
+ my %f = %{ $result->{_source} };
+
+ # say pp \%f;
+ my ( $date, $distribution, $name, $author, $deps, $version ) = @f{qw( date distribution name author dependency version )};
+ _log(['formatting entry for %s', $name ]);
+ say entry_heading( @f{qw( date author distribution name version)} );
+
+ if ( $flags->{deps} ) {
+ _log(['processing %s deps for %s', scalar @{$deps} , $name]);
+ print $_ for sort map { dep_line($_) } @{$deps};
+ }
+ if ( $flags->{changes} ) {
+ _log(['processing changes deps for %s', $name]);
+ }
+ if ( $flags->{changes} and my $message = change_for( $author, $name ) ) {
+ say "\n\e[1;38m" . $message . "\e[0m";
+ }
+
+}
+
+sub gv {
+ require Gentoo::PerlMod::Version;
+ goto \&Gentoo::PerlMod::Version::gentooize_version;
+}
+
+sub entry_heading {
+ my ( $date, $author, $distribution, $name, $version ) = @_;
+ state $date_style = UNDERLINE . CYAN;
+ state $gentoo_version = BOLD . CYAN;
+ return sprintf "%s - %s/%s %s",
+ $date_style . $date . RESET,
+ ac($author),
+ dc( $distribution, $name ),
+ $gentoo_version . gv( $version, { lax => 1 } ) . RESET;
+}
+
+sub dep_line {
+ my ($dep) = @_;
+ state $gentoo_version = BOLD . CYAN;
+ my $rel = ( $dep->{relationship} ne 'requires' ? BRIGHT_BLUE . $dep->{relationship} : q[] );
+ my $phase = ( $dep->{phase} eq 'develop' ? BRIGHT_GREEN : q[] ) . $dep->{phase};
+ my $version = $gentoo_version . gv( $dep->{version}, { lax => 1 } ) . RESET;
+ return sprintf "%s %s: %s %s %s\n", $rel, $phase, $dep->{module}, $dep->{version}, $version;
+}
+
+use Try::Tiny;
+
+sub change_for {
+ my ( $author, $release ) = @_;
+ my $file;
+ my @trylist = qw( Changes CHANGES ChangeLog );
+ my @errors;
+
+ my $success;
+
+ for my $basename ( @trylist ) {
+ try {
+ _log(['trying %s for %s', $basename, $release ]);
+ $file = mcpan->source(
+ author => $author,
+ release => $release,
+ path => $basename,
+ );
+ $success = $basename;
+ } catch {
+ $success = 0;
+ _log(['failed with %s for %s : %s', $basename, $release, $_ ]);
+ push @errors, $_;
+ };
+ last if $success;
+ }
+ if ( !$success ) {
+ _log(['no changes file %s ', $release ]);
+ warn for @errors;
+ }
+
+ return unless $file;
+
+ require CPAN::Changes;
+ my $changes = CPAN::Changes->load_string($file);
+ if ( $changes ){
+ my @releases = $changes->releases();
+ return $releases[-1]->serialize() if @releases;
+ _log(['No releases reported by CPAN::Changes for file %s on %s', $success, $release ]);
+ #warn "No releases :( ";
+ }
+ #warn "Cant load \$file with CPAN::Changes";
+ my @out = split /$/m, $file;
+ return join qq{\n}, splice @out, 0, 10;
+
+}
+
+sub ac {
+ state $cgen = mcgen();
+ return $cgen->( $_[0] ) . $_[0] . RESET;
+}
+
+sub dc {
+ state $cgen = mcgen();
+ return $cgen->( $_[0] ) . $_[1] . RESET;
+}
+
+sub ITALIC() { "\e[3m" }
+
+sub gen_colour_map {
+ my (@styles) = (
+ RESET,
+ BOLD,
+ ITALIC,
+ UNDERLINE,
+ REVERSE,
+ ( ( BOLD . ITALIC, BOLD . UNDERLINE, BOLD . REVERSE ), ( ITALIC . UNDERLINE, ITALIC . REVERSE, ), ( UNDERLINE . REVERSE ), ),
+ ( BOLD . ITALIC . UNDERLINE, BOLD . ITALIC . REVERSE, ITALIC . UNDERLINE . REVERSE, ),
+ ( BOLD . ITALIC . UNDERLINE . REVERSE ),
+ );
+ my (@fgs) = (
+ BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE,
+ BRIGHT_BLACK, BRIGHT_RED, BRIGHT_GREEN, BRIGHT_YELLOW, BRIGHT_BLUE, BRIGHT_MAGENTA, BRIGHT_CYAN, BRIGHT_WHITE
+ );
+
+ my (@bgs) = (
+ "", ON_WHITE, ON_RED, ON_GREEN, ON_YELLOW, ON_BLUE,
+ ON_MAGENTA, ON_CYAN, ON_BLACK, ON_BRIGHT_WHITE, ON_BRIGHT_RED, ON_BRIGHT_GREEN,
+ ON_BRIGHT_YELLOW, ON_BRIGHT_BLUE, ON_BRIGHT_MAGENTA, ON_BRIGHT_CYAN, ON_BRIGHT_BLACK
+ );
+
+ my @bad = (
+ [ undef, BLACK, ON_BLACK ],
+ [ undef, BLACK, "" ],
+ [ undef, RED, ON_RED ],
+ [ undef, GREEN, ON_GREEN ],
+ [ undef, YELLOW, ON_YELLOW ],
+ [ undef, BLUE, ON_BLUE ],
+ [ undef, MAGENTA, ON_MAGENTA ],
+ [ undef, CYAN, ON_CYAN ],
+ [ undef, WHITE, ON_WHITE ],
+ );
+
+ my (@colours);
+ my $is_bad = sub {
+ my ( $style, $fg, $bg ) = @_;
+ for my $bc (@bad) {
+ my ( $sm, $fgm, $bgm );
+ $sm = ( not defined $bc->[0] or $bc->[0] eq $style );
+ $fgm = ( not defined $bc->[1] or $bc->[1] eq $fg );
+ $bgm = ( not defined $bc->[2] or $bc->[2] eq $bg );
+ return 1 if ( $sm and $fgm and $bgm );
+ }
+ return;
+ };
+ for my $bg (@bgs) {
+ for my $style (@styles) {
+
+ for my $fg (@fgs) {
+ next if $is_bad->( $style, $fg, $bg );
+ push @colours, $style . $fg . $bg;
+
+ }
+ }
+ }
+ return \@colours;
+}
+
+sub mcgen {
+ my $colours = {};
+ my $cmap = gen_colour_map;
+ my $colour_gen = sub {
+ my $colour = shift @{$cmap};
+ push @{$cmap}, $colour;
+ return $colour;
+ };
+ return sub {
+ my $key = $_[0];
+ return $colours->{$key} if exists $colours->{$key};
+ return ( $colours->{$key} = $colour_gen->() );
+ };
+}
+
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2017-09-16 22:36 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2017-09-16 22:36 UTC (permalink / raw
To: gentoo-commits
commit: 3ada1f58b0b05b765b668a16e317a0319f2c7f1d
Author: Kent Fredric <kentnl <AT> gentoo <DOT> org>
AuthorDate: Tue Jan 17 01:37:54 2017 +0000
Commit: Kent Fredric <kentnl <AT> gentoo <DOT> org>
CommitDate: Sat Sep 16 22:07:29 2017 +0000
URL: https://gitweb.gentoo.org/proj/perl-overlay.git/commit/?id=3ada1f58
scripts/: update multiplex script for current gentoo repos
scripts/ssh_multiplex.pl | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/scripts/ssh_multiplex.pl b/scripts/ssh_multiplex.pl
index cb3d4c9bb..703e4c96d 100755
--- a/scripts/ssh_multiplex.pl
+++ b/scripts/ssh_multiplex.pl
@@ -38,9 +38,9 @@ spawn_cmd(
{
pids => \@pids,
params => [qw( background no_execute_command no_stdin control_master )],
- connect => 'git@git.overlays.gentoo.org',
+ connect => 'git@git.gentoo.org',
cleanup => sub {
- say "\e[32mConnected to git\@git.overlays.gentoo.org\e[0m";
+ say "\e[32mConnected to git\@git.gentoo.org\e[0m";
},
}
);
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2015-02-28 23:17 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2015-02-28 23:17 UTC (permalink / raw
To: gentoo-commits
commit: 01ed23965ec3561744abe64fd0ada6b89696eb53
Author: Pavel Denisov <pavel.a.denisov <AT> gmail <DOT> com>
AuthorDate: Sat Feb 28 03:15:38 2015 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sat Feb 28 03:34:08 2015 +0000
URL: http://sources.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=01ed2396
[scripts/gen_ebuild.pl] add special handling for perl_5 license
---
scripts/gen_ebuild.pl | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index a54a665..e5065e6 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -197,7 +197,9 @@ if ( scalar @$lics == 1 ) {
$fh->say( 'LICENSE=" ' . $lics->[0] . '"' );
}
elsif ( scalar @$lics > 1 ) {
- $fh->say( 'LICENSE=" || ( ' . ( join q{ }, @$lics ) . ' )"' );
+ if ( not ( $lics->[0] eq 'Artistic' && $lics->[1] eq 'GPL-2' ) ) {
+ $fh->say( 'LICENSE=" || ( ' . ( join q{ }, @$lics ) . ' )"' );
+ }
}
else {
$fh->say('LICENSE=""');
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2015-02-28 23:17 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2015-02-28 23:17 UTC (permalink / raw
To: gentoo-commits
commit: d7e8f28ba818d581345e18e220679fa964c29b46
Author: Pavel Denisov <pavel.a.denisov <AT> gmail <DOT> com>
AuthorDate: Sat Feb 28 03:21:42 2015 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sat Feb 28 03:34:08 2015 +0000
URL: http://sources.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=d7e8f28b
[scripts/gen_ebuild.pl] remove local SRC_TEST to make use of one from perl-module eclass
---
scripts/gen_ebuild.pl | 1 -
1 file changed, 1 deletion(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index e5065e6..5cbe1e8 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -284,7 +284,6 @@ if ( $handler2->has_tdeps ) {
$fh->say( "DEPEND=\"\n" . ( join qq{\n}, map { "\t$_" } @{$depends} ) . "\n\"" );
$fh->say( "RDEPEND=\"\n" . ( join qq{\n}, map { "\t$_" } @{$rdepends} ) . "\n\"" );
-$fh->say("SRC_TEST=\"do\"");
#say pp( \%modules,);# { pretty => 1 } );
exit 1;
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2013-12-23 15:28 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2013-12-23 15:28 UTC (permalink / raw
To: gentoo-commits
commit: ee9388f2aebb4cd02f3ebd661b4e5229f5b157d2
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Dec 23 13:40:16 2013 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Dec 23 13:40:16 2013 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=ee9388f2
[scripts] Handle a single license field graciously
---
scripts/gen_ebuild.pl | 3 +++
1 file changed, 3 insertions(+)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 2181a54..a54a665 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -178,6 +178,9 @@ my $oddlic = {
},
};
+if ( not ref $release_info->{license} ) {
+ $release_info->{license} = [ $release_info->{license} ];
+}
for my $lic ( @{ $release_info->{license} } ) {
if ( exists $licmap->{$lic} ) {
push @$lics, @{ $licmap->{$lic} };
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2013-05-01 23:03 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2013-05-01 23:03 UTC (permalink / raw
To: gentoo-commits
commit: 8b13e9caaaf76afbf835140cabadcdd66bde4077
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed May 1 22:56:02 2013 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Wed May 1 22:56:02 2013 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=8b13e9ca
[scripts] rework aggregate_tree.pl to use Gentoo::Perl::Distmap::FromOverlay
---
scripts/aggregate_tree.pl | 85 +++++++++++----------------------------------
1 files changed, 21 insertions(+), 64 deletions(-)
diff --git a/scripts/aggregate_tree.pl b/scripts/aggregate_tree.pl
index 16afe79..52b18f9 100755
--- a/scripts/aggregate_tree.pl
+++ b/scripts/aggregate_tree.pl
@@ -16,14 +16,15 @@ use Data::Dump qw( pp );
use Gentoo::Overlay;
use Gentoo::Perl::Distmap;
use Gentoo::Perl::Distmap::RecordSet;
+use Gentoo::Perl::Distmap::FromOverlay;
+
# FILENAME: aggregate_tree.pl
# CREATED: 29/02/12 07:37:54 by Kent Fredric (kentnl) <kentfredric@gmail.com>
# ABSTRACT: Connect all the cpan id's from the metadata.xml
use XML::Smart;
-my ( $env, $cat );
-my $dm = Gentoo::Perl::Distmap->new();
+my ( $env, $cat , $dm );
main();
@@ -46,11 +47,26 @@ sub main {
}
my $dest = open_output( $opts->long_opts->{output} );
+ my $mapper = Gentoo::Perl::Distmap::FromOverlay->new( overlay => $tree );
$|++;
- $tree->iterate(
- 'packages' => \&handle_package
- );
+ local *Gentoo::Perl::Distmap::FromOverlay::_on_enter_category = sub {
+ print "\r" . $_[1] . ' ';
+ print "\r" . $_[1] . ' ';
+ };
+ my @symbols = ( '/' , '-', '\\', '|' );
+ local *Gentoo::Perl::Distmap::FromOverlay::_on_enter_package = sub {
+ my $next_symbol = shift @symbols;
+ push @symbols, $next_symbol;
+ print $next_symbol . "\b";
+ };
+
+ local *Gentoo::Perl::Distmap::FromOverlay::_on_enter_ebuild = sub {
+ print ".> \b\b" ;
+ };
+
+
+ $dm = $mapper->distmap;
$dest->print( make_format( $opts->long_opts->{format} ) );
@@ -92,65 +108,6 @@ sub make_format_distlist {
return join qq{\n}, $dm->mapped_dists;
}
-sub handle_package {
- my ( $self, $c ) = @_;
- my $CP = $c->{category_name} . '/' . $c->{package_name};
- my $xmlfile = $c->{package}->path->file('metadata.xml');
- if ( not -e $xmlfile ) {
- warn "\e[31mNo metadata.xml for $CP\e[0m\n";
- return;
- }
- if ( not $cat or $c->{category_name} ne $cat ) {
- *STDERR->print( "\nProcessing " . $c->{category_name} . " :" );
- $cat = $c->{category_name};
- }
- *STDERR->print(".");
- my $XML = XML::Smart->new( $xmlfile->absolute()->stringify() );
- if ( not exists $XML->{pkgmetadata} ) {
- warn "\e[31m<pkgmetadata> missing in $xmlfile\e[0m\n";
- return;
- }
- if ( not exists $XML->{pkgmetadata}->{upstream} ) {
-
- # warn "<pkgmetadata>/<upstream> missing in $xmlfile\n";
- return;
- }
- if ( not exists $XML->{pkgmetadata}->{upstream}->{'remote-id'} ) {
-
- # warn "<pkgmetadata>/<upstream>/<remote-id> missing in $xmlfile\n";
- return;
- }
- for my $remote ( @{ $XML->{pkgmetadata}->{upstream}->{'remote-id'} } ) {
-
- next if not exists $remote->{type};
- next unless $remote->{type} eq 'cpan';
-
- my $upstream = $remote->content();
-
- my $record = {
- category => $c->{category_name},
- package => $c->{package_name},
- repository => $c->{overlay_name},
- distribution => $upstream,
- };
- $c->{package}->iterate(
- ebuilds => sub {
- my ( $self, $d ) = @_;
- my $version = $d->{ebuild_name};
- my $p = $c->{package_name};
- $version =~ s/\.ebuild$//;
- $version =~ s/^\Q${p}\E-//;
- $dm->add_version(
- %{$record},
- version => $version,
- );
- }
- );
-
- *STDERR->print("\e[32m $CP -> $upstream\e[0m ");
- }
-
-}
0;
__DATA__
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2013-05-01 23:03 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2013-05-01 23:03 UTC (permalink / raw
To: gentoo-commits
commit: b46480a9e424bd12e2ecfdbeac8b62a7d921e6c0
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed May 1 23:02:16 2013 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Wed May 1 23:02:16 2013 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=b46480a9
[scripts] aggregate_tree.pl : document --from-ini option
---
scripts/aggregate_tree.pl | 11 +++++++++++
1 files changed, 11 insertions(+), 0 deletions(-)
diff --git a/scripts/aggregate_tree.pl b/scripts/aggregate_tree.pl
index 52b18f9..56ff5eb 100755
--- a/scripts/aggregate_tree.pl
+++ b/scripts/aggregate_tree.pl
@@ -126,6 +126,17 @@ Usage:
--root="/path/to/some/root"
Specifiy another root to scan ( ie: /usr/portage )
+
+ --from-ini
+
+ Get the overlays to scan from a configuration named 'aggregate_tree' in a config
+ loaded by Gentoo::Overlay::Group::INI
+
+ ie: ~/.config/Perl/Gentoo-Overlay-Group-INI/config.ini
+
+ [Overlays / aggregate_tree]
+ directory = /var/paludis/repositories/perl-git/
+ directory = /usr/portage/
--format=JSON # Emit JSON ( Default )
--format=distlist # Emit a list of CPAN Dist Names
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-10-24 15:49 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-10-24 15:49 UTC (permalink / raw
To: gentoo-commits
commit: fbaab580673a4c9f2989f9b4b9d54635aafadc4a
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed Oct 24 15:39:06 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Wed Oct 24 15:39:06 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=fbaab580
[scripts/gen_ebuild] generate EAPI=5 by default
---
scripts/gen_ebuild.pl | 2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 7c89f45..2181a54 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -144,7 +144,7 @@ say "Writing $file";
$fh->say("# Copyright 1999-$year Gentoo Foundation");
$fh->say("# Distributed under the terms of the GNU General Public License v2");
$fh->say("# \$Header: \$");
-$fh->say("EAPI=4");
+$fh->say("EAPI=5");
$fh->say( "MODULE_AUTHOR=" . $release_info->{author} );
$fh->say( "MODULE_VERSION=" . $release_info->{version} );
$fh->say('inherit perl-module');
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-09-15 23:19 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-09-15 23:19 UTC (permalink / raw
To: gentoo-commits
commit: 58318f6522686017e0b09b4b047b9f204724a47d
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sat Sep 15 20:19:21 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sat Sep 15 23:17:22 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=58318f65
[scripts/fixvdep.pl] Add edge case for versions that weren't already discovered properly
---
scripts/fixvdep.pl | 2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/scripts/fixvdep.pl b/scripts/fixvdep.pl
index 7f16464..5f4d5f9 100755
--- a/scripts/fixvdep.pl
+++ b/scripts/fixvdep.pl
@@ -28,7 +28,7 @@ my @subs = (
( sprintf 's/%s-%s\s*$/%s-%s/' , $pkg, $oldversion,$pkg,$newversion ),
( sprintf 's/%s-%s\s*"/%s-%s"/' , $pkg, $oldversion,$pkg,$newversion ),
-
+ ( sprintf 's/%s-%s\s*(\).*$)/%s-%s \1/' , $pkg, $oldversion,$pkg,$newversion ),
( sprintf 's/%s\s*%s\s*$/%s %s/', $pkg, $oldversion, $pkg, $newversion ),
( sprintf 's/%s\s*%s\s*#\s*%s\s*$/%s %s/',
$pkg, $oldversion, $newversion, $pkg, $newversion ),
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-08-02 11:46 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-08-02 11:46 UTC (permalink / raw
To: gentoo-commits
commit: 50a5ba227df70c2eb22d83a73044fbb1848fe1e7
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Thu Aug 2 06:11:54 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Thu Aug 2 06:11:54 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=50a5ba22
[scripts] aggregate_tree.pl / use Gentoo::Perl::Distmap
---
scripts/aggregate_tree.pl | 27 ++++++++++++---------------
1 files changed, 12 insertions(+), 15 deletions(-)
diff --git a/scripts/aggregate_tree.pl b/scripts/aggregate_tree.pl
index 1e7e92a..16afe79 100755
--- a/scripts/aggregate_tree.pl
+++ b/scripts/aggregate_tree.pl
@@ -14,14 +14,17 @@ use optparse;
use utf8;
use Data::Dump qw( pp );
use Gentoo::Overlay;
-
+use Gentoo::Perl::Distmap;
+use Gentoo::Perl::Distmap::RecordSet;
# FILENAME: aggregate_tree.pl
# CREATED: 29/02/12 07:37:54 by Kent Fredric (kentnl) <kentfredric@gmail.com>
# ABSTRACT: Connect all the cpan id's from the metadata.xml
use XML::Smart;
-my ( $env, $packages, $cat );
+my ( $env, $cat );
+my $dm = Gentoo::Perl::Distmap->new();
+
main();
sub main {
@@ -42,8 +45,6 @@ sub main {
$tree->add_overlay( set_root( $opts->long_opts->{root} ));
}
- $packages = {};
-
my $dest = open_output( $opts->long_opts->{output} );
$|++;
@@ -84,13 +85,11 @@ sub make_format {
}
sub make_format_json {
- require JSON;
- my $encoder = JSON->new()->pretty->utf8->canonical;
- return $encoder->encode($packages);
+ return $dm->save( string =>, );
}
sub make_format_distlist {
- return join qq{\n}, keys %{$packages};
+ return join qq{\n}, $dm->mapped_dists;
}
sub handle_package {
@@ -128,15 +127,11 @@ sub handle_package {
my $upstream = $remote->content();
- if ( not defined $packages->{$upstream} ) {
- $packages->{$upstream} = [];
- }
- my $versions = [];
my $record = {
category => $c->{category_name},
package => $c->{package_name},
repository => $c->{overlay_name},
- versions_gentoo => $versions,
+ distribution => $upstream,
};
$c->{package}->iterate(
ebuilds => sub {
@@ -145,10 +140,12 @@ sub handle_package {
my $p = $c->{package_name};
$version =~ s/\.ebuild$//;
$version =~ s/^\Q${p}\E-//;
- push @{$versions}, $version;
+ $dm->add_version(
+ %{$record},
+ version => $version,
+ );
}
);
- push @{ $packages->{$upstream} }, $record;
*STDERR->print("\e[32m $CP -> $upstream\e[0m ");
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-08-02 11:46 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-08-02 11:46 UTC (permalink / raw
To: gentoo-commits
commit: eb64b9df52d207c8c3f8803ea3d1187910199f16
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Thu Aug 2 06:22:51 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Thu Aug 2 06:22:51 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=eb64b9df
[scripts] package_map_all.pl / use Gentoo::Perl::Distmap
---
scripts/package_map_all.pl | 30 +++++++-----------------------
1 files changed, 7 insertions(+), 23 deletions(-)
diff --git a/scripts/package_map_all.pl b/scripts/package_map_all.pl
index 2e84ac9..2abb9f3 100755
--- a/scripts/package_map_all.pl
+++ b/scripts/package_map_all.pl
@@ -16,6 +16,8 @@ use Try::Tiny;
use utf8;
use optparse;
use Path::Class::Dir;
+use Gentoo::Perl::Distmap;
+use Gentoo::Perl::Distmap::RecordSet;
my $optparse = optparse->new(
argv => \@ARGV,
help => sub { print help(); },
@@ -42,33 +44,15 @@ my $decoder = JSON->new()->utf8->relaxed;
my $encoder = JSON->new()->pretty->utf8->canonical;
my %lookup;
-my %g_repos;
+
say "Init-ed";
{
for my $file (@json_files) {
- my %repos;
say "* Reading " . $file->relative;
- my $nodes = $decoder->decode( scalar $file->slurp );
-
- say " Found " . ( scalar keys %{$nodes} ) . " distributions";
- for ( keys %{$nodes} ) {
- my $records = $nodes->{$_};
- $lookup{$_}++;
- for my $rec ( @{$records} ) {
- my $repo = $rec->{repository};
- $repos{$repo}++;
- }
- }
- say " $_ : " . $repos{$_} for keys %repos;
- for ( keys %repos ) {
- $g_repos{$_} += $repos{$_};
- }
- }
- 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 $dm = Gentoo::Perl::Distmap->load( file => $file );
+
+ say " Found " . ( scalar $dm->mapped_dists ) . " distributions";
+ %lookup = ( %lookup, map { $_ => 1 } $dm->mapped_dists );
}
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-07-31 3:04 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-07-31 3:04 UTC (permalink / raw
To: gentoo-commits
commit: 077c56991ca754e120779d002824ba6cff99ddea
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Jul 31 00:35:48 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Tue Jul 31 00:35:48 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=077c5699
[scripts] add my diff itemization scripts Ive been using for a while
---
scripts/itemise_diff_distinfo.pl | 44 +++++++++++
scripts/itemise_diff_distmap.pl | 150 ++++++++++++++++++++++++++++++++++++++
2 files changed, 194 insertions(+), 0 deletions(-)
diff --git a/scripts/itemise_diff_distinfo.pl b/scripts/itemise_diff_distinfo.pl
new file mode 100644
index 0000000..ad9819f
--- /dev/null
+++ b/scripts/itemise_diff_distinfo.pl
@@ -0,0 +1,44 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use 5.12.1;
+
+# FILENAME: itemise_diff.pl
+# CREATED: 17/04/12 04:06:11 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Show the relevant parts from git diff
+
+my $fh;
+if ( not @ARGV ) {
+ $fh = *STDIN;
+}
+else {
+ open $fh, '<', $ARGV[0] or die;
+}
+
+my @seen;
+my @seen_status;
+
+my $archive;
+
+while ( defined( my $line = <$fh> ) ) {
+ chomp $line;
+ push @seen, $line;
+ if ( $line =~ /^([+-]|)\s+"archive_canon"\s+:\s+"([^"]+)"/ ) {
+ my $polarity = $1;
+ $archive = $2;
+ say "new: $archive" if $polarity eq '+';
+ }
+ if ( $line =~ /^([+-])\s+"status"\s+:\s+"([^"]+)"/ ) {
+ my ( $stat, $value ) = ( "$1", "$2" );
+ my $current = [ $stat, $value , $archive];
+ push @seen_status, $current;
+ my $has_prev = exists $seen_status[-2];
+ my $prev;
+ $prev = $seen_status[-2] if $has_prev;
+
+ if ( $has_prev and $current->[1] eq 'backpan' and $prev->[1] ne 'backpan' and $prev->[2] eq $current->[2] and $current->[0] eq '+' and $prev->[0] eq '-' ) {
+ say "del: $archive";
+ }
+ }
+}
diff --git a/scripts/itemise_diff_distmap.pl b/scripts/itemise_diff_distmap.pl
new file mode 100644
index 0000000..b69bad2
--- /dev/null
+++ b/scripts/itemise_diff_distmap.pl
@@ -0,0 +1,150 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use 5.12.1;
+
+# FILENAME: itemise_diff.pl
+# CREATED: 17/04/12 04:06:11 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Show the relevant parts from git diff
+
+my $fh;
+if ( not @ARGV ) {
+ $fh = *STDIN;
+}
+else {
+ open $fh, '<', $ARGV[0] or die;
+}
+
+my @seen;
+my @seen_status;
+
+my $category = "";
+my $package = "";
+my $repo = "";
+
+my $dstash = {};
+my $stash_key = "";
+my $in_versions;
+
+sub process_stash {
+ my ( $key ) = @_;
+ #say "* $key";
+ if ( not exists $dstash->{$key} ) {
+ #say "-- no stash";
+ return;
+ }
+ if ( not keys %{$dstash->{$key}} ) {
+ #say "-- no keys";
+ return;
+ }
+ for my $keyname ( keys %{$dstash->{$key}} ) {
+ my $value = $dstash->{$key}->{$keyname};
+ if ( $value eq '+' ) {
+ say "newversion $key @ $keyname";
+ } else {
+ say "removed $key @ $keyname";
+ }
+ }
+}
+sub set_package {
+ my ( $polarity, $_package ) = @_;
+ $package = $_package;
+ $in_versions = undef;
+}
+
+sub set_repo {
+ my ( $polarity, $_repo ) = @_;
+ $repo = $_repo;
+ say "\nADD $category/${package}::$repo\n" if $polarity eq '+';
+ say "\nTREECLEAN $category/${package}::$repo\n" if $polarity eq '-';
+
+}
+
+sub set_category {
+ my ( $_category ) = @_;
+ $category = $_category;
+ $package = "";
+ $in_versions = undef;
+}
+
+sub set_version_plus {
+ my ( $key, $version ) = @_;
+ if ( not exists $dstash->{$key} ){
+ $dstash->{$key} = {};
+ }
+ if ( not exists $dstash->{$key}->{$version} ) {
+ $dstash->{$key}->{$version} = '+';
+ return;
+ }
+ if ( $dstash->{$key}->{$version} eq '-' ) {
+ delete $dstash->{$key}->{$version};
+ return;
+ }
+ die "Wut";
+}
+sub set_version_minus {
+ my ( $key, $version ) = @_;
+ if ( not exists $dstash->{$key} ){
+ $dstash->{$key} = {};
+ }
+ if ( not exists $dstash->{$key}->{$version} ) {
+ $dstash->{$key}->{$version} = '-';
+ return;
+ }
+ if ( $dstash->{$key}->{$version} eq '+' ) {
+ delete $dstash->{$key}->{$version};
+ return;
+ }
+ die "Wut";
+}
+
+
+while ( defined( my $line = <$fh> ) ) {
+ chomp $line;
+ push @seen, $line;
+ my $last_pkg = $package;
+
+ $stash_key = "$category/${package}::$repo";
+
+ if ( $line =~ /^([+-]|)\s+"category"\s+:\s+"([^"]+)"/ ) {
+ set_category($2);
+ }
+ if ( $line =~ /^([+-]|)\s+"package"\s+:\s+"([^"]+)"/ ) {
+ set_package( $1, $2 );
+ }
+ if ( $line =~ /^([+-]|)\s+"repository"\s+:\s+"([^"]+)"/ ) {
+ set_repo($1, $2 );
+ }
+
+ if ( $last_pkg ne $package and $last_pkg ne "" ) {
+ process_stash( $stash_key );
+ next;
+ }
+
+
+ if ( $line =~ /^([+-]|)\s+"versions_gentoo"\s+:\s+\[/ ) {
+ $in_versions = 1;
+ next;
+ }
+ if ( $in_versions && $line =~ /^([+-]|)\s+\]/ ){
+ $in_versions = undef;
+ next;
+ }
+
+ next if not $in_versions;
+
+ if ( $in_versions && $line =~ /^([+-])\s+"([^"]+)"/ ){
+ my $polarity = $1;
+ my $version = $2;
+ if ( $polarity eq '+' ) {
+ set_version_plus( $stash_key, $version );
+ next;
+ } else {
+ set_version_minus( $stash_key, $version );
+ next;
+ }
+ }
+
+}
+process_stash($stash_key);
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-07-12 19:23 Torsten Veller
0 siblings, 0 replies; 63+ messages in thread
From: Torsten Veller @ 2012-07-12 19:23 UTC (permalink / raw
To: gentoo-commits
commit: 0585507945741fe6a1a0f347154cf69c9b9235cf
Author: Torsten Veller <tove <AT> gentoo <DOT> org>
AuthorDate: Thu Jul 12 19:21:22 2012 +0000
Commit: Torsten Veller <tove <AT> gentoo <DOT> org>
CommitDate: Thu Jul 12 19:21:22 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=05855079
Add script for metacpan metadata updates
---
scripts/metadata-cpan-update.pl | 230 +++++++++++++++++++++++++++++++++++++++
1 files changed, 230 insertions(+), 0 deletions(-)
diff --git a/scripts/metadata-cpan-update.pl b/scripts/metadata-cpan-update.pl
new file mode 100755
index 0000000..a4a5654
--- /dev/null
+++ b/scripts/metadata-cpan-update.pl
@@ -0,0 +1,230 @@
+#!/usr/bin/env perl
+
+eval 'echo "Called with something not perl"' && exit 1 # Non-Perl protection.
+ if 0;
+
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use XML::Smart;
+use File::Slurp;
+use Data::Dumper;
+use CHI;
+use WWW::Mechanize::Cached;
+use HTTP::Tiny::Mech;
+use MetaCPAN::API;
+use Gentoo::Ebuild::ParseVariables qw(gentoo_ebuild_var);
+use CPAN::DistnameInfo;
+use Path::Class;
+use PortageXS;
+
+use metacpan qw( mcpan );
+my $mcpan = mcpan;
+#my $mcpan = MetaCPAN::API->new(
+# ua => HTTP::Tiny::Mech->new(
+# mechua => WWW::Mechanize::Cached->new(
+# cache => CHI->new(
+# driver => 'File',
+# root_dir => '/tmp/metacpan-cache',
+# ),
+# ),
+# ),
+#);
+
+#my $portdir = '/var/gentoo/portage';
+my $portdir = PortageXS->new->getPortdir();
+my $dtd = $portdir . "/metadata/dtd/metadata.dtd";
+
+while (@ARGV) {
+ my $md = shift @ARGV;
+ #print "$md\n";
+ my $dist;
+ my %cpan_modules;
+ my $metadata_old = read_file($md, binmode => ':utf8');
+ my $indent_level = indent($metadata_old);
+ my $metadata_new;
+ my $XML = XML::Smart->new($metadata_old);
+
+ #$XML->apply_dtd($dtd);
+ if ( check_remote_id($XML)
+ and not $XML->{pkgmetadata}->{upstream}
+ ->{'remote-id'}( 'type', 'eq', 'cpan' )->null() )
+ {
+ $dist =
+ $XML->{pkgmetadata}->{upstream}
+ ->{'remote-id'}( 'type', 'eq', 'cpan' )->content();
+ }
+ my $dist_src_uri = distname($md);
+ my $cpan_dist_failure;
+ if ( defined $dist and $dist ne '' and $dist ne $dist_src_uri ) {
+ print "Dist is wrong!\n";
+ print "'$dist' vs '$dist_src_uri'\n";
+ $cpan_dist_failure = 1;
+ $dist = $dist_src_uri;
+ } elsif ( not defined $dist ) {
+ $dist = $dist_src_uri;
+ }
+
+ my $result = $mcpan->post(
+ 'module/_search',
+ {
+ "fields" => [ "module.name", "release" ],
+ "query" => {
+ "constant_score" => {
+ "filter" => {
+ "and" => [
+ { "term" => { "distribution" => "$dist" } },
+ { "term" => { "status" => "latest" } },
+ { "term" => { "mime" => "text/x-script.perl-module" } },
+ { "term" => { "indexed" => "true" } },
+ { "term" => { "module.authorized" => "true" } }
+ ]
+ }
+ }
+ },
+ "size" => 990
+ }
+ );
+
+ return unless $result->{'hits'}->{'hits'};
+ for my $file ( @{ $result->{'hits'}->{'hits'} } ) {
+ if ( ref $file->{'fields'}->{'module.name'} eq 'ARRAY' ) {
+ for my $module ( @{ $file->{'fields'}->{'module.name'} } ) {
+ $cpan_modules{$module} += 2;
+ }
+ }
+ else {
+ $cpan_modules{ $file->{'fields'}->{'module.name'} } += 2;
+ }
+ }
+ drop_former_modules($XML, \%cpan_modules, $cpan_dist_failure);
+
+ if ( defined $dist and $dist ne '' ) {
+ if ( $XML->{pkgmetadata}->{upstream}
+ ->{'remote-id'}( 'type', 'eq', 'cpan' )->null() )
+ {
+ push @{ $XML->{pkgmetadata}->{upstream}->{"remote-id"} },
+ { type => 'cpan', content => "$dist" };
+ }
+ else {
+ if ( $XML->{pkgmetadata}->{upstream}
+ ->{'remote-id'}( 'type', 'eq', 'cpan' )->content() ne $dist )
+ {
+ push @{ $XML->{pkgmetadata}->{upstream}->{"remote-id"} },
+ { type => 'cpan', content => "$dist" };
+ }
+ }
+ }
+
+ for my $module ( sort keys %cpan_modules ) {
+
+ print "Removed : $module\n" if $cpan_modules{$module} == 1;
+ print "Added : $module\n" if $cpan_modules{$module} == 2;
+
+ push(
+ @{ $XML->{pkgmetadata}->{upstream}->{'remote-id'} },
+ { type => 'cpan-module', content => "$module" }
+ ) if $cpan_modules{$module} >= 2;
+ }
+ $metadata_new = '<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE pkgmetadata SYSTEM "http://www.gentoo.org/dtd/metadata.dtd">
+';
+ $metadata_new .= $XML->data( nometagen => 1, nodtd => 1, noheader => 1 );
+ $metadata_new =~ s/\n\Z//sm;
+
+ my $metadata_newnew;
+ for my $line ( split /\n/, $metadata_new ) {
+ if ( $line =~ m,^[ ]{4}(?=\<), ) {
+ $line =~ s,^[ ]{4}(?=\<),$indent_level->{'second'},mseg;
+ } elsif ( $line =~ m,^[ ]{2}(?=\<), ) {
+ $line =~ s,^[ ]{2}(?=\<),$indent_level->{'first'},mseg;
+ }
+ $metadata_newnew .= $line . "\n";
+ }
+
+ write_file( "$md.new",{binmode => ':utf8'}, $metadata_newnew );
+ system("diff -ur $md $md.new");
+ rename "$md.new", "$md" or die "Can't rename $md.new: $!\n";
+
+}
+
+sub indent {
+ my $metadata = shift;
+ my %tags;
+ foreach my $tag (qw( herd maintainer longdescription use upstream )) {
+ $tags{"first"} = $1 if $metadata =~ m,.*?^([ \t]*)\<$tag,ms;
+ }
+ foreach my $tag (qw( remote-id name email )) {
+ $tags{"second"} = $1 if $metadata =~ m,.*?^([ \t]*)\<$tag,ms;
+ }
+ $tags{"second"} = "$tags{'first'}$tags{'first'}"
+ if not exists $tags{"second"};
+ return \%tags;
+}
+
+sub distname {
+ my $fd = shift;
+ $fd =~ s,metadata.xml,*.ebuild,;
+ my @ebuilds = glob "$fd";
+# @ebuilds = reverse @ebuilds;
+ foreach my $ebuild ( reverse @ebuilds) {
+ $ebuild = file($ebuild)->absolute;
+ my $ebuild_hash = gentoo_ebuild_var(
+ "$ebuild",
+ #[qw( MY_PN SRC_URI MY_PV MODULE_VERSION MODULE_A )],
+ [qw( SRC_URI )],
+ #file($ebuild)->absolute->dir->parent->parent
+ $portdir
+ );
+ next unless $ebuild_hash->{'SRC_URI'};
+ my @src_uri = split /\s/, $ebuild_hash->{'SRC_URI'};
+ foreach my $uri (@src_uri) {
+
+ next unless $uri =~ m,authors/id,;
+ return CPAN::DistnameInfo->new("$uri")->dist();
+ }
+ print Dumper $ebuild_hash;
+ }
+}
+
+sub check_remote_id {
+ my $xml = shift;
+ if ( $xml->{pkgmetadata}->null() ) {
+ print "metadata.xml: pkgmetadata does not exist\n";
+ return;
+ }
+ if ( $xml->{pkgmetadata}->{upstream}->null() ) {
+ print "metadata.xml: upstream does not exist\n";
+ return;
+ }
+ if ( $xml->{pkgmetadata}->{upstream}->{'remote-id'}->null() ) {
+ print "metadata.xml: remote-id does not exist\n";
+ return;
+ }
+ return 1;
+}
+
+sub drop_former_modules {
+ my $xml = shift;
+ my $cpan_modules = shift;
+ my $cpan_dist_failure = shift;
+ return unless check_remote_id($xml);
+ for my $remote ( @{ $xml->{pkgmetadata}->{upstream}->{'remote-id'} } ) {
+
+ # print "Remote: $remote\n";
+ next unless exists $remote->{type};
+ if ( $remote->{type} eq 'cpan-module' ) {
+ $cpan_modules->{ $remote->content() } += 1;
+ undef $remote;
+ }
+ elsif ( $remote->{type} eq 'cpan' ) {
+ if ($cpan_dist_failure) {
+ print "undef cpan\n";
+
+ undef $remote;
+ undef $xml->{pkgmetadata}->{upstream};
+ }
+ }
+ }
+}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-06-22 7:34 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-06-22 7:34 UTC (permalink / raw
To: gentoo-commits
commit: 94de4825f65caa983f0c816917c872e68c67bcd9
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Fri Jun 22 07:19:11 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Fri Jun 22 07:19:11 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=94de4825
[scripts/aggregate_tree] refactor to use the new Gentoo::Overlay::Group::INI class, loadable via --from-ini, which enables processing multiple repositories into a single output file
---
scripts/aggregate_tree.pl | 201 +++++++++++++++++++++++++--------------------
1 files changed, 112 insertions(+), 89 deletions(-)
diff --git a/scripts/aggregate_tree.pl b/scripts/aggregate_tree.pl
index f8f797e..1e7e92a 100755
--- a/scripts/aggregate_tree.pl
+++ b/scripts/aggregate_tree.pl
@@ -21,116 +21,139 @@ use Gentoo::Overlay;
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;
-
-if ( defined $opts->long_opts->{root} ) {
- $root = Path::Class::Dir->new( $opts->long_opts->{root} );
-}
-my $overlay = Gentoo::Overlay->new( path => $root );
+my ( $env, $packages, $cat );
+main();
+
+sub main {
+ $env = env::gentoo::perl_experimental->new();
+ my $opts = optparse->new(
+ argv => \@ARGV,
+ help => sub { print <DATA>; return },
+ );
+ my $tree;
+
+ if ( $opts->long_opts->{'from-ini'} ) {
+ require Gentoo::Overlay::Group::INI;
+ $tree = Gentoo::Overlay::Group::INI->load_named('aggregate_tree')->overlay_group;
+ }
+ else {
+ require Gentoo::Overlay::Group;
+ $tree = Gentoo::Overlay::Group->new();
+ $tree->add_overlay( set_root( $opts->long_opts->{root} ));
+ }
-my $overlay_name = $overlay->name;
-use JSON;
+ $packages = {};
-my $data;
+ my $dest = open_output( $opts->long_opts->{output} );
-my $packages = $data->{ $overlay_name } = {};
+ $|++;
+ $tree->iterate(
+ 'packages' => \&handle_package
+ );
-my $encoder = JSON->new()->pretty->utf8->canonical;
+ $dest->print( make_format( $opts->long_opts->{format} ) );
-my $dest = \*STDOUT;
-if ( not $opts->long_opts->{output} or $opts->long_opts->{output} eq '-' ) {
- $dest = \*STDOUT;
}
-else {
- use Path::Class::File;
- my $file = Path::Class::File->new( $opts->long_opts->{output} )->absolute();
- $dest = $file->openw( iomode => ':utf8' );
+
+sub set_root {
+ my ($root) = @_;
+ return $env->root unless defined $root;
+ require Path::Class::Dir;
+ return Path::Class::Dir->new($root);
}
-my $cat;
-$|++;
-$overlay->iterate(
- 'packages' => sub {
- my ( $self, $c ) = @_;
- my $CP = $c->{category_name} . '/' . $c->{package_name};
- my $xmlfile = $root->subdir( $c->{category_name}, $c->{package_name} )->file('metadata.xml');
- if ( not -e $xmlfile ) {
- warn "\e[31mNo metadata.xml for $CP\e[0m\n";
- return;
- }
- if( not $cat or $c->{category_name} ne $cat ) {
- *STDERR->print("\nProcessing " . $c->{category_name} . " :");
- $cat = $c->{category_name};
- }
- *STDERR->print(".");
- my $XML = XML::Smart->new( $xmlfile->absolute()->stringify() );
- if ( not exists $XML->{pkgmetadata} ) {
- warn "\e[31m<pkgmetadata> missing in $xmlfile\e[0m\n";
- return;
- }
- if ( not exists $XML->{pkgmetadata}->{upstream} ) {
- # warn "<pkgmetadata>/<upstream> missing in $xmlfile\n";
- return;
- }
- if ( not exists $XML->{pkgmetadata}->{upstream}->{'remote-id'} ) {
+sub open_output {
+ my ($output) = @_;
+ return \*STDOUT if not defined $output;
+ return \*STDOUT if $output eq '-';
+ require Path::Class::File;
+ my $file = Path::Class::File->new($output)->absolute();
+ return $file->openw( iomode => ':utf8' );
+}
- # warn "<pkgmetadata>/<upstream>/<remote-id> missing in $xmlfile\n";
- return;
- }
- for my $remote ( @{ $XML->{pkgmetadata}->{upstream}->{'remote-id'} } ) {
+sub make_format {
+ my ($format) = @_;
+ $format ||= 'JSON';
+ if ( $format eq 'JSON' ) {
+ goto &make_format_json;
+ }
+ if ( $format eq 'distlist' ) {
+ goto &make_format_distlist;
+ }
+ die "Unknown format type " . $format;
+}
- next if not exists $remote->{type};
- next unless $remote->{type} eq 'cpan';
+sub make_format_json {
+ require JSON;
+ my $encoder = JSON->new()->pretty->utf8->canonical;
+ return $encoder->encode($packages);
+}
- my $upstream = $remote->content();
+sub make_format_distlist {
+ return join qq{\n}, keys %{$packages};
+}
- if ( not defined $packages->{$upstream} ) {
- $packages->{$upstream} = [];
- }
- my $versions = [];
- my $record = {
- category => $c->{category_name},
- package => $c->{package_name},
- repository => $overlay_name,
- versions_gentoo => $versions,
- };
- $c->{package}->iterate( ebuilds => sub {
+sub handle_package {
+ my ( $self, $c ) = @_;
+ my $CP = $c->{category_name} . '/' . $c->{package_name};
+ my $xmlfile = $c->{package}->path->file('metadata.xml');
+ if ( not -e $xmlfile ) {
+ warn "\e[31mNo metadata.xml for $CP\e[0m\n";
+ return;
+ }
+ if ( not $cat or $c->{category_name} ne $cat ) {
+ *STDERR->print( "\nProcessing " . $c->{category_name} . " :" );
+ $cat = $c->{category_name};
+ }
+ *STDERR->print(".");
+ my $XML = XML::Smart->new( $xmlfile->absolute()->stringify() );
+ if ( not exists $XML->{pkgmetadata} ) {
+ warn "\e[31m<pkgmetadata> missing in $xmlfile\e[0m\n";
+ return;
+ }
+ if ( not exists $XML->{pkgmetadata}->{upstream} ) {
+
+ # warn "<pkgmetadata>/<upstream> missing in $xmlfile\n";
+ return;
+ }
+ if ( not exists $XML->{pkgmetadata}->{upstream}->{'remote-id'} ) {
+
+ # warn "<pkgmetadata>/<upstream>/<remote-id> missing in $xmlfile\n";
+ return;
+ }
+ for my $remote ( @{ $XML->{pkgmetadata}->{upstream}->{'remote-id'} } ) {
+
+ next if not exists $remote->{type};
+ next unless $remote->{type} eq 'cpan';
+
+ my $upstream = $remote->content();
+
+ if ( not defined $packages->{$upstream} ) {
+ $packages->{$upstream} = [];
+ }
+ my $versions = [];
+ my $record = {
+ category => $c->{category_name},
+ package => $c->{package_name},
+ repository => $c->{overlay_name},
+ versions_gentoo => $versions,
+ };
+ $c->{package}->iterate(
+ ebuilds => sub {
my ( $self, $d ) = @_;
my $version = $d->{ebuild_name};
- my $p = $c->{package_name};
+ my $p = $c->{package_name};
$version =~ s/\.ebuild$//;
$version =~ s/^\Q${p}\E-//;
push @{$versions}, $version;
- });
- push @{ $packages->{$upstream} }, $record;
+ }
+ );
+ push @{ $packages->{$upstream} }, $record;
- *STDERR->print("\e[32m $CP -> $upstream\e[0m ");
- }
+ *STDERR->print("\e[32m $CP -> $upstream\e[0m ");
}
-);
-my $out;
-if ( not $opts->long_opts->{format} ) {
- $opts->long_opts->{format} = "JSON";
-}
-if ( $opts->long_opts->{format} eq "JSON" ) {
- $out = $encoder->encode($packages);
}
-elsif ( $opts->long_opts->{format} eq 'distlist' ) {
- $out = join "\n", keys %{$packages};
-}
-else {
- die "Unknown format type " . $opts->long_opts->{format};
-}
-
-$dest->print($out);
-
0;
__DATA__
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-06-08 17:14 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-06-08 17:14 UTC (permalink / raw
To: gentoo-commits
commit: 406468434765876b6f42bb7bcdc6c883965b5b3b
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Fri Jun 8 17:13:41 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Fri Jun 8 17:13:41 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=40646843
[scripts/aggregate_tree.pl] add code to handle >1 remote_id field being declared
---
scripts/aggregate_tree.pl | 59 +++++++++++++++++++++-----------------------
1 files changed, 28 insertions(+), 31 deletions(-)
diff --git a/scripts/aggregate_tree.pl b/scripts/aggregate_tree.pl
index a719a26..f8f797e 100755
--- a/scripts/aggregate_tree.pl
+++ b/scripts/aggregate_tree.pl
@@ -83,38 +83,35 @@ $overlay->iterate(
# warn "<pkgmetadata>/<upstream>/<remote-id> missing in $xmlfile\n";
return;
}
- if ( not exists $XML->{pkgmetadata}->{upstream}->{'remote-id'}->{type} ) {
-
- # warn "remote type not specified for $CP";
- return;
- }
- if ( not $XML->{pkgmetadata}->{upstream}->{'remote-id'}->{type} eq 'cpan' ) {
-
- # warn "$CP: Not a CPAN remote: " . $XML->{pkgmetadata}->{upstream}->{'remote-id'}->{type} ;
- return;
- }
- my $upstream = $XML->{pkgmetadata}->{upstream}->{'remote-id'}->content();
- if ( not defined $packages->{$upstream} ) {
- $packages->{$upstream} = [];
+ for my $remote ( @{ $XML->{pkgmetadata}->{upstream}->{'remote-id'} } ) {
+
+ next if not exists $remote->{type};
+ next unless $remote->{type} eq 'cpan';
+
+ my $upstream = $remote->content();
+
+ if ( not defined $packages->{$upstream} ) {
+ $packages->{$upstream} = [];
+ }
+ my $versions = [];
+ my $record = {
+ category => $c->{category_name},
+ package => $c->{package_name},
+ repository => $overlay_name,
+ versions_gentoo => $versions,
+ };
+ $c->{package}->iterate( ebuilds => sub {
+ my ( $self, $d ) = @_;
+ my $version = $d->{ebuild_name};
+ my $p = $c->{package_name};
+ $version =~ s/\.ebuild$//;
+ $version =~ s/^\Q${p}\E-//;
+ push @{$versions}, $version;
+ });
+ push @{ $packages->{$upstream} }, $record;
+
+ *STDERR->print("\e[32m $CP -> $upstream\e[0m ");
}
- my $versions = [];
- my $record = {
- category => $c->{category_name},
- package => $c->{package_name},
- repository => $overlay_name,
- versions_gentoo => $versions,
- };
- $c->{package}->iterate( ebuilds => sub {
- my ( $self, $d ) = @_;
- my $version = $d->{ebuild_name};
- my $p = $c->{package_name};
- $version =~ s/\.ebuild$//;
- $version =~ s/^\Q${p}\E-//;
- push @{$versions}, $version;
- });
- push @{ $packages->{$upstream} }, $record;
-
- *STDERR->print("\e[32m $CP -> $upstream\e[0m ");
}
);
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-05-27 2:30 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-05-27 2:30 UTC (permalink / raw
To: gentoo-commits
commit: d51b923bbd197215a0df11f459b215147aa1bcba
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun May 27 02:28:24 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sun May 27 02:28:56 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=d51b923b
[scripts/gen_ebuild.pl] Add BSD to the License map
---
scripts/gen_ebuild.pl | 1 +
1 files changed, 1 insertions(+), 0 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index b6c1f9b..7c89f45 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -169,6 +169,7 @@ my $licmap = {
lgpl_2_1 => [qw( LGPL-2.1 )],
artistic_2 => [qw( Artistic-2 )],
gpl_3 => [qw( GPL-3 )],
+ bsd => [qw( BSD )],
};
my $oddlic = {
open_source => sub {
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-04-28 10:40 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-04-28 10:40 UTC (permalink / raw
To: gentoo-commits
commit: 2105ca92e27d14160374ce5a34a1a6a5da86cc24
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sat Apr 28 09:37:56 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sat Apr 28 10:30:39 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=2105ca92
Specialcase gen_ebuild for open_source
---
scripts/gen_ebuild.pl | 9 +++++++++
1 files changed, 9 insertions(+), 0 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index f742a9b..b6c1f9b 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -170,11 +170,20 @@ my $licmap = {
artistic_2 => [qw( Artistic-2 )],
gpl_3 => [qw( GPL-3 )],
};
+my $oddlic = {
+ open_source => sub {
+ warn "\n \e[31m*\e[0m User defined license in the metadata is 'open_source', which could mean any of: gpl, lgpl or mozilla. Please check Makefile/Build.PL"
+ . "\n This is due to: https://metacpan.org/source/DAGOLDEN/CPAN-Meta-2.120921/lib/CPAN/Meta/Converter.pm#L155\n";
+ },
+};
for my $lic ( @{ $release_info->{license} } ) {
if ( exists $licmap->{$lic} ) {
push @$lics, @{ $licmap->{$lic} };
}
+ elsif ( exists $oddlic->{$lic} ) {
+ $oddlic->{$lic}->();
+ }
else {
warn "No Gentoo maping listed for $lic license type";
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-04-18 3:32 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-04-18 3:32 UTC (permalink / raw
To: gentoo-commits
commit: c2ff7063d813e5307db436ee38cb48035aa541f3
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed Apr 18 01:32:57 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Wed Apr 18 01:32:57 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=c2ff7063
[scripts/package_map_all.pl] Update to handle the modified data format
---
scripts/package_map_all.pl | 22 ++++++++++++++++------
1 files changed, 16 insertions(+), 6 deletions(-)
diff --git a/scripts/package_map_all.pl b/scripts/package_map_all.pl
index b0bf814..351cd63 100755
--- a/scripts/package_map_all.pl
+++ b/scripts/package_map_all.pl
@@ -40,16 +40,26 @@ my $decoder = JSON->new()->utf8->relaxed;
my $encoder = JSON->new()->pretty->utf8->canonical;
my %lookup;
+my %g_repos;
{
for my $file (@json_files) {
+ my %repos;
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};
+ my $nodes = $decoder->decode( scalar $file->slurp );
+
+ say " Found " . ( scalar keys %{$nodes} ) . " distributions";
+ for ( keys %{$nodes} ) {
+ my $records = $nodes->{$_};
+ $lookup{$_}++;
+ for my $rec ( @{ $records }) {
+ my $repo = $rec->{repository};
+ $repos{$repo}++;
+ }
+ }
+ say " $_ : " . $repos{$_} for keys %repos;
+ for ( keys %repos ) {
+ $g_repos{$_} += $repos{$_};
}
}
say "* Found: " . ( scalar keys %lookup ) . " unique distributions";
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-04-18 3:32 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-04-18 3:32 UTC (permalink / raw
To: gentoo-commits
commit: b2800087a6719b8b9df1732d7ecdac3f5fab8b06
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed Apr 18 03:25:51 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Wed Apr 18 03:25:51 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=b2800087
[scripts/package_map_all.pl] hacks to get around the abysmal speed I experienced today with the API, request batching and ssl stuff
---
scripts/package_map_all.pl | 120 +++++++++++++++++++++++++------------------
1 files changed, 70 insertions(+), 50 deletions(-)
diff --git a/scripts/package_map_all.pl b/scripts/package_map_all.pl
index 351cd63..8bb260e 100755
--- a/scripts/package_map_all.pl
+++ b/scripts/package_map_all.pl
@@ -28,7 +28,8 @@ if ( $optparse->has_long_opt('root') ) {
$root = Path::Class::Dir->new( $optparse->long_opt('root') );
}
-my $size = 1000;
+my $size = 500;
+my $scroll_time = '20m';
my $metadata = $root->subdir( 'metadata', 'perl' );
my $distmap = $metadata->subdir('distmap');
@@ -52,7 +53,7 @@ my %g_repos;
for ( keys %{$nodes} ) {
my $records = $nodes->{$_};
$lookup{$_}++;
- for my $rec ( @{ $records }) {
+ for my $rec ( @{$records} ) {
my $repo = $rec->{repository};
$repos{$repo}++;
}
@@ -72,58 +73,17 @@ my %g_repos;
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,
- {
- headers => { 'Accept-Encoding' => 'gzip', },
- content => $encoder->encode($search),
- }
-);
-
-say $results_string->{content};
-
-my $results = $decoder->decode( $results_string->{content} );
-my $scroll_id = $results->{_scroll_id};
+my $dtree;
-my $total_results = $results->{hits}->{total};
+my $seen = 0;
-say "Found: $total_results releases";
+use List::MoreUtils qw( natatime );
-my $dtree;
-my $seen = 0;
+my $it = natatime 500, @dists;
-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";
+while ( my @dists_batch = $it->() ) {
+ get_data_for(@dists_batch);
}
-
for my $package ( sort keys %{$dtree} ) {
say "Sorting $package";
$dtree->{$package} = [ sort { $b->{date} cmp $a->{date} } @{ $dtree->{$package} } ];
@@ -134,14 +94,74 @@ $fh->print( $encoder->encode($dtree) );
exit 0;
+sub get_data_for {
+ my (@items) = @_;
+ my $search = {};
+ $search->{query} = { constant_score => { filter => { terms => { distribution => [@items] } } } };
+ $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',
+ 'https://api.metacpan.org/release/_search?search_type=scan&scroll=' . $scroll_time . '&size=' . $size,
+ {
+ headers => { 'Accept-Encoding' => 'gzip', },
+ content => $encoder->encode($search),
+ }
+ );
+
+ my $results = $decoder->decode( $results_string->{content} );
+ my $scroll_id = $results->{_scroll_id};
+
+ my $total_results = $results->{hits}->{total};
+
+ say "Found: $total_results releases";
+ $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";
+ }
+
+}
+
sub scroll {
my ($id) = @_;
my $result = mcpan->ua->request(
'GET',
- 'http://api.metacpan.org/_search/scroll/?scroll=30s&size=' . $size . '&scroll_id=' . $id,
+ 'https://api.metacpan.org/_search/scroll/?scroll=' . $scroll_time . '&size=' . $size . '&scroll_id=' . $id,
{ headers => { 'Accept-Encoding' => 'gzip', } }
);
+ if ( $result->{content} =~ /Server Error/ ) {
+ require Data::Dump;
+ Data::Dump::pp( { result => $result, size => $size, scroll_id => $id } );
+ die;
+ }
+ else {
+ #require Data::Dump;
+ #Data::Dump::pp( { result => { %{$result}, content => '...' }, size => $size, scroll_id => $id } );
+ }
my $data = $decoder->decode( $result->{content} );
return $data, $data->{_scroll_id};
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-04-18 3:32 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-04-18 3:32 UTC (permalink / raw
To: gentoo-commits
commit: 871aaebc3151f4514244fae929f461fcde0dab1b
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed Apr 18 01:19:48 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Wed Apr 18 01:19:48 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=871aaebc
[scripts/aggregate_tree.pl] Reorganise the data structure emitted, and emit gentoo related data as individual tokens ( ie: cat/pkg/repo ), along with exporting an array of found versions, allowing for one cpan-id to simultaneously occur in multiple packages , or multiple categories, or multiple repositories, within the same dataset
---
scripts/aggregate_tree.pl | 30 +++++++++++++++++++++++++-----
1 files changed, 25 insertions(+), 5 deletions(-)
diff --git a/scripts/aggregate_tree.pl b/scripts/aggregate_tree.pl
index c2e3c55..a719a26 100755
--- a/scripts/aggregate_tree.pl
+++ b/scripts/aggregate_tree.pl
@@ -34,11 +34,12 @@ if ( defined $opts->long_opts->{root} ) {
}
my $overlay = Gentoo::Overlay->new( path => $root );
+my $overlay_name = $overlay->name;
use JSON;
my $data;
-my $packages = $data->{ $overlay->name } = {};
+my $packages = $data->{ $overlay_name } = {};
my $encoder = JSON->new()->pretty->utf8->canonical;
@@ -52,7 +53,7 @@ else {
$dest = $file->openw( iomode => ':utf8' );
}
-my $cat;
+my $cat;
$|++;
$overlay->iterate(
'packages' => sub {
@@ -63,7 +64,7 @@ $overlay->iterate(
warn "\e[31mNo metadata.xml for $CP\e[0m\n";
return;
}
- if( $c->{category_name} ne $cat ) {
+ if( not $cat or $c->{category_name} ne $cat ) {
*STDERR->print("\nProcessing " . $c->{category_name} . " :");
$cat = $c->{category_name};
}
@@ -93,7 +94,26 @@ $overlay->iterate(
return;
}
my $upstream = $XML->{pkgmetadata}->{upstream}->{'remote-id'}->content();
- $packages->{$upstream} = $CP;
+ if ( not defined $packages->{$upstream} ) {
+ $packages->{$upstream} = [];
+ }
+ my $versions = [];
+ my $record = {
+ category => $c->{category_name},
+ package => $c->{package_name},
+ repository => $overlay_name,
+ versions_gentoo => $versions,
+ };
+ $c->{package}->iterate( ebuilds => sub {
+ my ( $self, $d ) = @_;
+ my $version = $d->{ebuild_name};
+ my $p = $c->{package_name};
+ $version =~ s/\.ebuild$//;
+ $version =~ s/^\Q${p}\E-//;
+ push @{$versions}, $version;
+ });
+ push @{ $packages->{$upstream} }, $record;
+
*STDERR->print("\e[32m $CP -> $upstream\e[0m ");
}
);
@@ -103,7 +123,7 @@ if ( not $opts->long_opts->{format} ) {
$opts->long_opts->{format} = "JSON";
}
if ( $opts->long_opts->{format} eq "JSON" ) {
- $out = $encoder->encode($data);
+ $out = $encoder->encode($packages);
}
elsif ( $opts->long_opts->{format} eq 'distlist' ) {
$out = join "\n", keys %{$packages};
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-04-12 19:46 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-04-12 19:46 UTC (permalink / raw
To: gentoo-commits
commit: c9f00684dff3f22dc4e2ffdaeb994396dfc9becb
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Thu Apr 12 19:45:21 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Thu Apr 12 19:45:21 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=c9f00684
[scripts] Increase the scroll size, which works more efficiently now gzip is enabled
---
scripts/package_map_all.pl | 2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/scripts/package_map_all.pl b/scripts/package_map_all.pl
index 8b37bd2..b0bf814 100755
--- a/scripts/package_map_all.pl
+++ b/scripts/package_map_all.pl
@@ -28,7 +28,7 @@ if ( $optparse->has_long_opt('root') ) {
$root = Path::Class::Dir->new( $optparse->long_opt('root') );
}
-my $size = 300;
+my $size = 1000;
my $metadata = $root->subdir( 'metadata', 'perl' );
my $distmap = $metadata->subdir('distmap');
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-04-09 16:05 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-04-09 16:05 UTC (permalink / raw
To: gentoo-commits
commit: 7263e878fa21e0e29186e1586f2dd3fd255d1e3d
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Apr 9 15:29:26 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Apr 9 15:29:26 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=7263e878
[scripts] Turn on GZIP encoding to make package_map_all faster
---
scripts/package_map_all.pl | 14 +++++++++-----
1 files changed, 9 insertions(+), 5 deletions(-)
diff --git a/scripts/package_map_all.pl b/scripts/package_map_all.pl
index a22355b..8b37bd2 100755
--- a/scripts/package_map_all.pl
+++ b/scripts/package_map_all.pl
@@ -33,8 +33,6 @@ 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;
@@ -90,7 +88,10 @@ $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), }
+ {
+ headers => { 'Accept-Encoding' => 'gzip', },
+ content => $encoder->encode($search),
+ }
);
say $results_string->{content};
@@ -125,8 +126,11 @@ 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 $result = mcpan->ua->request(
+ 'GET',
+ 'http://api.metacpan.org/_search/scroll/?scroll=30s&size=' . $size . '&scroll_id=' . $id,
+ { headers => { 'Accept-Encoding' => 'gzip', } }
+ );
my $data = $decoder->decode( $result->{content} );
return $data, $data->{_scroll_id};
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-04-08 13:20 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-04-08 13:20 UTC (permalink / raw
To: gentoo-commits
commit: e1327f45165acc0e83ec0cbf9cf370c93bd814db
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Apr 8 13:19:46 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sun Apr 8 13:19:46 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=e1327f45
[scripts/package_map] add a canonical package name string that works with some cliens ( ie: cpanm AUTHOR/foobaz.tar.z ) , reorganise some of the version values
---
scripts/package_map.pl | 5 +++--
1 files changed, 3 insertions(+), 2 deletions(-)
diff --git a/scripts/package_map.pl b/scripts/package_map.pl
index cdc306f..3b0abec 100755
--- a/scripts/package_map.pl
+++ b/scripts/package_map.pl
@@ -72,8 +72,9 @@ for my $result ( @{ $results->{hits}->{hits} } ) {
my $cdistrib = $fields->{distribution};
$cversion =~ s/^${cdistrib}-//;
- $fields->{canon_version} = $cversion;
- $fields->{gentoo_version} = scalar try { gv( $cversion , { lax => 1 } ) };
+ $fields->{version_canon} = $cversion;
+ $fields->{version_gentoo} = scalar try { gv( $cversion , { lax => 1 } ) };
+ $fields->{archive_canon} = $fields->{author} . '/' . $fields->{archive};
$data->{ $cdistrib } = [] unless exists $data->{ $cdistrib };
push @{ $data->{ $cdistrib } }, $fields ;
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-04-08 13:20 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-04-08 13:20 UTC (permalink / raw
To: gentoo-commits
commit: 86cf3771522cae084ec11a50aa85401504489cfc
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Apr 8 13:14:30 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sun Apr 8 13:14:30 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=86cf3771
[scripts] add scripts/package_map.pl which emits all useful metadata for all versions of a given distribution
---
scripts/package_map.pl | 132 ++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 132 insertions(+), 0 deletions(-)
diff --git a/scripts/package_map.pl b/scripts/package_map.pl
new file mode 100755
index 0000000..cdc306f
--- /dev/null
+++ b/scripts/package_map.pl
@@ -0,0 +1,132 @@
+#!/usr/bin/env perl
+
+eval 'echo "Called with something not perl"' && exit 1 # Non-Perl protection.
+ if 0;
+
+use 5.14.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 optparse;
+
+# FILENAME: pvlist.pl
+# CREATED: 16/10/11 20:16:03 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Show dist metadata for interesting perl dists
+
+# DEPENDENCIES:
+#
+# * MetaCPAN::API
+# * CHI
+# * WWW::Mechanize::Cached
+# * HTTP::Tiny::Mech
+# * Data::Dump
+# * Gentoo::PerlMod::Version
+#
+
+my $optparse = optparse->new(
+ argv => \@ARGV,
+ help => sub { print help(); },
+);
+my $search = {};
+$search->{query} = { constant_score => { filter => { terms => { distribution => $optparse->extra_opts } } } };
+$search->{sort} = [ { 'date' => 'desc', }, ];
+$search->{size} = 5000;
+$search->{fields} = [qw(
+ abstract
+ archive
+ author
+ authorized
+ date
+ distribution
+ download_url
+ license
+ maturity
+ name
+ status
+ version
+)];
+
+_log( ['initialized: fetching search results'] );
+
+my $results = mcpan->post( 'release/_search', $search );
+
+_log( [ 'fetched %s results', scalar @{ $results->{hits}->{hits} } ] );
+
+my $data = {};
+
+
+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}-//;
+
+ $fields->{canon_version} = $cversion;
+ $fields->{gentoo_version} = scalar try { gv( $cversion , { lax => 1 } ) };
+ $data->{ $cdistrib } = [] unless exists $data->{ $cdistrib };
+ push @{ $data->{ $cdistrib } }, $fields ;
+}
+
+require JSON;
+
+my $encode = JSON->new->pretty->utf8->canonical;
+say $encode->encode( $data );
+
+exit 0;
+
+# Utils
+
+sub pp { require Data::Dump; goto \&Data::Dump::pp }
+sub gv { require Gentoo::PerlMod::Version; goto \&Gentoo::PerlMod::Version::gentooize_version }
+
+sub _log {
+ return unless $optparse->long_opts->{trace};
+ return *STDERR->print(@_) if ( not ref $_[0] );
+
+ state $prefix = "\e[7m* package_map.pl:\e[0m ";
+
+ my ( $str, @args ) = @{ $_[0] };
+ $str =~ s/\n?$/\n/;
+
+ *STDERR->print($prefix);
+ *STDERR->printf( $str, @args );
+ return;
+
+}
+
+
+
+sub help {
+ return <<"EOF";
+package_map.pl
+
+USAGE:
+
+ package_map.pl PACKAGE [PACKAGE*][--help] [--trace]
+
+ ie:
+
+ # Show full metadata for Moose, Catalyst-Runtime and Dist-Zilla
+ package_log.pl Moose Catalyst-Runtime Dist-Zilla
+
+ # Be verbose about what we're doing
+ package_log.pl Moose --trace
+
+ --help Show this message
+ --trace Turn on extra debugging.
+
+EOF
+
+}
+
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-04-05 10:02 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-04-05 10:02 UTC (permalink / raw
To: gentoo-commits
commit: 1c7feeecca0a29934046cd02961022a3c1a4efe8
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Thu Apr 5 10:01:36 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Thu Apr 5 10:01:36 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=1c7feeec
[scripts/aggregate_tree.pl] Be more verbose about scraping the overlay/repo
---
scripts/aggregate_tree.pl | 16 ++++++++++------
1 files changed, 10 insertions(+), 6 deletions(-)
diff --git a/scripts/aggregate_tree.pl b/scripts/aggregate_tree.pl
index 1e3f1c1..c2e3c55 100755
--- a/scripts/aggregate_tree.pl
+++ b/scripts/aggregate_tree.pl
@@ -52,25 +52,28 @@ else {
$dest = $file->openw( iomode => ':utf8' );
}
+my $cat;
+$|++;
$overlay->iterate(
'packages' => sub {
my ( $self, $c ) = @_;
my $CP = $c->{category_name} . '/' . $c->{package_name};
my $xmlfile = $root->subdir( $c->{category_name}, $c->{package_name} )->file('metadata.xml');
if ( not -e $xmlfile ) {
- warn "No metadata.xml for $CP\n";
+ warn "\e[31mNo metadata.xml for $CP\e[0m\n";
return;
}
-
- # warn "Processing $xmlfile\n";
+ if( $c->{category_name} ne $cat ) {
+ *STDERR->print("\nProcessing " . $c->{category_name} . " :");
+ $cat = $c->{category_name};
+ }
+ *STDERR->print(".");
my $XML = XML::Smart->new( $xmlfile->absolute()->stringify() );
if ( not exists $XML->{pkgmetadata} ) {
-
- # warn "<pkgmetadata> missing in $xmlfile\n";
+ warn "\e[31m<pkgmetadata> missing in $xmlfile\e[0m\n";
return;
}
if ( not exists $XML->{pkgmetadata}->{upstream} ) {
-
# warn "<pkgmetadata>/<upstream> missing in $xmlfile\n";
return;
}
@@ -91,6 +94,7 @@ $overlay->iterate(
}
my $upstream = $XML->{pkgmetadata}->{upstream}->{'remote-id'}->content();
$packages->{$upstream} = $CP;
+ *STDERR->print("\e[32m $CP -> $upstream\e[0m ");
}
);
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-03-27 1:26 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-03-27 1:26 UTC (permalink / raw
To: gentoo-commits
commit: 856a602970ba9b3d31b12247c64255dcf0b6b847
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Mar 5 11:21:42 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Mar 5 11:21:42 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=856a6029
[scripts/aggregate_tree.pl] declare perl dep is only 5.12
---
scripts/aggregate_tree.pl | 2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/scripts/aggregate_tree.pl b/scripts/aggregate_tree.pl
index d4c5bfa..1e3f1c1 100755
--- a/scripts/aggregate_tree.pl
+++ b/scripts/aggregate_tree.pl
@@ -3,7 +3,7 @@
eval 'echo "Called with something not perl"' && exit 1 # Non-Perl protection.
if 0;
-use 5.14.2;
+use 5.12.2;
use strict;
use warnings;
^ permalink raw reply related [flat|nested] 63+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-03-27 1:26 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-03-27 1:26 UTC (permalink / raw
To: gentoo-commits
commit: cf352a74150e28c06f15b801e9edf239ffcc4be7
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Mar 5 14:52:30 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Mar 5 14:52:30 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=cf352a74
[scripts/fixvdep.pl] Clarify usage in documentation
---
scripts/fixvdep.pl | 13 +++++++++++++
1 files changed, 13 insertions(+), 0 deletions(-)
diff --git a/scripts/fixvdep.pl b/scripts/fixvdep.pl
old mode 100644
new mode 100755
index 3a77406..7f16464
--- a/scripts/fixvdep.pl
+++ b/scripts/fixvdep.pl
@@ -6,7 +6,20 @@ use warnings;
# CREATED: 12/11/11 00:52:15 by Kent Fredric (kentnl) <kentfredric@gmail.com>
# ABSTRACT: Fix up version deps on a specific package in (a) given ebuild(s)
+if ( not @ARGV or grep { /-h|--help/ } @ARGV ) {
+ print <<"MSG";
+ Usage:
+
+ fixvdep.pl Perl-Module-Name oldformat newformat \@files;
+
+ ie:
+
+ fixdep.pl Moose 0.91 0.910.0 ./*/*.ebuild
+
+MSG
+ exit 0;
+}
my ( $pkg, $oldversion , $newversion , @files ) = @ARGV;
@ARGV = ();
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-03-27 1:26 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-03-27 1:26 UTC (permalink / raw
To: gentoo-commits
commit: 7c3ce3011aeb5e2731c61ab34f2e9aec9b9ff591
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Mar 27 01:18:35 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Tue Mar 27 01:18:35 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=7c3ce301
make module_log run on older perls
---
scripts/module_log.pl | 4 ++--
1 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/scripts/module_log.pl b/scripts/module_log.pl
index f92ec36..fa060d0 100755
--- a/scripts/module_log.pl
+++ b/scripts/module_log.pl
@@ -3,7 +3,7 @@
eval 'echo "Called with something not perl"' && exit 1 # Non-Perl protection.
if 0;
-use 5.14.2;
+use 5.12.2;
use strict;
use warnings;
use FindBin;
@@ -72,7 +72,7 @@ EOF
use Data::Dump qw( pp );
-my ($release) = shift( $optparse->extra_opts );
+my ($release) = shift( @{$optparse->extra_opts} );
my (@data) = metacpan->find_dist_simple( $release, $optparse->long_opts );
if ( not $optparse->long_opts->{dump} ) {
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-03-01 11:38 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-03-01 11:38 UTC (permalink / raw
To: gentoo-commits
commit: 6fa0b2554f692f7be8e2e861be0b6a0d86fd5a5e
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Thu Mar 1 11:38:01 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Thu Mar 1 11:38:01 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=6fa0b255
[scripts/gen_ebuild.pl] add gpl_3 license mapping
---
scripts/gen_ebuild.pl | 1 +
1 files changed, 1 insertions(+), 0 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index d1fd4eb..f742a9b 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -168,6 +168,7 @@ my $licmap = {
mit => [qw( MIT )],
lgpl_2_1 => [qw( LGPL-2.1 )],
artistic_2 => [qw( Artistic-2 )],
+ gpl_3 => [qw( GPL-3 )],
};
for my $lic ( @{ $release_info->{license} } ) {
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-29 12:22 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-29 12:22 UTC (permalink / raw
To: gentoo-commits
commit: 603b79f0816ba142fb36ee07fe2a9989ec1a9c17
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed Feb 29 12:22:37 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Wed Feb 29 12:22:37 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=603b79f0
[scripts/package_log.pl] improve documentation for --help
---
scripts/package_log.pl | 4 ++++
1 files changed, 4 insertions(+), 0 deletions(-)
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index 89d85e5..0528d93 100755
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -266,6 +266,10 @@ USAGE:
--trace Turn on extra debugging.
--nosummarize Do no processing of Changes data and report it verbatim
( Useful when CPAN::Changes gets it wrong :( )
+
+ --from=2001-08-28T05:38:23.000Z # Starting time ( Defaults to somewhere in October 2011 )
+ --to= sdfas # Stopping time ( Defaults to unset == now )
+
EOF
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-29 12:22 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-29 12:22 UTC (permalink / raw
To: gentoo-commits
commit: b2b4a679093ef53090421d89ac5458435a93eed5
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed Feb 29 12:15:15 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Wed Feb 29 12:15:15 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=b2b4a679
add --from and --to timestamp range controls
---
scripts/package_log.pl | 16 ++++++++++++----
1 files changed, 12 insertions(+), 4 deletions(-)
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index dc1a877..89d85e5 100755
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -47,16 +47,24 @@ my $search = {};
my $and = [];
+if ( $optparse->long_opts->{from} ) {
+ $oldest_date = $optparse->long_opts->{from};
+}
+my @to;
+if ( my $ts = $optparse->long_opts->{to} ) {
+ @to = ( to => $ts );
+}
+
if ( not $optparse->long_opts->{all} ) {
- push @{$and}, {
+ push @{$and},
+ {
range => {
date => {
from => $oldest_date,
-
- #to => $newest_date,
+ @to,
}
}
- };
+ };
}
#my $or = [];
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-29 12:06 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-29 12:06 UTC (permalink / raw
To: gentoo-commits
commit: 33f583a57d7d1c7cb6b58e261725c6bfa723b995
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed Feb 29 12:04:49 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Wed Feb 29 12:04:49 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=33f583a5
[scripts/gen_ebuild.pl] add artistic_1 license to map
---
scripts/gen_ebuild.pl | 1 +
1 files changed, 1 insertions(+), 0 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 2d9d1e5..d1fd4eb 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -164,6 +164,7 @@ my $lics = [];
my $licmap = {
perl_5 => [qw( Artistic GPL-2 )],
apache_2_0 => [qw( Apache-2.0 )],
+ artistic_1 => [qw( Artistic )],
mit => [qw( MIT )],
lgpl_2_1 => [qw( LGPL-2.1 )],
artistic_2 => [qw( Artistic-2 )],
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-28 21:55 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-28 21:55 UTC (permalink / raw
To: gentoo-commits
commit: 77d2781c0c39aefb6411714dbd374a0640b60191
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Feb 28 21:48:32 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Tue Feb 28 21:48:32 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=77d2781c
[scripts:new] aggregate_tree.pl, harvest <remote-id type=cpan> data into a big JSON file/list of dists
---
scripts/aggregate_tree.pl | 138 +++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 138 insertions(+), 0 deletions(-)
diff --git a/scripts/aggregate_tree.pl b/scripts/aggregate_tree.pl
new file mode 100755
index 0000000..d4c5bfa
--- /dev/null
+++ b/scripts/aggregate_tree.pl
@@ -0,0 +1,138 @@
+#!/usr/bin/env perl
+
+eval 'echo "Called with something not perl"' && exit 1 # Non-Perl protection.
+ if 0;
+
+use 5.14.2;
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use env::gentoo::perl_experimental;
+use optparse;
+use utf8;
+use Data::Dump qw( pp );
+use Gentoo::Overlay;
+
+# FILENAME: aggregate_tree.pl
+# CREATED: 29/02/12 07:37:54 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Connect all the cpan id's from the metadata.xml
+
+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;
+
+if ( defined $opts->long_opts->{root} ) {
+ $root = Path::Class::Dir->new( $opts->long_opts->{root} );
+}
+my $overlay = Gentoo::Overlay->new( path => $root );
+
+use JSON;
+
+my $data;
+
+my $packages = $data->{ $overlay->name } = {};
+
+my $encoder = JSON->new()->pretty->utf8->canonical;
+
+my $dest = \*STDOUT;
+if ( not $opts->long_opts->{output} or $opts->long_opts->{output} eq '-' ) {
+ $dest = \*STDOUT;
+}
+else {
+ use Path::Class::File;
+ my $file = Path::Class::File->new( $opts->long_opts->{output} )->absolute();
+ $dest = $file->openw( iomode => ':utf8' );
+}
+
+$overlay->iterate(
+ 'packages' => sub {
+ my ( $self, $c ) = @_;
+ my $CP = $c->{category_name} . '/' . $c->{package_name};
+ my $xmlfile = $root->subdir( $c->{category_name}, $c->{package_name} )->file('metadata.xml');
+ if ( not -e $xmlfile ) {
+ warn "No metadata.xml for $CP\n";
+ return;
+ }
+
+ # warn "Processing $xmlfile\n";
+ my $XML = XML::Smart->new( $xmlfile->absolute()->stringify() );
+ if ( not exists $XML->{pkgmetadata} ) {
+
+ # warn "<pkgmetadata> missing in $xmlfile\n";
+ return;
+ }
+ if ( not exists $XML->{pkgmetadata}->{upstream} ) {
+
+ # warn "<pkgmetadata>/<upstream> missing in $xmlfile\n";
+ return;
+ }
+ if ( not exists $XML->{pkgmetadata}->{upstream}->{'remote-id'} ) {
+
+ # warn "<pkgmetadata>/<upstream>/<remote-id> missing in $xmlfile\n";
+ return;
+ }
+ if ( not exists $XML->{pkgmetadata}->{upstream}->{'remote-id'}->{type} ) {
+
+ # warn "remote type not specified for $CP";
+ return;
+ }
+ if ( not $XML->{pkgmetadata}->{upstream}->{'remote-id'}->{type} eq 'cpan' ) {
+
+ # warn "$CP: Not a CPAN remote: " . $XML->{pkgmetadata}->{upstream}->{'remote-id'}->{type} ;
+ return;
+ }
+ my $upstream = $XML->{pkgmetadata}->{upstream}->{'remote-id'}->content();
+ $packages->{$upstream} = $CP;
+ }
+);
+
+my $out;
+if ( not $opts->long_opts->{format} ) {
+ $opts->long_opts->{format} = "JSON";
+}
+if ( $opts->long_opts->{format} eq "JSON" ) {
+ $out = $encoder->encode($data);
+}
+elsif ( $opts->long_opts->{format} eq 'distlist' ) {
+ $out = join "\n", keys %{$packages};
+}
+else {
+ die "Unknown format type " . $opts->long_opts->{format};
+}
+
+$dest->print($out);
+
+0;
+
+__DATA__
+
+This script scrapes the perl repository and finds all the metadata.xml files
+ and makes a mapping file connecting categories to upstream dists.
+
+Usage:
+
+ aggregate_tree.pl
+
+ By default uses the perl-experimental overlay as a working dir, and emits JSON to stdout
+
+ aggregate_tree.pl
+
+ --root="/path/to/some/root"
+
+ Specifiy another root to scan ( ie: /usr/portage )
+
+ --format=JSON # Emit JSON ( Default )
+ --format=distlist # Emit a list of CPAN Dist Names
+
+ --output=- # Write to standard output ( Default )
+ --output="/path/to/file" # Write to the specified file
+
+
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-28 21:55 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-28 21:55 UTC (permalink / raw
To: gentoo-commits
commit: c7b4fddfc61341e6a0e7e82e98a84e2fe0e51db8
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Feb 28 21:45:00 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Tue Feb 28 21:45:00 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=c7b4fddf
[scripts] Rehash module_log.pl to use optparse lib
---
scripts/module_log.pl | 40 ++++++++++++----------------------------
1 files changed, 12 insertions(+), 28 deletions(-)
diff --git a/scripts/module_log.pl b/scripts/module_log.pl
index 92f976b..f92ec36 100755
--- a/scripts/module_log.pl
+++ b/scripts/module_log.pl
@@ -9,30 +9,13 @@ use warnings;
use FindBin;
use lib "$FindBin::Bin/lib";
use env::gentoo::perl_experimental;
+use optparse;
use metacpan qw( mcpan );
-my $flags;
-my $singleflags;
-
-@ARGV = grep { defined } map {
- $_ =~ /^--(.+)/
- ? do { $flags->{$1}++; undef }
- : do {
- $_ =~ /^-(.+)/
- ? 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; }
-
-sub help {
- return <<'EOF';
+my $optparse = optparse->new(
+ argv => \@ARGV,
+ help => sub {
+ return print <<'EOF';
module_log.pl
USAGE:
@@ -75,7 +58,8 @@ USAGE:
#
EOF
-}
+ },
+);
# FILENAME: module_log.pl
# CREATED: 25/10/11 12:15:51 by Kent Fredric (kentnl) <kentfredric@gmail.com>
@@ -88,17 +72,17 @@ EOF
use Data::Dump qw( pp );
-my ($release) = shift(@ARGV);
+my ($release) = shift( $optparse->extra_opts );
-my (@data) = metacpan->find_dist_simple( $release, $flags );
-if( not $flags->{dump} ) {
+my (@data) = metacpan->find_dist_simple( $release, $optparse->long_opts );
+if ( not $optparse->long_opts->{dump} ) {
my $result = [ map { $_->{as_string} } @data ];
use JSON qw( to_json );
say to_json( $result, { pretty => 1 } );
-} else {
+}
+else {
pp $_ for @data;
}
1;
-
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-28 21:55 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-28 21:55 UTC (permalink / raw
To: gentoo-commits
commit: cb988b42b74fc9a5b4715df7122db7eb01d3e4ba
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Feb 28 21:46:55 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Tue Feb 28 21:46:55 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=cb988b42
[scripts/package_log.pl] update to use optparser , fix bug that was preventing specifiying multiple packages
---
scripts/package_log.pl | 78 ++++++++++++++++++++++-------------------------
1 files changed, 37 insertions(+), 41 deletions(-)
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index 22e571d..dc1a877 100755
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -14,6 +14,7 @@ use env::gentoo::perl_experimental;
use metacpan qw( mcpan );
use Term::ANSIColor qw( :constants );
use Try::Tiny;
+use optparse;
use coloriterator
coloriser => { -as => 'author_colour' },
coloriser => { -as => 'dist_colour' };
@@ -34,20 +35,10 @@ use coloriterator
# * CPAN::Changes
#
-my $flags;
-my $singleflags;
-
-@ARGV = grep { defined } map {
- $_ =~ /^--(\w+)/
- ? do { $flags->{$1}++; undef }
- : do {
- $_ =~ /^-(\w+)/
- ? do { $singleflags->{$1}++; undef }
- : do { $_ }
- }
-} @ARGV;
-
-if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
+my $optparse = optparse->new(
+ argv => \@ARGV,
+ help => sub { print help(); },
+);
my $oldest_date = '2011-10-01T00:00:00.000Z';
my $newest_date = '2012-02-01T00:00:00.000Z';
@@ -56,46 +47,51 @@ my $search = {};
my $and = [];
-if ( not $flags->{all} ) {
- push @{$and}, {
- range => {
- date => {
- from => $oldest_date,
- #to => $newest_date,
- }
- }
- };
-}
+if ( not $optparse->long_opts->{all} ) {
+ push @{$and}, {
+ range => {
+ date => {
+ from => $oldest_date,
-push @{$and} , {
- term => {
- 'distribution' => @ARGV,
-# minimum_match => 1,
+ #to => $newest_date,
+ }
}
-};
+ };
+}
+
+#my $or = [];
-$search->{query} = {
- constant_score => {
- filter => {
- and => $and,
- }
- }
+#for my $dist ( @{ $optparse->extra_opts } ) {
+
+push @{$and}, {
+ terms => {
+ 'distribution' => $optparse->extra_opts,
+
+ # minimum_match => 1,
+ }
};
+#}
+
+#push @{$and}, {
+# or => $or,
+#};
+
+$search->{query} = { constant_score => { filter => { and => $and, } } };
+
$search->{sort} = [
# { 'author' => 'asc', },
{ 'date' => 'desc', },
];
-$search->{size} = 10;
+$search->{size} = 10000;
$search->{fields} = [qw( author name date distribution version )];
-if ( $flags->{deps} ) {
+if ( $optparse->long_opts->{deps} ) {
push @{ $search->{fields} }, '_source.dependency';
}
-
_log( ['initialized: fetching search results'] );
my $results = mcpan->post( 'release/_search', $search );
@@ -106,7 +102,7 @@ for my $result ( @{ $results->{hits}->{hits} } ) {
# use Data::Dump qw(pp);
# pp $result;
- say $_ for format_result( $result->{fields}, $flags );
+ say $_ for format_result( $result->{fields}, $optparse->long_opts );
}
exit 0;
@@ -119,7 +115,7 @@ sub pp { require Data::Dump; goto \&Data::Dump::pp }
sub gv { require Gentoo::PerlMod::Version; goto \&Gentoo::PerlMod::Version::gentooize_version }
sub _log {
- return unless $flags->{trace};
+ return unless $optparse->long_opts->{trace};
return *STDERR->print(@_) if ( not ref $_[0] );
state $prefix = "\e[7m* package_log.pl:\e[0m ";
@@ -213,7 +209,7 @@ sub change_for {
return unless $file;
- if ( $flags->{'nosummarize'} ) {
+ if ( $optparse->long_opts->{'nosummarize'} ) {
return $file;
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-24 7:13 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-24 7:13 UTC (permalink / raw
To: gentoo-commits
commit: 11f68780d3ccfb50396a4f9736957288d466cd04
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Thu Feb 23 20:07:50 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Thu Feb 23 20:07:50 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=11f68780
[scripts] Be less vulnerable to weird quotes in abstract
---
scripts/gen_ebuild.pl | 4 +++-
1 files changed, 3 insertions(+), 1 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 46ea8f1..8d83bc5 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -135,7 +135,9 @@ if ( not defined $release_info->{abstract} ) {
warn "Missing an ABSTRACT";
}
else {
- $fh->say( 'DESCRIPTION=\'' . $release_info->{abstract} . '\'' );
+ my $abstract = $release_info->{abstract};
+ $abstract =~ s/'/'\\''/g; # ' => '\''
+ $fh->say( 'DESCRIPTION=\'' . $abstract . '\'' );
}
my $lics = [];
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-24 7:13 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-24 7:13 UTC (permalink / raw
To: gentoo-commits
commit: d7a5db5072483848020aff97c5ba9eaf0275e3c6
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Thu Feb 23 19:52:55 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Thu Feb 23 19:52:55 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=d7a5db50
[scripts] fix quoting style to give literal \n :(
---
scripts/gen_ebuild.pl | 2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index fe14365..46ea8f1 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -252,5 +252,5 @@ exit 1;
sub gen_func {
my ( $name, @body ) = @_;
- return join( q{\n}, $name . '() {', ( map { "\t" . $_ } @body ), '}' );
+ return join( qq{\n}, $name . '() {', ( map { "\t" . $_ } @body ), '}' );
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-12 7:22 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-12 7:22 UTC (permalink / raw
To: gentoo-commits
commit: b6c34a07e3e80260db3571c14015f3c7e53e137a
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Feb 12 02:05:10 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sun Feb 12 02:05:10 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=b6c34a07
[scripts] gen_ebuild more verbose error handling
---
scripts/gen_ebuild.pl | 33 ++++++++++++++++++++++++++++-----
1 files changed, 28 insertions(+), 5 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 87d91d7..e8635b6 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -10,6 +10,7 @@ use FindBin;
use lib "$FindBin::Bin/lib";
use env::gentoo::perl_experimental;
use utf8;
+use Data::Dump qw( pp );
my $env = env::gentoo::perl_experimental->new();
my $flags;
@@ -145,20 +146,32 @@ else {
$fh->say('IUSE=""');
}
+pp($handler2);
+
if ( $handler2->has_cdeps ) {
$fh->say('perl_meta_configure() {');
for my $dep ( @{ $handler2->cdeps } ) {
$fh->say( "\t# " . $dep->{dep} );
- $fh->say( "\techo " . $dep->{install} );
+ if ( not defined $dep->{install} ) {
+ $fh->say( "\t#echo unresolved");
+ warn "cdep " . $dep->{dep} . " was not resolved to a dependency";
+ } else {
+ $fh->say( "\techo " . $dep->{install} );
+ }
}
$fh->say('}');
push @{$depends}, '$(perl_meta_configure)';
}
if ( $handler2->has_bdeps ) {
$fh->say('perl_meta_build() {');
- for my $dep ( @{ $handler2->bdeps } ) {
+ for my $dep ( @{ $handler2->bdeps } ) {
$fh->say( "\t# " . $dep->{dep} );
- $fh->say( "\techo " . $dep->{install} );
+ if ( not defined $dep->{install} ) {
+ $fh->say( "\t#echo unresolved");
+ warn "bdep " . $dep->{dep} . " was not resolved to a dependency";
+ } else {
+ $fh->say( "\techo " . $dep->{install} );
+ }
}
$fh->say('}');
push @{$depends}, '$(perl_meta_build)';
@@ -168,7 +181,12 @@ if ( $handler2->has_rdeps ) {
$fh->say('perl_meta_runtime() {');
for my $dep ( @{ $handler2->rdeps } ) {
$fh->say( "\t# " . $dep->{dep} );
- $fh->say( "\techo " . $dep->{install} );
+ if ( not defined $dep->{install} ) {
+ $fh->say( "\t#echo unresolved");
+ warn "rdep: " . $dep->{dep} . " was not resolved to a dependency";
+ } else {
+ $fh->say( "\techo " . $dep->{install} );
+ }
}
$fh->say('}');
push @{$depends}, '$(perl_meta_runtime)';
@@ -179,7 +197,12 @@ if ( $handler2->has_tdeps ) {
$fh->say('perl_meta_test() {');
for my $dep ( @{ $handler2->tdeps } ) {
$fh->say( "\t# " . $dep->{dep} );
- $fh->say( "\techo " . $dep->{install} );
+ if ( not defined $dep->{install} ) {
+ $fh->say( "\t#echo unresolved");
+ warn "tdep: " . $dep->{dep} . " was not resolved to a dependency";
+ } else {
+ $fh->say( "\techo " . $dep->{install} );
+ }
}
$fh->say('}');
push @{$depends}, 'test? ( $(perl_meta_test) )';
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2012-02-12 7:22 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2012-02-12 7:22 UTC (permalink / raw
To: gentoo-commits
commit: 61c48fe86e85329762533763c3c2799893c761bd
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Feb 12 01:48:15 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sun Feb 12 01:48:15 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=61c48fe8
[script] remove newest_date limitation on package_log
---
scripts/package_log.pl | 2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index a6bc9fb..22e571d 100755
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -61,7 +61,7 @@ if ( not $flags->{all} ) {
range => {
date => {
from => $oldest_date,
- to => $newest_date,
+ #to => $newest_date,
}
}
};
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-12-05 21:45 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-12-05 21:45 UTC (permalink / raw
To: gentoo-commits
commit: 6cf58e9985c25624314361fbb855cb30b75fa4f0
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Dec 5 21:44:25 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Dec 5 21:44:25 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=6cf58e99
[scripts] add Artistic-2 to license map
---
scripts/gen_ebuild.pl | 3 ++-
1 files changed, 2 insertions(+), 1 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index a230110..87d91d7 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -114,7 +114,8 @@ 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 )]
+ lgpl_2_1 => [qw( LGPL-2.1 )],
+ artistic_2 => [qw( Artistic-2 )],
};
for my $lic ( @{ $release_info->{license} } ) {
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-11-14 2:57 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-11-14 2:57 UTC (permalink / raw
To: gentoo-commits
commit: 8153bc114f3eb710b47939e40a3164d9a72e3ba8
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Nov 14 02:52:46 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Nov 14 02:52:46 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=8153bc11
[scripts] add a git modified dirs util
---
scripts/modified_mod_dirs.sh | 1 +
1 files changed, 1 insertions(+), 0 deletions(-)
diff --git a/scripts/modified_mod_dirs.sh b/scripts/modified_mod_dirs.sh
new file mode 100755
index 0000000..7c43278
--- /dev/null
+++ b/scripts/modified_mod_dirs.sh
@@ -0,0 +1 @@
+ git status --porcelain | sed -r 's/^[MRD? ]+ ([^/]+\/[^/]+)\/.*/\1/' | sort -u | grep -v scripts
^ permalink raw reply related [flat|nested] 63+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-11-14 2:57 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-11-14 2:57 UTC (permalink / raw
To: gentoo-commits
commit: ab4f94737364e5a82928459a5e96c6416448dcb1
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Nov 14 02:52:24 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Nov 14 02:52:24 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=ab4f9473
Add support for --debug to gen_ebuild
---
scripts/gen_ebuild.pl | 100 +++++++++++++++++++++++++------------------------
1 files changed, 51 insertions(+), 49 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index ef9c4c7..a230110 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -47,16 +47,14 @@ EOF
}
my ($release) = shift(@ARGV);
-
-
*STDOUT->binmode(':utf8');
*STDERR->binmode(':utf8');
require deptools;
-my ( $release_info ) = deptools::get_deps( $release );
+my ($release_info) = deptools::get_deps($release);
-if ( not $release_info ){
+if ( not $release_info ) {
die "Cannot find $release on MetaCPAN";
}
my $dep_phases = deptools::get_dep_phases($release);
@@ -71,119 +69,123 @@ for my $module ( keys %{ $dep_phases->{modules} } ) {
my @squeue =
sort { $a->[1]->[2] cmp $b->[1]->[2] or $a->[1]->[3] cmp $b->[1]->[3] or $a->[0] cmp $b->[0] } @queue;
-
require dep::handler::stdout;
require dep::handler::bashcode;
my $handler = dep::handler::stdout->new();
-my $handler2 = dep::handler::bashcode->new();
-
+my $handler2 = dep::handler::bashcode->new( ( $flags->{debug} ? ( debug => 1 ) : () ), debug_handler => $handler, );
for my $qi (@squeue) {
deptools::dispatch_dependency_handler( $release, @{$qi}, $handler2 );
}
-my $depends = [];
+my $depends = [];
my $rdepends = [];
require POSIX;
-my $year = POSIX::strftime('%Y', gmtime);
+my $year = POSIX::strftime( '%Y', gmtime );
-my $path = deptools::gentooize_pkg($release_info->{distribution} );
+my $path = deptools::gentooize_pkg( $release_info->{distribution} );
require Gentoo::PerlMod::Version;
-my $version = Gentoo::PerlMod::Version::gentooize_version( $release_info->{version} , { lax => 1 } );
+my $version = Gentoo::PerlMod::Version::gentooize_version( $release_info->{version}, { lax => 1 } );
$env->root->subdir($path)->mkpath;
-my $file = $env->root->subdir($path)->file($release_info->{distribution} . '-' . $version . '.ebuild' );
+my $file = $env->root->subdir($path)->file( $release_info->{distribution} . '-' . $version . '.ebuild' );
-my ( $fh ) = $file->openw;
+my ($fh) = $file->openw;
say "Writing $file";
$fh->say("# Copyright 1999-$year Gentoo Foundation");
$fh->say("# Distributed under the terms of the GNU General Public License v2");
$fh->say("# \$Header: \$");
$fh->say("EAPI=4");
-$fh->say("MODULE_AUTHOR=" . $release_info->{author});
-$fh->say("MODULE_VERSION=" . $release_info->{version});
+$fh->say( "MODULE_AUTHOR=" . $release_info->{author} );
+$fh->say( "MODULE_VERSION=" . $release_info->{version} );
$fh->say('inherit perl-module');
$fh->say('');
-if ( not defined $release_info->{abstract} ) {
- $fh->say('DESCRIPTION=\'' . $release_info->{distribution} . '\'');
+
+if ( not defined $release_info->{abstract} ) {
+ $fh->say( 'DESCRIPTION=\'' . $release_info->{distribution} . '\'' );
warn "Missing an ABSTRACT";
-} else {
- $fh->say('DESCRIPTION=\'' . $release_info->{abstract} . '\'');
+}
+else {
+ $fh->say( 'DESCRIPTION=\'' . $release_info->{abstract} . '\'' );
}
-my $lics = [];
+my $lics = [];
my $licmap = {
- perl_5 => [qw( Artistic GPL-2 )],
+ perl_5 => [qw( Artistic GPL-2 )],
apache_2_0 => [qw( Apache-2.0 )],
- mit => [qw( MIT )],
- lgpl_2_1 => [qw( LGPL-2.1 )]
+ mit => [qw( MIT )],
+ lgpl_2_1 => [qw( LGPL-2.1 )]
};
-for my $lic ( @{ $release_info->{license} } ){
- if ( exists $licmap->{$lic} ){
- push @$lics, @{ $licmap->{$lic}};
- } else {
+for my $lic ( @{ $release_info->{license} } ) {
+ if ( exists $licmap->{$lic} ) {
+ push @$lics, @{ $licmap->{$lic} };
+ }
+ else {
warn "No Gentoo maping listed for $lic license type";
}
}
-if( scalar @$lics == 1 ){
- $fh->say('LICENSE=" ' . $lics->[0] . '"');
-} elsif ( scalar @$lics > 1 ){
- $fh->say('LICENSE=" || ( ' . (join q{ } , @$lics) . ' )"');
-} else {
+if ( scalar @$lics == 1 ) {
+ $fh->say( 'LICENSE=" ' . $lics->[0] . '"' );
+}
+elsif ( scalar @$lics > 1 ) {
+ $fh->say( 'LICENSE=" || ( ' . ( join q{ }, @$lics ) . ' )"' );
+}
+else {
$fh->say('LICENSE=""');
}
$fh->say('SLOT="0"');
$fh->say('KEYWORDS="~amd64 ~x86"');
-if( $handler2->has_tdeps ) {
+if ( $handler2->has_tdeps ) {
$fh->say('IUSE="test"');
-} else {
+}
+else {
$fh->say('IUSE=""');
}
if ( $handler2->has_cdeps ) {
$fh->say('perl_meta_configure() {');
for my $dep ( @{ $handler2->cdeps } ) {
- $fh->say("\t# " . $dep->{dep});
- $fh->say("\techo " . $dep->{install});
+ $fh->say( "\t# " . $dep->{dep} );
+ $fh->say( "\techo " . $dep->{install} );
}
$fh->say('}');
- push @{ $depends }, '$(perl_meta_configure)';
+ push @{$depends}, '$(perl_meta_configure)';
}
if ( $handler2->has_bdeps ) {
$fh->say('perl_meta_build() {');
for my $dep ( @{ $handler2->bdeps } ) {
- $fh->say("\t# " . $dep->{dep});
- $fh->say("\techo " . $dep->{install});
+ $fh->say( "\t# " . $dep->{dep} );
+ $fh->say( "\techo " . $dep->{install} );
}
$fh->say('}');
- push @{ $depends }, '$(perl_meta_build)';
+ push @{$depends}, '$(perl_meta_build)';
}
if ( $handler2->has_rdeps ) {
$fh->say('perl_meta_runtime() {');
for my $dep ( @{ $handler2->rdeps } ) {
- $fh->say("\t# " . $dep->{dep});
- $fh->say("\techo " . $dep->{install});
+ $fh->say( "\t# " . $dep->{dep} );
+ $fh->say( "\techo " . $dep->{install} );
}
$fh->say('}');
- push @{ $depends }, '$(perl_meta_runtime)';
- push @{ $rdepends }, '$(perl_meta_runtime)';
+ push @{$depends}, '$(perl_meta_runtime)';
+ push @{$rdepends}, '$(perl_meta_runtime)';
}
if ( $handler2->has_tdeps ) {
$fh->say('perl_meta_test() {');
for my $dep ( @{ $handler2->tdeps } ) {
- $fh->say("\t# " . $dep->{dep});
- $fh->say("\techo " . $dep->{install});
+ $fh->say( "\t# " . $dep->{dep} );
+ $fh->say( "\techo " . $dep->{install} );
}
$fh->say('}');
- push @{ $depends }, 'test? ( $(perl_meta_test) )';
+ push @{$depends}, 'test? ( $(perl_meta_test) )';
}
-$fh->say("DEPEND=\"\n" . ( join qq{\n}, map { "\t$_" } @{$depends} ) . "\n\"");
-$fh->say("RDEPEND=\"\n" . ( join qq{\n}, map { "\t$_" } @{$rdepends} ) . "\n\"");
+$fh->say( "DEPEND=\"\n" . ( join qq{\n}, map { "\t$_" } @{$depends} ) . "\n\"" );
+$fh->say( "RDEPEND=\"\n" . ( join qq{\n}, map { "\t$_" } @{$rdepends} ) . "\n\"" );
$fh->say("SRC_TEST=\"do\"");
#say pp( \%modules,);# { pretty => 1 } );
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-11-11 14:38 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-11-11 14:38 UTC (permalink / raw
To: gentoo-commits
commit: b9d63a5efdae891f3ab20d19e908f6f816d78a81
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Fri Nov 11 14:37:23 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Fri Nov 11 14:37:23 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=b9d63a5e
[scripts] added fixvdep for easy version subs
---
scripts/fixvdep.pl | 38 ++++++++++++++++++++++++++++++++++++++
1 files changed, 38 insertions(+), 0 deletions(-)
diff --git a/scripts/fixvdep.pl b/scripts/fixvdep.pl
new file mode 100644
index 0000000..3a77406
--- /dev/null
+++ b/scripts/fixvdep.pl
@@ -0,0 +1,38 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+# FILENAME: fixvdep.pl
+# CREATED: 12/11/11 00:52:15 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Fix up version deps on a specific package in (a) given ebuild(s)
+
+
+my ( $pkg, $oldversion , $newversion , @files ) = @ARGV;
+@ARGV = ();
+
+
+my @subs = (
+
+ ( sprintf 's/%s-%s\s*$/%s-%s/' , $pkg, $oldversion,$pkg,$newversion ),
+ ( sprintf 's/%s-%s\s*"/%s-%s"/' , $pkg, $oldversion,$pkg,$newversion ),
+
+ ( sprintf 's/%s\s*%s\s*$/%s %s/', $pkg, $oldversion, $pkg, $newversion ),
+ ( sprintf 's/%s\s*%s\s*#\s*%s\s*$/%s %s/',
+ $pkg, $oldversion, $newversion, $pkg, $newversion ),
+ ( sprintf 's/%s-%s\s*\$\(comment\s*%s\)\s*$/%s-%s/', $pkg, $oldversion, $newversion, $pkg, $newversion ),
+
+
+
+
+
+);
+
+for my $sub ( @subs ) {
+ print "$sub\n";
+ system('sed','-i', '-r', '-e', $sub , @files );
+}
+
+
+
+
+
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 18:05 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 18:05 UTC (permalink / raw
To: gentoo-commits
commit: 327a4ed4a91cc5803d80fa1134cdcaac8b22dd3b
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 31 18:04:47 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 31 18:04:47 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=327a4ed4
[scripts/dual-life.pl] Tidy code
---
scripts/dual-life.pl | 57 +++++++++++++++++++++++--------------------------
1 files changed, 27 insertions(+), 30 deletions(-)
diff --git a/scripts/dual-life.pl b/scripts/dual-life.pl
index 458e1f9..9d7fe80 100644
--- a/scripts/dual-life.pl
+++ b/scripts/dual-life.pl
@@ -23,9 +23,7 @@ my $perls = {
stable => CoreGroup->new( name => 'stable', perls => [qw( 5.12.3 5.12.4 )] ),
};
-
-pp $perls->{masked_future}->get_perl(qw( 5.14.2 ))->delta(
- $perls->{stable}->get_perl(qw( 5.12.4 )) );
+pp $perls->{masked_future}->get_perl(qw( 5.14.2 ))->delta( $perls->{stable}->get_perl(qw( 5.12.4 )) );
#for my $group ( $perls->{masked_future} ) {
# for my $perl ( values $group->perls ) {
@@ -83,49 +81,47 @@ BEGIN {
__PACKAGE__->meta->make_immutable;
-
sub delta {
- my ( $self, $other ) = @_ ;
- my ( %all ) = map { $_ , 1 }
+ my ( $self, $other ) = @_;
+ my (%all) = map { $_, 1 }
$self->module_names,
$other->module_names;
my %diffs;
for my $module ( keys %all ) {
- if( $self->has_module( $module ) and not $other->has_module( $module ) ) {
+ if ( $self->has_module($module) and not $other->has_module($module) ) {
$diffs{$module} = {
- kind => 'ours',
- available_in => $self->perl_version,
- not_available_in => $other->perl_version,
- module => $module,
- available_version => $self->module( $module )->version,
+ kind => 'ours',
+ available_in => $self->perl_version,
+ not_available_in => $other->perl_version,
+ module => $module,
+ available_version => $self->module($module)->version,
};
next;
}
- if( not $self->has_module( $module ) and $other->has_module( $module ) ) {
+ if ( not $self->has_module($module) and $other->has_module($module) ) {
$diffs{$module} = {
- kind => 'theirs',
- available_in => $other->perl_version,
- not_available_in => $self->perl_version,
- module => $module,
- available_version => $other->module( $module )->version,
+ kind => 'theirs',
+ available_in => $other->perl_version,
+ not_available_in => $self->perl_version,
+ module => $module,
+ available_version => $other->module($module)->version,
};
next;
}
- if ( ( $self->module( $module )->version // 'undef' ) ne ( $other->module($module)->version // 'undef' ) ) {
- $diffs{$module} = {
- kind => 'cross',
- module => $module,
- our_version => $self->module( $module )->version,
- their_version => $other->module( $module )->version,
- our_perl => $self->perl_version,
- their_perl => $other->perl_version,
+ if ( ( $self->module($module)->version // 'undef' ) ne ( $other->module($module)->version // 'undef' ) ) {
+ $diffs{$module} = {
+ kind => 'cross',
+ module => $module,
+ our_version => $self->module($module)->version,
+ their_version => $other->module($module)->version,
+ our_perl => $self->perl_version,
+ their_perl => $other->perl_version,
};
}
}
return \%diffs;
}
-
# BUILDERS
sub _build_perl_version {
@@ -184,16 +180,17 @@ BEGIN {
__PACKAGE__->meta->make_immutable;
sub get_perl {
- my ($self,$perlv) = @_;
- if ( not exists $self->perls->{$perlv} ) {
+ my ( $self, $perlv ) = @_;
+ if ( not exists $self->perls->{$perlv} ) {
die "No key $perlv";
}
return $self->perls->{$perlv};
}
+
# BUILDERS
sub _build_perls {
my $self = shift;
- return { map { $_ , CoreList::Single->new( coregroup => $self->name, perl => $_ ) } @{ $self->_perls } };
+ return { map { $_, CoreList::Single->new( coregroup => $self->name, perl => $_ ) } @{ $self->_perls } };
}
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 18:05 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 18:05 UTC (permalink / raw
To: gentoo-commits
commit: 66ce54b9fb3a062ff9ff1b164de659f47aa9cb25
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 31 18:03:56 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 31 18:03:56 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=66ce54b9
[scripts/dual-life.pl] early stage of dual-life script, shows delta between arbitrary corelist perls
---
scripts/dual-life.pl | 199 ++++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 199 insertions(+), 0 deletions(-)
diff --git a/scripts/dual-life.pl b/scripts/dual-life.pl
new file mode 100644
index 0000000..458e1f9
--- /dev/null
+++ b/scripts/dual-life.pl
@@ -0,0 +1,199 @@
+#!/usr/bin/env perl
+
+use 5.14.2;
+use strict;
+use warnings;
+
+# FILENAME: dual-life.pl
+# CREATED: 01/11/11 05:49:45 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: find/report dual-life modules.
+use Module::CoreList;
+use Data::Dump qw( pp );
+use FindBin;
+use version;
+
+use lib "$FindBin::Bin/lib";
+
+my $pv = shift(@ARGV);
+
+my $perls = {
+ masked_future => CoreGroup->new( name => 'masked_future', perls => [qw( 5.14.0 5.14.1 5.14.2 )] ),
+ masked_past => CoreGroup->new( name => 'masked_past', perls => [qw( 5.8.8 5.10.1 )] ),
+ testing => CoreGroup->new( name => 'testing', perls => [qw()] ),
+ stable => CoreGroup->new( name => 'stable', perls => [qw( 5.12.3 5.12.4 )] ),
+};
+
+
+pp $perls->{masked_future}->get_perl(qw( 5.14.2 ))->delta(
+ $perls->{stable}->get_perl(qw( 5.12.4 )) );
+
+#for my $group ( $perls->{masked_future} ) {
+# for my $perl ( values $group->perls ) {
+# for my $module ( values $perl->modules ) {
+# say $module->to_s;
+# }
+# }
+#}
+
+#pp $perls;
+
+exit 0;
+
+BEGIN {
+
+ package CoreList::Module;
+ use Moose;
+ has name => ( isa => 'Str', is => 'rw', required => 1 );
+ has version => ( isa => 'Maybe[Str]', is => 'rw', required => 1 );
+ has perl => ( isa => 'Str', is => 'rw', required => 1 );
+ has coregroup => ( isa => 'Str', is => 'rw', required => 1 );
+ __PACKAGE__->meta->make_immutable;
+
+ sub to_s {
+ my $self = shift;
+ return sprintf '%s %s %s %s', $self->coregroup, $self->perl, $self->name, $self->version // 'undef';
+ }
+
+}
+
+BEGIN {
+
+ package CoreList::Single;
+ use Moose;
+
+ has 'perl' => ( isa => 'Str', is => 'rw', required => 1 );
+
+ has 'modules' => (
+ isa => 'HashRef[CoreList::Module]',
+ is => 'rw',
+ lazy_build => 1,
+ traits => [qw( Hash )],
+ handles => {
+ 'module_names' => 'keys',
+ 'has_module' => 'exists',
+ 'module' => 'get',
+ },
+ );
+
+ has 'released' => ( isa => 'Str', is => 'rw', lazy_build => 1 );
+
+ has 'perl_version' => ( isa => 'Str', is => 'rw', lazy_build => 1 );
+
+ has 'coregroup' => ( isa => 'Str', is => 'rw', required => 1 );
+
+ __PACKAGE__->meta->make_immutable;
+
+
+ sub delta {
+ my ( $self, $other ) = @_ ;
+ my ( %all ) = map { $_ , 1 }
+ $self->module_names,
+ $other->module_names;
+ my %diffs;
+ for my $module ( keys %all ) {
+ if( $self->has_module( $module ) and not $other->has_module( $module ) ) {
+ $diffs{$module} = {
+ kind => 'ours',
+ available_in => $self->perl_version,
+ not_available_in => $other->perl_version,
+ module => $module,
+ available_version => $self->module( $module )->version,
+ };
+ next;
+ }
+ if( not $self->has_module( $module ) and $other->has_module( $module ) ) {
+ $diffs{$module} = {
+ kind => 'theirs',
+ available_in => $other->perl_version,
+ not_available_in => $self->perl_version,
+ module => $module,
+ available_version => $other->module( $module )->version,
+ };
+ next;
+ }
+ if ( ( $self->module( $module )->version // 'undef' ) ne ( $other->module($module)->version // 'undef' ) ) {
+ $diffs{$module} = {
+ kind => 'cross',
+ module => $module,
+ our_version => $self->module( $module )->version,
+ their_version => $other->module( $module )->version,
+ our_perl => $self->perl_version,
+ their_perl => $other->perl_version,
+ };
+ }
+
+ }
+ return \%diffs;
+ }
+
+
+ # BUILDERS
+ sub _build_perl_version {
+ require version;
+ my $self = shift;
+ return version->parse( $self->perl )->numify;
+ }
+
+ sub _version_string {
+ my $self = shift;
+ return $self->perl . ' ( ' . $self->perl_version . ' )';
+ }
+
+ sub _build_released {
+ require Module::CoreList;
+ my $self = shift;
+ if ( not exists $Module::CoreList::released{ $self->perl_version } ) {
+ die "Version " . $self->_version_string . " is not in the \$released stash";
+ }
+ return $Module::CoreList::released{ $self->perl_version };
+ }
+
+ sub _build_modules {
+ require Module::CoreList;
+ my $self = shift;
+ if ( not exists $Module::CoreList::version{ $self->perl_version } ) {
+ die "Version " . $self->_version_string . " is not in the \$version stash";
+ }
+
+ my $stash = $Module::CoreList::version{ $self->perl_version };
+
+ return {
+ map {
+ $_,
+ CoreList::Module->new(
+ perl => $self->perl_version,
+ coregroup => $self->coregroup,
+ name => $_,
+ version => $stash->{$_}
+ )
+ } keys $stash
+ };
+ }
+}
+
+BEGIN {
+
+ package CoreGroup;
+ use Moose;
+
+ has _perls => ( isa => 'ArrayRef[Str]', is => 'rw', required => 1, init_arg => 'perls' );
+
+ has perls => ( isa => 'HashRef[CoreList::Single]', is => 'rw', lazy_build => 1, init_arg => undef );
+ has name => ( isa => 'Str', is => 'rw', required => 1 );
+
+ __PACKAGE__->meta->make_immutable;
+
+ sub get_perl {
+ my ($self,$perlv) = @_;
+ if ( not exists $self->perls->{$perlv} ) {
+ die "No key $perlv";
+ }
+ return $self->perls->{$perlv};
+ }
+ # BUILDERS
+ sub _build_perls {
+ my $self = shift;
+ return { map { $_ , CoreList::Single->new( coregroup => $self->name, perl => $_ ) } @{ $self->_perls } };
+ }
+
+}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 8:46 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 8:46 UTC (permalink / raw
To: gentoo-commits
commit: 66f31bb876d1d67b0f0340b33f773388fb3cbb34
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 31 07:21:26 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 31 07:21:26 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=66f31bb8
Add a mapping for MIT license
---
scripts/gen_ebuild.pl | 1 +
1 files changed, 1 insertions(+), 0 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 220ec13..d9c3648 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -111,6 +111,7 @@ my $lics = [];
my $licmap = {
perl_5 => [qw( Artistic GPL-2 )],
apache_2_0 => [qw( Apache-2.0 )],
+ mit => [qw( MIT )],
};
for my $lic ( @{ $release_info->{license} } ){
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 7:10 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 7:10 UTC (permalink / raw
To: gentoo-commits
commit: b18b6d3f88cca14d9fc3a2c23e720517dde9420f
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 31 07:07:35 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 31 07:07:35 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=b18b6d3f
[scripts/gen_ebuild.pl] die with an error if the requested package can't be resolved
---
scripts/gen_ebuild.pl | 4 ++++
1 files changed, 4 insertions(+), 0 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index c70dba4..220ec13 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -55,6 +55,10 @@ my ($release) = shift(@ARGV);
require deptools;
my ( $release_info ) = deptools::get_deps( $release );
+
+if ( not $release_info ){
+ die "Cannot find $release on MetaCPAN";
+}
my $dep_phases = deptools::get_dep_phases($release);
my @queue;
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 4:52 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 4:52 UTC (permalink / raw
To: gentoo-commits
commit: a4f377d82908626b8ddd16997b1f1abf7fbf438a
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 31 04:49:15 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 31 04:49:15 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=a4f377d8
add apache2 license to generator
---
scripts/gen_ebuild.pl | 1 +
1 files changed, 1 insertions(+), 0 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index d068a0b..c70dba4 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -106,6 +106,7 @@ $fh->say('DESCRIPTION=\'' . $release_info->{abstract} . '\'');
my $lics = [];
my $licmap = {
perl_5 => [qw( Artistic GPL-2 )],
+ apache_2_0 => [qw( Apache-2.0 )],
};
for my $lic ( @{ $release_info->{license} } ){
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: 96d11ac266c595c159fb4b39da0f8d59312b864a
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 31 02:43:45 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 31 02:45:48 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=96d11ac2
generator script now producing full stubs
---
scripts/gen_ebuild.pl | 6 +++---
1 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 4f09d25..d068a0b 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -101,7 +101,7 @@ $fh->say("MODULE_VERSION=" . $release_info->{version});
$fh->say('inherit perl-module');
$fh->say('');
-$fh->say('DESCRIPTION="' . quotemeta( $release_info->{abstract} ) . '"');
+$fh->say('DESCRIPTION=\'' . $release_info->{abstract} . '\'');
my $lics = [];
my $licmap = {
@@ -171,8 +171,8 @@ if ( $handler2->has_tdeps ) {
push @{ $depends }, 'test? ( $(perl_meta_test) )';
}
-$fh->say("DEPENDS=\"\n" . ( join qq{\n}, map { "\t$_" } @{$depends} ) . "\n\"");
-$fh->say("RDEPENDS=\"\n" . ( join qq{\n}, map { "\t$_" } @{$rdepends} ) . "\n\"");
+$fh->say("DEPEND=\"\n" . ( join qq{\n}, map { "\t$_" } @{$depends} ) . "\n\"");
+$fh->say("RDEPEND=\"\n" . ( join qq{\n}, map { "\t$_" } @{$rdepends} ) . "\n\"");
$fh->say("SRC_TEST=\"do\"");
#say pp( \%modules,);# { pretty => 1 } );
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: b768a4ce805c6439d64dd05d4c4fe1fc422b6b2e
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Oct 30 20:19:03 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=b768a4ce
Reasonably assumptive-but-works chooser of exported dep
---
scripts/show_deptree.pl | 348 ++++++++++++++++++++++++++++++++++-------------
1 files changed, 250 insertions(+), 98 deletions(-)
diff --git a/scripts/show_deptree.pl b/scripts/show_deptree.pl
index 14f221b..8b78896 100755
--- a/scripts/show_deptree.pl
+++ b/scripts/show_deptree.pl
@@ -36,7 +36,7 @@ if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
# usage:
#
# gen_ebuild.pl DOY/Moose-2.0301-TRIAL
-#
+#
my ($release) = shift(@ARGV);
*STDOUT->binmode(':utf8');
@@ -46,8 +46,8 @@ my %phases;
my %modules;
my %providers;
-my $dep_phases = get_dep_phases( $release );
-%phases = %{ $dep_phases->{phases} };
+my $dep_phases = get_dep_phases($release);
+%phases = %{ $dep_phases->{phases} };
%modules = %{ $dep_phases->{modules} };
use Data::Dump qw( pp );
@@ -56,28 +56,29 @@ use Try::Tiny;
use version ();
sub provider_map {
- my ( $module , $version ) = @_;
- my @providers = metacpan->find_dist_simple( $module );
+ my ( $module, $version ) = @_;
+ my @providers = metacpan->find_dist_simple($module);
my %moduleprov;
-
- my %specialvs;
+ my %specialvs;
- my $wanted_version = version->parse( $version );
+ my $wanted_version = version->parse($version);
- for my $provider ( @providers ) {
+ for my $provider (@providers) {
- next if $provider->{status} eq 'backpan';
+ #next if $provider->{status} eq 'backpan';
next if $provider->{maturity} eq 'developer';
-# pp $provider;
- my $dist = $provider->{distribution};
+ # pp $provider;
+
+ my $dist = $provider->{distribution};
my $distv = $provider->{version} // 'undef';
my $gv = 'undef';
- if ( $distv ne 'undef' ){
+ if ( $distv ne 'undef' ) {
try {
- $gv = gentooize_version( $distv , { lax => 1 } );
- } catch {
+ $gv = gentooize_version( $distv, { lax => 1 } );
+ }
+ catch {
$gv = '???';
};
}
@@ -87,46 +88,41 @@ sub provider_map {
$moduleprov{$dist} //= [];
my @provided_matching_mods;
- for my $mod ( @{ $provider->{'_source.module' } } ) {
+ for my $mod ( @{ $provider->{'_source.module'} } ) {
next unless $mod->{name} eq $module;
my $modv = $mod->{version} // 'undef';
my $got_version = version->parse( $mod->{version} );
- my $dv = $distv;
- #if( $distv ne $modv ) {
- $dv = sprintf "%s ( %s ) => \"%s\"" , $distv , $gv, $modv;
- #}
- # specials
-
- $specialvs{newest} //= {};
- $specialvs{oldest} //= {};
- $specialvs{closest} //= {};
+ my $dv = $distv;
+ $dv = sprintf "%s ( %s ) => \"%s\"", $distv, $gv, $modv;
+
+ # specials
+
+ $specialvs{newest} //= {};
+ $specialvs{oldest} //= {};
+ $specialvs{closest} //= {};
$specialvs{closestx} //= {};
- $specialvs{latest} = [ $dist , $dv ] if not exists $specialvs{latest};
+ $specialvs{latest} = [ $dist, $dv ] if not exists $specialvs{latest};
$specialvs{newest}->{$dist} = $dv if not exists $specialvs{newest}->{$dist};
- $specialvs{oldest}->{$dist} = $dv;
+ $specialvs{oldest}->{$dist} = $dv;
- # *STDERR->printf("\e[99m%s > %s , %s\n", $got_version, $wanted_version, $got_version > $wanted_version );
+ if ( not defined $version or $got_version >= $wanted_version ) {
- if ( not defined $version or $got_version >= $wanted_version ){
-# *STDERR->printf("\e[99m%s > %s , %s x2\n", $got_version, $version , 1 );
if ( not defined $specialvs{closestx}->{$dist} ) {
-# *STDERR->printf("\e[99m%s > %s => set \n", $got_version, $version );
$specialvs{closestx}->{$dist} = $got_version;
- $specialvs{closest}->{$dist} = $dv;
- } else {
- if( $specialvs{closestx}->{$dist} >= $got_version ) {
-# *STDERR->printf("\e[99m%s > %s => << \n", $got_version, $version );
-
+ $specialvs{closest}->{$dist} = $dv;
+ }
+ else {
+ if ( $specialvs{closestx}->{$dist} >= $got_version ) {
$specialvs{closestx}->{$dist} = $got_version;
- $specialvs{closest}->{$dist} = $dv;
-
+ $specialvs{closest}->{$dist} = $dv;
}
}
}
- #
-
+
+ #
+
push @provided_matching_mods, $dv
if $mod->{name} eq $module;
}
@@ -135,108 +131,264 @@ sub provider_map {
return \%moduleprov, \%specialvs;
}
+sub handle_declaration {
+ my ( $release, $module, $declaration, $output ) = @_;
-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 $depstring = $module;
- if ( $declaration->[1] ne '0.0.0' ) {
- $depstring .= " " . $declaration->[0] . " ( " . $declaration->[1] . " ) " ;
- }
+ my $want_string = "$release -> " . $declaration->[2] . " " . $declaration->[3] . " " . $depstring;
- my $want_string = "$release -> " . $declaration->[2] . " " . $declaration->[3] . " " . $depstring;
+ my ( $moduleprov, $specialvs ) = provider_map( $module, $declaration->[0] );
-
- my ( $moduleprov, $specialvs ) = provider_map( $module , $declaration->[0]);
+ my $to_pkg = sub {
+ my $pkg = shift;
+ my $xpkg = gentooize_pkg($pkg);
+ if ( $declaration->[1] eq '0.0.0' ) {
+ return $xpkg;
+ }
+ return '\\>=' . $xpkg . '-' . $declaration->[1];
+ };
- my $pc = scalar keys %$moduleprov;
+ my $pc = scalar keys %$moduleprov;
- my $multi = ( $pc > 1 );
- my $any = ( $pc > 0 );
+ my $multi = ( $pc > 1 );
+ my $any = ( $pc > 0 );
- *STDOUT->printf("\e[1;93m%s\e[0m\n", $want_string );
+ $output->printf( "\e[1;93m%s\e[0m\n", $want_string );
-
+ if ( not $any ) {
+ return $output->printf( "%sWARNING: NO PROVIDER FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
+ }
+ if ($multi) {
+ $output->printf( "%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
+ }
- if ( not $any ) {
- *STDOUT->printf("%sWARNING: NO PROVIDER FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
- next;
- }
- if( $multi ){
- *STDOUT->printf("%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
+ my $indent = " \e[1;92m*";
+ $indent = " \e[1;91m*" if $multi;
+
+ $output->printf(
+ "%s\e[1;95m latest: %s => %s ( %s )\n",
+ $indent,
+ @{ $specialvs->{latest} },
+ $to_pkg->( $specialvs->{latest}->[0] )
+ );
+
+ 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;
+ $output->printf( " %s%s -> %s%s (%s)\n", "\e[1;92m", $depstring, "\e[0m\e[92m", $prov, gentooize_pkg($prov) );
+ $output->printf( "%s newest: %s\e[0m\n", $indent, $specialvs->{newest}->{$prov} );
+ $output->printf( "%s oldest: %s\e[0m\n", $indent, $specialvs->{oldest}->{$prov} );
+ my $v = $specialvs->{closest}->{$prov};
+ if ( not defined $v ) { $v = 'undef' }
+ $output->printf( "%s closest: %s\e[0m\n", $indent, $v );
+
+ for (@slines) {
+
+ $output->printf( "%s %s%s -> %s%s\n", $indent, "\e[1;94m", $prov, "\e[0m\e[94m", $_ );
}
+ }
+ if ($multi) {
+ $output->print(" \e[1;91m-\n\n");
+ }
+ else {
+ $output->print(" \e[1;92m-\n\n");
+ }
+}
- my $indent = " \e[1;92m*";
- $indent = " \e[1;91m*" if $multi;
-
- *STDOUT->printf("%s latest: %s => %s\n", $indent, @{ $specialvs->{latest} } );
-
- 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;
- *STDOUT->printf(" %s%s -> %s%s\n", "\e[1;92m", $depstring, "\e[0m\e[92m" ,$prov);
- *STDOUT->printf("%s newest: %s\e[0m\n", $indent, $specialvs->{newest}->{$prov});
- *STDOUT->printf("%s oldest: %s\e[0m\n", $indent, $specialvs->{oldest}->{$prov});
- my $v = $specialvs->{closest}->{$prov};
- if( not defined $v ){ $v = 'undef' }
- *STDOUT->printf("%s closest: %s\e[0m\n", $indent, $v );
- for ( @slines ) {
+sub virtual($) {
+ my $i = shift;
+ return 'virtual/perl-' . $i;
+}
- *STDOUT->printf("%s %s%s -> %s%s\n", $indent, "\e[1;94m", $prov , "\e[0m\e[94m", $_ );
- }
- }
- if ( $multi ){
- *STDOUT->print(" \e[1;91m-\n\n");
- } else {
- *STDOUT->print(" \e[1;92m-\n\n");
- }
+sub gentooize_pkg {
+ my $pkg = shift;
+ my %vmap = (
+ 'perl' => 'dev-lang/perl',
+ 'perl_debug' => 'dev-lang/perl_debug', # doesn't actually exist
+ (
+ map { $_, virtual $_ }
+ qw(
+ Archive-Tar
+ Attribute-Handlers
+ AutoLoader
+ CGI
+ Class-ISA
+ Compress-Raw-Bzip2
+ Compress-Raw-Zlib
+ CPAN-Meta
+ CPAN-Meta-YAML
+ Data-Dumper
+ DB_File
+ Digest-MD5
+ Digest-SHA
+ Encode
+ ExtUtils-CBuilder
+ ExtUtils-Command
+ ExtUtils-Install
+ ExtUtils-MakeMaker
+ ExtUtils-Manifest
+ ExtUtils-ParseXS
+ File-Path
+ File-Temp
+ Filter
+ Getopt-Long
+ i18n-langtags
+ IO
+ IO-Compress
+ IO-Zlib
+ IPC-Cmd
+ JSON-PP
+ libnet
+ Locale-MakeText-Simple
+ Math-BigInt
+ Math-BigInt-FastCalc
+ Memoize
+ MIME-Base64
+ Module-Build
+ Module-CoreList
+ Module-Load
+ Module-Load-Conditional
+ Module-Loaded
+ Module-Metadata
+ Module-Pluggable
+ Package-Constants
+ Params-Check
+ parent
+ Parse-CPAN-Meta
+ Perl-OSType
+ Pod-Escapes
+ podlators
+ Pod-Simple
+ Safe
+ Scalar-List-Utils
+ Storable
+ Switch
+ Sys-Syslog
+ Term-ANSIColor
+ Test
+ Test-Harness
+ Test-Simple
+ Text-Balanced
+ Text-Tabs+Wrap
+ Thread-Queue
+ threads
+ Thread-Semaphore
+ threads-shared
+ Time-HiRes
+ Time-Local
+ Time-Piece
+ version
+ Version-Requirements
+ XSLoader
+ )
+ ),
+ 'Digest' => virtual 'digest-base',
+ 'PathTools' => virtual 'File-Spec',
+ 'Locale-MakeText' => virtual 'locale-maketext',
+ 'Net-Ping' => virtual 'net-ping',
+ 'Pod-Parser' => virtual 'PodParser',
+ ## Overlay
+ (
+ map { $_, virtual $_ }
+ qw(
+ 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
+ )
+ ),
+ );
+
+ if ( exists $vmap{$pkg} ) {
+ return $vmap{$pkg};
+ }
+ return 'dev-perl/' . $pkg;
+}
-}}
+for my $module ( keys %modules ) {
+ for my $declaration ( @{ $modules{$module} } ) {
+ handle_declaration( $release, $module, $declaration, *STDOUT );
+ }
+}
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::break = qr/,/;
local $Text::Wrap::overflow = 'huge';
- local $Text::Wrap::columns = 128;
+ local $Text::Wrap::columns = 128;
$Text::Wrap::overflow = 'huge';
my $pre = " ";
- my $lines = wrap( $pre , $pre, @_ );
+ my $lines = wrap( $pre, $pre, @_ );
return $lines;
}
+
sub clines {
- my ( $c, $prefix , $lines ) = @_ ;
+ my ( $c, $prefix, $lines ) = @_;
$lines =~ s/^/$prefix>>$c/mg;
$lines =~ s/$/\e[0m/mg;
return $lines;
}
sub get_dep_phases {
- my ( $release ) = shift;
+ 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 $phase = $dep->{phase};
+ my $module = $dep->{module};
my $required = ( $dep->{relationship} eq 'requires' );
next unless $required;
- next if $phase eq 'develop';
+ next if $phase eq 'develop';
- $phases{$phase} //= [];
+ $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} ];
+ 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 };
}
@@ -258,7 +410,7 @@ sub get_deps {
$release =~ qr{^([^/]+)/(.*$)};
( $author, $distrelease ) = ( "$1", "$2" );
- return metacpan->find_release( $author, $distrelease );
+ return metacpan->find_release( $author, $distrelease );
}
sub pkg_for_module {
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: 51e1a94445b07c58d4fb2f5167a37a5991844b55
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Oct 30 05:10:12 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=51e1a944
rename gen_build and make it just a deptree displayer
---
scripts/{gen_ebuild.pl => show_deptree.pl} | 48 +++++++++++-----------------
1 files changed, 19 insertions(+), 29 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/show_deptree.pl
similarity index 81%
rename from scripts/gen_ebuild.pl
rename to scripts/show_deptree.pl
index 9828a12..14f221b 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/show_deptree.pl
@@ -29,14 +29,14 @@ my $singleflags;
if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
-# FILENAME: gen_ebuild.pl
+# FILENAME: show_deptree.pl
# CREATED: 25/10/11 12:15:51 by Kent Fredric (kentnl) <kentfredric@gmail.com>
-# ABSTRACT: An attempt at generating ebuilds entirely from MetaCPAN data
+# ABSTRACT: show the metadata harvested for a given packages install tree.
# usage:
#
# gen_ebuild.pl DOY/Moose-2.0301-TRIAL
-# emits Moose/Moose-2.30.100_rc.ebuild
+#
my ($release) = shift(@ARGV);
*STDOUT->binmode(':utf8');
@@ -103,7 +103,7 @@ sub provider_map {
$specialvs{oldest} //= {};
$specialvs{closest} //= {};
$specialvs{closestx} //= {};
-
+ $specialvs{latest} = [ $dist , $dv ] if not exists $specialvs{latest};
$specialvs{newest}->{$dist} = $dv if not exists $specialvs{newest}->{$dist};
$specialvs{oldest}->{$dist} = $dv;
@@ -134,6 +134,8 @@ sub provider_map {
}
return \%moduleprov, \%specialvs;
}
+
+
for my $module ( keys %modules ) {
for my $declaration ( @{ $modules{$module} } ) {
@@ -152,58 +154,46 @@ for my $module ( keys %modules ) {
my $multi = ( $pc > 1 );
my $any = ( $pc > 0 );
- *STDERR->printf("\e[1;93m%s\e[0m\n", $want_string );
+ *STDOUT->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" );
+ *STDOUT->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" );
+ *STDOUT->printf("%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
}
+
my $indent = " \e[1;92m*";
$indent = " \e[1;91m*" if $multi;
+ *STDOUT->printf("%s latest: %s => %s\n", $indent, @{ $specialvs->{latest} } );
+
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);
- *STDERR->printf("%s newest: %s\e[0m\n", $indent, $specialvs->{newest}->{$prov});
- *STDERR->printf("%s oldest: %s\e[0m\n", $indent, $specialvs->{oldest}->{$prov});
+ *STDOUT->printf(" %s%s -> %s%s\n", "\e[1;92m", $depstring, "\e[0m\e[92m" ,$prov);
+ *STDOUT->printf("%s newest: %s\e[0m\n", $indent, $specialvs->{newest}->{$prov});
+ *STDOUT->printf("%s oldest: %s\e[0m\n", $indent, $specialvs->{oldest}->{$prov});
my $v = $specialvs->{closest}->{$prov};
if( not defined $v ){ $v = 'undef' }
- *STDERR->printf("%s closest: %s\e[0m\n", $indent, $v );
+ *STDOUT->printf("%s closest: %s\e[0m\n", $indent, $v );
for ( @slines ) {
- *STDERR->printf("%s %s%s -> %s%s\n", $indent, "\e[1;94m", $prov , "\e[0m\e[94m", $_ );
+ *STDOUT->printf("%s %s%s -> %s%s\n", $indent, "\e[1;94m", $prov , "\e[0m\e[94m", $_ );
}
}
if ( $multi ){
- *STDERR->print(" \e[1;91m-\n\n");
+ *STDOUT->print(" \e[1;91m-\n\n");
} else {
- *STDERR->print(" \e[1;92m-\n\n");
+ *STDOUT->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 );
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: 95d1d237d95adbaeeddb824a8bee852cd8614bbf
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Oct 30 20:29:51 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=95d1d237
Sort and print by phase order
---
scripts/show_deptree.pl | 10 +++++++++-
1 files changed, 9 insertions(+), 1 deletions(-)
diff --git a/scripts/show_deptree.pl b/scripts/show_deptree.pl
index 8b78896..e49728d 100755
--- a/scripts/show_deptree.pl
+++ b/scripts/show_deptree.pl
@@ -340,11 +340,19 @@ sub gentooize_pkg {
return 'dev-perl/' . $pkg;
}
+my @queue;
+
for my $module ( keys %modules ) {
for my $declaration ( @{ $modules{$module} } ) {
- handle_declaration( $release, $module, $declaration, *STDOUT );
+ push @queue, [ $module, $declaration ];
}
}
+my @squeue =
+ sort { $a->[1]->[2] cmp $b->[1]->[2] or $a->[1]->[3] cmp $b->[1]->[3] or $a->[0] cmp $b->[0] } @queue;
+
+for my $qi (@squeue) {
+ handle_declaration( $release, @{$qi}, *STDOUT );
+}
use Data::Dump qw( pp );
use JSON qw( to_json encode_json );
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: 3b22d7dafc0955eefa16b56270fb12b7fa66e58f
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Fri Oct 28 13:42:09 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=3b22d7da
enable dev/backpan in output again
---
scripts/gen_ebuild.pl | 4 ++--
1 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 867127b..9828a12 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -67,8 +67,8 @@ sub provider_map {
for my $provider ( @providers ) {
- #next if $provider->{status} eq 'backpan';
- #next if $provider->{maturity} eq 'developer';
+ next if $provider->{status} eq 'backpan';
+ next if $provider->{maturity} eq 'developer';
# pp $provider;
my $dist = $provider->{distribution};
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: daa146d297c4d3842458e2e1709148bbf17cfe81
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Oct 25 20:46:34 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 31 02:45:46 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=daa146d2
make executable
---
0 files changed, 0 insertions(+), 0 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
old mode 100644
new mode 100755
^ permalink raw reply [flat|nested] 63+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: e7ba54d83323869a58d0951ae92ca0dd4a926b96
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Fri Oct 28 03:57:09 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=e7ba54d8
Now shows the oldest version, the newest version, and the closest
version.
Generally speaking, when declaring a dep, you'll want the one with the
"closest version" as your specifier for ">="
---
scripts/gen_ebuild.pl | 88 ++++++++++++++++++++++++++++++++++++++++--------
1 files changed, 73 insertions(+), 15 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index 1623bb8..867127b 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -52,35 +52,87 @@ my $dep_phases = get_dep_phases( $release );
use Data::Dump qw( pp );
use JSON qw( to_json encode_json );
+use Try::Tiny;
+use version ();
sub provider_map {
- my ( $module ) = shift;
+ my ( $module , $version ) = @_;
my @providers = metacpan->find_dist_simple( $module );
my %moduleprov;
-
+
+
+ my %specialvs;
+
+ my $wanted_version = version->parse( $version );
+
for my $provider ( @providers ) {
- next if $provider->{status} eq 'backpan';
- next if $provider->{maturity} eq 'developer';
+ #next if $provider->{status} eq 'backpan';
+ #next if $provider->{maturity} eq 'developer';
# pp $provider;
my $dist = $provider->{distribution};
my $distv = $provider->{version} // 'undef';
+ my $gv = 'undef';
+ if ( $distv ne 'undef' ){
+ try {
+ $gv = gentooize_version( $distv , { lax => 1 } );
+ } catch {
+ $gv = '???';
+ };
+ }
+
+ #next if $gv eq '???';
+
$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 . '"';
+
+ my $got_version = version->parse( $mod->{version} );
+
+ my $dv = $distv;
+ #if( $distv ne $modv ) {
+ $dv = sprintf "%s ( %s ) => \"%s\"" , $distv , $gv, $modv;
+ #}
+ # specials
+
+ $specialvs{newest} //= {};
+ $specialvs{oldest} //= {};
+ $specialvs{closest} //= {};
+ $specialvs{closestx} //= {};
+
+ $specialvs{newest}->{$dist} = $dv if not exists $specialvs{newest}->{$dist};
+ $specialvs{oldest}->{$dist} = $dv;
+
+ # *STDERR->printf("\e[99m%s > %s , %s\n", $got_version, $wanted_version, $got_version > $wanted_version );
+
+ if ( not defined $version or $got_version >= $wanted_version ){
+# *STDERR->printf("\e[99m%s > %s , %s x2\n", $got_version, $version , 1 );
+ if ( not defined $specialvs{closestx}->{$dist} ) {
+# *STDERR->printf("\e[99m%s > %s => set \n", $got_version, $version );
+ $specialvs{closestx}->{$dist} = $got_version;
+ $specialvs{closest}->{$dist} = $dv;
+ } else {
+ if( $specialvs{closestx}->{$dist} >= $got_version ) {
+# *STDERR->printf("\e[99m%s > %s => << \n", $got_version, $version );
+
+ $specialvs{closestx}->{$dist} = $got_version;
+ $specialvs{closest}->{$dist} = $dv;
+
+ }
+ }
}
+ #
+
push @provided_matching_mods, $dv
if $mod->{name} eq $module;
}
push @{ $moduleprov{$dist} }, @provided_matching_mods;
}
- return \%moduleprov;
+ return \%moduleprov, \%specialvs;
}
for my $module ( keys %modules ) {
for my $declaration ( @{ $modules{$module} } ) {
@@ -93,9 +145,9 @@ for my $module ( keys %modules ) {
my $want_string = "$release -> " . $declaration->[2] . " " . $declaration->[3] . " " . $depstring;
- my %moduleprov = %{ provider_map( $module ) };
+ my ( $moduleprov, $specialvs ) = provider_map( $module , $declaration->[0]);
- my $pc = scalar keys %moduleprov;
+ my $pc = scalar keys %$moduleprov;
my $multi = ( $pc > 1 );
my $any = ( $pc > 0 );
@@ -112,17 +164,23 @@ for my $module ( keys %modules ) {
*STDERR->printf("%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
}
- for my $prov ( keys %moduleprov ) {
+ my $indent = " \e[1;92m*";
+ $indent = " \e[1;91m*" if $multi;
+
+ for my $prov ( keys %{$moduleprov} ) {
my $prefix = $depstring . ' in ' . $prov;
- my $lines = xwrap( join q[, ], @{$moduleprov{ $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);
+ *STDERR->printf("%s newest: %s\e[0m\n", $indent, $specialvs->{newest}->{$prov});
+ *STDERR->printf("%s oldest: %s\e[0m\n", $indent, $specialvs->{oldest}->{$prov});
+ my $v = $specialvs->{closest}->{$prov};
+ if( not defined $v ){ $v = 'undef' }
+ *STDERR->printf("%s closest: %s\e[0m\n", $indent, $v );
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", $_ );
+ *STDERR->printf("%s %s%s -> %s%s\n", $indent, "\e[1;94m", $prov , "\e[0m\e[94m", $_ );
}
}
if ( $multi ){
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: b5d9da14ba9824a678d75a36018e52fca726403c
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Oct 25 13:40:46 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 31 02:45:46 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=b5d9da14
interesting reverse lookup stuff
---
scripts/gen_ebuild.pl | 70 +++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 70 insertions(+), 0 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
new file mode 100644
index 0000000..0d0fa06
--- /dev/null
+++ b/scripts/gen_ebuild.pl
@@ -0,0 +1,70 @@
+#!/usr/bin/env perl
+
+eval 'echo "Called with something not perl"' && exit 1 # Non-Perl protection.
+ if 0;
+
+use 5.14.2;
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use env::gentoo::perl_experimental;
+use metacpan qw( mcpan );
+
+my $flags;
+my $singleflags;
+
+@ARGV = grep { defined } map {
+ $_ =~ /^--(\w+)/
+ ? do { $flags->{$1}++; undef }
+ : do {
+ $_ =~ /^-(\w+)/
+ ? do { $singleflags->{$1}++; undef }
+ : do { $_ }
+ }
+} @ARGV;
+
+if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
+
+# FILENAME: gen_ebuild.pl
+# CREATED: 25/10/11 12:15:51 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: An attempt at generating ebuilds entirely from MetaCPAN data
+
+# usage:
+#
+# gen_ebuild.pl DOY/Moose-2.0301-TRIAL
+# emits Moose/Moose-2.30.100_rc.ebuild
+my ($release) = shift(@ARGV);
+
+my $result = [ map { $_->{as_string} } metacpan->find_dist_simple( $release , {notrim=>1}) ];
+
+use Data::Dump qw( pp );
+use JSON qw( to_json );
+say to_json($result , { pretty => 1 } );
+1;
+
+sub pkg_for_module {
+ my ($module) = shift;
+
+}
+
+sub gen_dep {
+ state $template = qq{\t# %s%s\n\techo %s\n};
+ my ( $module, $version ) = @_;
+
+}
+
+sub help {
+ return <<'EOF';
+gen_ebuild.pl
+
+USAGE:
+
+ gen_ebuild.pl DOY/Moose-2.0301-TRIAL
+
+ edit ./Moose-2.30.100_rc.ebuild
+
+ done!
+
+EOF
+}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-25 19:46 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-25 19:46 UTC (permalink / raw
To: gentoo-commits
commit: dfa465a87d3dcc442ed544966f6e10b940d77b5f
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Oct 25 19:45:58 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Tue Oct 25 19:45:58 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=dfa465a8
[scripts/package_log.pl] +x perms
---
0 files changed, 0 insertions(+), 0 deletions(-)
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
old mode 100644
new mode 100755
^ permalink raw reply [flat|nested] 63+ messages in thread
* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-25 19:46 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-25 19:46 UTC (permalink / raw
To: gentoo-commits
commit: eeb6d383783c990d56f039cd0ffe92c9e0dc6838
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Oct 25 19:43:09 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Tue Oct 25 19:45:19 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=eeb6d383
[scripts/module_log.pl] improve help
---
scripts/module_log.pl | 66 +++++++++++++++++++++++++++++++++++++-----------
1 files changed, 51 insertions(+), 15 deletions(-)
diff --git a/scripts/module_log.pl b/scripts/module_log.pl
index cf0d498..ff012af 100755
--- a/scripts/module_log.pl
+++ b/scripts/module_log.pl
@@ -26,6 +26,52 @@ my $singleflags;
if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
+sub help {
+ return <<'EOF';
+module_log.pl
+
+USAGE:
+
+ module_log.pl Class::MOP::Class
+
+ # See Class::MOP::Class started in Class-MOP and moved to Moose
+ #
+ # NOTE: Due to a caveat in PAUSE with how indexing works, Modules may look
+ # like they're comming from weird places.
+ #
+ # this is usually due to somebody lexically hacking a foreign package like so:
+ #
+ # { package Foo; blah blah blah }
+ #
+ # Unfortunately, PAUSE indexer sees that 'package Foo' and then deems this a place 'Foo' is defined.
+ #
+ # Usually that doesn't pose a problem, as the author who releases the containing package rarely has
+ # AUTHORITY permssion on the hacked package, so it doesn't get indexed. ( ie: HTTP::Request::Common )
+ #
+ # However, in the event the author has permissions to publish 'Foo', the indexer runs the risk
+ # of taking that tiny little package declaration as *the most recent version of that package*
+ # and is likely to try installing it. ( ie: HTTP::Message )
+ #
+ # For the most part, the "indexed but not authorised" case is eliminated by the query,
+ # but we have to weed out some false matches client side due to a current API limitation.
+ #
+ # but you can turn this weeding off for diagnostic reasons with
+ #
+ # module_log.pl --notrim HTTP::Message
+ #
+ # PROTIP: Usually when people do this foreign hacking, they don't define a VERSION in the same context
+ # which thankfully gives you the ability to assume its not sourceable.
+ #
+ # Try this:
+ #
+ # module_log.pl --notrim HTTP::Request::Common
+ #
+ # and see all the hacking in Apache-TestRequest turn up =)
+ #
+
+EOF
+}
+
# FILENAME: module_log.pl
# CREATED: 25/10/11 12:15:51 by Kent Fredric (kentnl) <kentfredric@gmail.com>
# ABSTRACT: Show the full history of a Module across distributions.
@@ -34,13 +80,15 @@ if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
#
# module_log.pl Class::MOP
# # emits both Class-MOP and Moose history
+
+use Data::Dump qw( pp );
+
my ($release) = shift(@ARGV);
-my $result = [ map { $_->{as_string} } metacpan->find_dist_simple( $release , {notrim=>1}) ];
+my $result = [ map { $_->{as_string} } metacpan->find_dist_simple( $release, $flags ) ];
-use Data::Dump qw( pp );
use JSON qw( to_json );
-say to_json($result , { pretty => 1 } );
+say to_json( $result, { pretty => 1 } );
1;
sub pkg_for_module {
@@ -54,15 +102,3 @@ sub gen_dep {
}
-sub help {
- return <<'EOF';
-module_log.pl
-
-USAGE:
-
- module_log.pl Class::MOP::Class
-
- # See Class::MOP::Class started in Class-MOP and moved to Moose
-
-EOF
-}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-25 19:46 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-25 19:46 UTC (permalink / raw
To: gentoo-commits
commit: d384d09cd4451a333cd0278d1aefd5f1ffbfec25
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Oct 25 19:23:41 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Tue Oct 25 19:45:07 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=d384d09c
[scripts/module_log.pl] Pull out module history code into its own util
---
scripts/module_log.pl | 68 +++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 68 insertions(+), 0 deletions(-)
diff --git a/scripts/module_log.pl b/scripts/module_log.pl
new file mode 100755
index 0000000..cf0d498
--- /dev/null
+++ b/scripts/module_log.pl
@@ -0,0 +1,68 @@
+#!/usr/bin/env perl
+
+eval 'echo "Called with something not perl"' && exit 1 # Non-Perl protection.
+ if 0;
+
+use 5.14.2;
+use strict;
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use env::gentoo::perl_experimental;
+use metacpan qw( mcpan );
+
+my $flags;
+my $singleflags;
+
+@ARGV = grep { defined } map {
+ $_ =~ /^--(\w+)/
+ ? do { $flags->{$1}++; undef }
+ : do {
+ $_ =~ /^-(\w+)/
+ ? do { $singleflags->{$1}++; undef }
+ : do { $_ }
+ }
+} @ARGV;
+
+if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
+
+# FILENAME: module_log.pl
+# CREATED: 25/10/11 12:15:51 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Show the full history of a Module across distributions.
+
+# usage:
+#
+# module_log.pl Class::MOP
+# # emits both Class-MOP and Moose history
+my ($release) = shift(@ARGV);
+
+my $result = [ map { $_->{as_string} } metacpan->find_dist_simple( $release , {notrim=>1}) ];
+
+use Data::Dump qw( pp );
+use JSON qw( to_json );
+say to_json($result , { pretty => 1 } );
+1;
+
+sub pkg_for_module {
+ my ($module) = shift;
+
+}
+
+sub gen_dep {
+ state $template = qq{\t# %s%s\n\techo %s\n};
+ my ( $module, $version ) = @_;
+
+}
+
+sub help {
+ return <<'EOF';
+module_log.pl
+
+USAGE:
+
+ module_log.pl Class::MOP::Class
+
+ # See Class::MOP::Class started in Class-MOP and moved to Moose
+
+EOF
+}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-24 21:17 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-24 21:17 UTC (permalink / raw
To: gentoo-commits
commit: a3124f45d1cbeb9170123a31fdd1079a641b2e11
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 24 21:15:37 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 24 21:15:37 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=a3124f45
[scripts/package_log.pl] add a --nosummarize command to get full changes output
---
scripts/package_log.pl | 16 +++++++++++-----
1 files changed, 11 insertions(+), 5 deletions(-)
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index 1d36d12..70547b3 100644
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -201,6 +201,10 @@ sub change_for {
return unless $file;
+ if ( $flags->{'nosummarize'} ) {
+ return $file;
+ }
+
require CPAN::Changes;
my $changes = CPAN::Changes->load_string($file);
if ($changes) {
@@ -239,11 +243,13 @@ USAGE:
# Be verbose about what we're doing
package_log.pl Moose --trace --all
- --all Show all releases in the log.
- --help Show this message
- --changes Show ChangeLog Excerpts using CPAN::Changes where possible
- --deps Show Dependency data ( as reported via metadata )
- --trace Turn on extra debugging.
+ --all Show all releases in the log.
+ --help Show this message
+ --changes Show ChangeLog Excerpts using CPAN::Changes where possible
+ --deps Show Dependency data ( as reported via metadata )
+ --trace Turn on extra debugging.
+ --nosummarize Do no processing of Changes data and report it verbatim
+ ( Useful when CPAN::Changes gets it wrong :( )
EOF
}
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-10-24 18:26 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-10-24 18:26 UTC (permalink / raw
To: gentoo-commits
commit: f93a203f751970026f26bf3666145a92e13698ba
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 24 17:50:04 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 24 18:23:19 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=f93a203f
[Scripts/package_log.pl] refactor to be more functional.
don't fetch data that we don't use.
---
scripts/package_log.pl | 152 ++++++++++++++++++++++++++----------------------
1 files changed, 83 insertions(+), 69 deletions(-)
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index 69deb38..1d36d12 100644
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -36,6 +36,7 @@ use coloriterator
my $flags;
my $singleflags;
+
@ARGV = grep { defined } map {
$_ =~ /^--(\w+)/
? do { $flags->{$1}++; undef }
@@ -46,51 +47,20 @@ my $singleflags;
}
} @ARGV;
-if ( $flags->{help} or $singleflags->{h} ) {
- print <<"EOF";
-package_log.pl
-
-USAGE:
-
- package_log.pl PACKAGE [PACKAGE*] [--all] [--help] [--changes] [--deps] [--trace]
-
- ie:
-
- # Just show the recent log for Moose, Catalyst-Runtime and Dist-Zilla
- package_log.pl Moose Catalyst-Runtime Dist-Zilla
-
- # show all log events for Moose
- package_log.pl Moose --all
-
- # show recent Moose log events with attached changelog data and dependenices
- package_log.pl Moose --changes --deps
-
- # Be verbose about what we're doing
- package_log.pl Moose --trace --all
-
- --all Show all releases in the log.
- --help Show this message
- --changes Show ChangeLog Excerpts using CPAN::Changes where possible
- --deps Show Dependency data ( as reported via metadata )
- --trace Turn on extra debugging.
-EOF
- exit 0;
-}
-
-my $package = shift @ARGV;
-
-my (@want_dists) = ( $package, @ARGV );
+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 $search = {};
+
$search->{query} = {
terms => {
- distribution => [ @want_dists, ],
+ distribution => [ @ARGV, ],
minimum_match => 1,
},
};
+
if ( not $flags->{all} ) {
$search->{filter} = {
range => {
@@ -108,62 +78,75 @@ $search->{sort} = [
];
$search->{size} = 1024;
-# $flags->{fields} = [qw( author name date distribution )],
+$search->{fields} = [qw( author name date distribution version )];
+
+if ( $flags->{deps} ) {
+ push @{ $search->{fields} }, '_source.dependency';
+}
+
_log( ['initialized: fetching search results'] );
my $results = mcpan->post( 'release', $search );
_log( [ 'fetched %s results', scalar @{ $results->{hits}->{hits} } ] );
-sub ac {
- return author_colour( $_[0] ) . $_[0] . RESET;
-}
+for my $result ( @{ $results->{hits}->{hits} } ) {
-sub dc {
- return dist_colour( $_[0] ) . $_[1] . RESET;
+ # use Data::Dump qw(pp);
+ # pp $result;
+ say $_ for format_result( $result->{fields}, $flags );
}
-sub pp {
- require Data::Dump;
- goto \&Data::Dump::pp;
-}
+exit 0;
-sub gv {
- require Gentoo::PerlMod::Version;
- goto \&Gentoo::PerlMod::Version::gentooize_version;
-}
+# Utils
+
+sub ac { return author_colour( $_[0] ) . $_[0] . RESET }
+sub dc { return dist_colour( $_[0] ) . $_[1] . RESET }
+sub pp { require Data::Dump; goto \&Data::Dump::pp }
+sub gv { require Gentoo::PerlMod::Version; goto \&Gentoo::PerlMod::Version::gentooize_version }
sub _log {
return unless $flags->{trace};
- if ( not ref $_[0] ) {
- return *STDERR->print(@_);
- }
- my $conf = $_[0];
- my ( $str, @args ) = @{$conf};
+ return *STDERR->print(@_) if ( not ref $_[0] );
+
+ state $prefix = "\e[7m* package_log.pl:\e[0m ";
+
+ my ( $str, @args ) = @{ $_[0] };
$str =~ s/\n?$/\n/;
- return *STDERR->print( sprintf "\e[7m* %s:\e[0m " . $str, 'package_log.pl', @args );
+
+ *STDERR->print($prefix);
+ *STDERR->printf( $str, @args );
+ return;
+
}
-for my $result ( @{ $results->{hits}->{hits} } ) {
+sub format_result {
+
+ my %f = %{ $_[0] };
+ my %opts = %{ $_[1] || {} };
+
+ _log( [ 'formatting entry for %s', $f{name} ] );
- my %f = %{ $result->{_source} };
+ my @out;
- # say pp \%f;
- my ( $date, $distribution, $name, $author, $deps, $version ) = @f{qw( date distribution name author dependency version )};
- _log( [ 'formatting entry for %s', $name ] );
- say entry_heading( @f{qw( date author distribution name version)} );
+ push @out, entry_heading( @f{qw( date author distribution name version)} );
- if ( $flags->{deps} ) {
- _log( [ 'processing %s deps for %s', scalar @{$deps}, $name ] );
- print $_ for sort map { dep_line($_) } @{$deps};
+ my $name = $f{name};
+ my $author = $f{author};
+
+ if ( $opts{deps} ) {
+ my $deps = $f{'_source.dependency'};
+ _log( [ 'processing %s deps for %s', scalar @{$deps}, $f{name} ] );
+ push @out, sort map { dep_line($_) } @{$deps};
}
- if ( $flags->{changes} ) {
+ if ( $opts{changes} ) {
_log( [ 'processing changes deps for %s', $name ] );
}
- if ( $flags->{changes} and my $message = change_for( $author, $name ) ) {
- say "\n\e[1;38m" . $message . "\e[0m";
+ if ( $opts{changes} and my $message = change_for( $author, $name ) ) {
+ push @out, "\e[1;38m" . $message . "\e[0m";
}
-
+ return @out;
}
sub entry_heading {
@@ -183,7 +166,7 @@ sub dep_line {
my $rel = ( $dep->{relationship} ne 'requires' ? BRIGHT_BLUE . $dep->{relationship} : q[] );
my $phase = ( $dep->{phase} eq 'develop' ? BRIGHT_GREEN : q[] ) . $dep->{phase};
my $version = $gentoo_version . gv( $dep->{version}, { lax => 1 } ) . RESET;
- return sprintf "%s %s: %s %s %s\n", $rel, $phase, $dep->{module}, $dep->{version}, $version;
+ return sprintf "%s %s: %s %s %s", $rel, $phase, $dep->{module}, $dep->{version}, $version;
}
sub change_for {
@@ -234,3 +217,34 @@ sub change_for {
}
+sub help {
+ return <<"EOF";
+package_log.pl
+
+USAGE:
+
+ package_log.pl PACKAGE [PACKAGE*] [--all] [--help] [--changes] [--deps] [--trace]
+
+ ie:
+
+ # Just show the recent log for Moose, Catalyst-Runtime and Dist-Zilla
+ package_log.pl Moose Catalyst-Runtime Dist-Zilla
+
+ # show all log events for Moose
+ package_log.pl Moose --all
+
+ # show recent Moose log events with attached changelog data and dependenices
+ package_log.pl Moose --changes --deps
+
+ # Be verbose about what we're doing
+ package_log.pl Moose --trace --all
+
+ --all Show all releases in the log.
+ --help Show this message
+ --changes Show ChangeLog Excerpts using CPAN::Changes where possible
+ --deps Show Dependency data ( as reported via metadata )
+ --trace Turn on extra debugging.
+EOF
+
+}
+
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-09-23 6:17 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-09-23 6:17 UTC (permalink / raw
To: gentoo-commits
commit: 96e36ba5d7a32ff510915d54b089386554466986
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Wed Sep 21 10:14:06 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Thu Sep 22 07:26:41 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=96e36ba5
[scripts] make multiplex script +x
[scripts] make error conditions in ssh_multiplex script clearer
---
scripts/ssh_multiplex.pl | 14 ++++++++++----
1 files changed, 10 insertions(+), 4 deletions(-)
diff --git a/scripts/ssh_multiplex.pl b/scripts/ssh_multiplex.pl
old mode 100644
new mode 100755
index a83cd62..cb3d4c9
--- a/scripts/ssh_multiplex.pl
+++ b/scripts/ssh_multiplex.pl
@@ -77,20 +77,26 @@ sub map_param {
sub spawn_child {
my (@cmd) = @_;
+ local $!;
+ local $?;
+ local $@;
my $cleanup = pop @cmd;
my $pid;
if ( not defined( $pid = fork() ) ) {
- my (@error) = ( $!, $?, $@ );
+ my (%error) = ( '$!', $!, '$?', $?, '$@', $@ );
require Carp;
- Carp::croak("Forking Failed :( @error ");
+ Carp::croak( 'Forking Failed :( ' . dump \%error );
}
if ($pid) {
return $pid;
}
+ local $!;
+ local $?;
+ local $@;
system(@cmd) == 0 or do {
- my (@error) = ( $!, $?, $@ );
+ my (%error) = ( '$!', $!, '$?', $?, '$@', $@ );
require Carp;
- Carp::croak("Running command Failed :( @error ");
+ Carp::croak( 'Running command Failed :( ' . dump \%error );
};
$cleanup->();
exit;
^ permalink raw reply related [flat|nested] 63+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/
@ 2011-08-29 5:44 Kent Fredric
0 siblings, 0 replies; 63+ messages in thread
From: Kent Fredric @ 2011-08-29 5:44 UTC (permalink / raw
To: gentoo-commits
commit: 3a05ea43a2e634e12124f44e49b7c8b059d264ec
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Tue Aug 2 01:46:29 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Aug 29 05:39:17 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=3a05ea43
[scripts] new script to facilitate spawning the ssh backgrounded connections. ( I always forget how to do this and its annoying, this script mostly just does the right thing. Its a bit more annoying on subsequent calls to the script if the master connection is already up, but its really not worth mention )
---
scripts/ssh_multiplex.pl | 109 ++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 109 insertions(+), 0 deletions(-)
diff --git a/scripts/ssh_multiplex.pl b/scripts/ssh_multiplex.pl
new file mode 100644
index 0000000..a83cd62
--- /dev/null
+++ b/scripts/ssh_multiplex.pl
@@ -0,0 +1,109 @@
+#!/usr/bin/env perl
+eval 'echo "Called with something not perl"' && exit 1 # Non-Perl protection.
+ if 0;
+
+use strict;
+use warnings;
+use 5.12.1;
+
+# FILENAME: ssh_multiplex.pl
+# CREATED: 02/08/11 12:18:23 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Spawn Background SSH Masters for Gentoo Git Sources
+
+use File::Which qw( which );
+use Data::Dump qw( dump );
+
+my $ssh_cmd = which(qw( ssh ));
+my %flag_map = (
+ background => ['-f'],
+ no_execute_command => ['-N'],
+ no_stdin => ['-n'],
+ control_master => [ '-o', 'ControlMaster=auto' ],
+);
+
+my @pids;
+
+spawn_cmd(
+ {
+ pids => \@pids,
+ params => [qw( background no_execute_command no_stdin control_master )],
+ connect => 'git@github.com',
+ cleanup => sub {
+ say "\e[31mConnected to git\@github.com\e[0m";
+ },
+ }
+);
+
+spawn_cmd(
+ {
+ pids => \@pids,
+ params => [qw( background no_execute_command no_stdin control_master )],
+ connect => 'git@git.overlays.gentoo.org',
+ cleanup => sub {
+ say "\e[32mConnected to git\@git.overlays.gentoo.org\e[0m";
+ },
+ }
+);
+
+for (@pids) {
+ waitpid $_, 0;
+}
+
+say "Done.";
+
+exit;
+
+sub map_option {
+ my ($option) = @_;
+ if ( not exists $flag_map{$option} ) {
+ require Carp;
+ Carp::croak("Map for $option undefined");
+ }
+ return @{ $flag_map{$option} };
+}
+
+sub map_literal_array {
+ my ($literal) = @_;
+ return @{$literal};
+}
+
+sub map_param {
+ my ($param) = @_;
+ return map_option($param) if not ref $param;
+ return map_literal_array($param) if ref $param eq 'ARRAY';
+ require Carp;
+ Carp::croak("Unhandled parameter $param");
+}
+
+sub spawn_child {
+ my (@cmd) = @_;
+ my $cleanup = pop @cmd;
+ my $pid;
+ if ( not defined( $pid = fork() ) ) {
+ my (@error) = ( $!, $?, $@ );
+ require Carp;
+ Carp::croak("Forking Failed :( @error ");
+ }
+ if ($pid) {
+ return $pid;
+ }
+ system(@cmd) == 0 or do {
+ my (@error) = ( $!, $?, $@ );
+ require Carp;
+ Carp::croak("Running command Failed :( @error ");
+ };
+ $cleanup->();
+ exit;
+}
+
+sub spawn_cmd {
+ my ($args) = @_;
+ my @outargs = map { map_param($_) } @{ $args->{'params'} };
+ my (@cmd) = ( $ssh_cmd, @outargs, $args->{'connect'} );
+ say "Spawning " . dump( \@cmd );
+ $args->{cleanup} //= sub {
+ say "\e[31mConnected to " . $args->{'connect'} . "\e[0m";
+ };
+ push @{ $args->{pids} }, grep { defined } spawn_child( @cmd, $args->{cleanup} );
+}
+
^ permalink raw reply related [flat|nested] 63+ messages in thread
end of thread, other threads:[~2017-09-16 22:36 UTC | newest]
Thread overview: 63+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-10-24 9:09 [gentoo-commits] proj/perl-overlay:master commit in: scripts/ Kent Fredric
-- strict thread matches above, loose matches on Subject: below --
2017-09-16 22:36 Kent Fredric
2015-02-28 23:17 Kent Fredric
2015-02-28 23:17 Kent Fredric
2013-12-23 15:28 Kent Fredric
2013-05-01 23:03 Kent Fredric
2013-05-01 23:03 Kent Fredric
2012-10-24 15:49 Kent Fredric
2012-09-15 23:19 Kent Fredric
2012-08-02 11:46 Kent Fredric
2012-08-02 11:46 Kent Fredric
2012-07-31 3:04 Kent Fredric
2012-07-12 19:23 Torsten Veller
2012-06-22 7:34 Kent Fredric
2012-06-08 17:14 Kent Fredric
2012-05-27 2:30 Kent Fredric
2012-04-28 10:40 Kent Fredric
2012-04-18 3:32 Kent Fredric
2012-04-18 3:32 Kent Fredric
2012-04-18 3:32 Kent Fredric
2012-04-12 19:46 Kent Fredric
2012-04-09 16:05 Kent Fredric
2012-04-08 13:20 Kent Fredric
2012-04-08 13:20 Kent Fredric
2012-04-05 10:02 Kent Fredric
2012-03-27 1:26 Kent Fredric
2012-03-27 1:26 Kent Fredric
2012-03-27 1:26 Kent Fredric
2012-03-01 11:38 Kent Fredric
2012-02-29 12:22 Kent Fredric
2012-02-29 12:22 Kent Fredric
2012-02-29 12:06 Kent Fredric
2012-02-28 21:55 Kent Fredric
2012-02-28 21:55 Kent Fredric
2012-02-28 21:55 Kent Fredric
2012-02-24 7:13 Kent Fredric
2012-02-24 7:13 Kent Fredric
2012-02-12 7:22 Kent Fredric
2012-02-12 7:22 Kent Fredric
2011-12-05 21:45 Kent Fredric
2011-11-14 2:57 Kent Fredric
2011-11-14 2:57 Kent Fredric
2011-11-11 14:38 Kent Fredric
2011-10-31 18:05 Kent Fredric
2011-10-31 18:05 Kent Fredric
2011-10-31 8:46 Kent Fredric
2011-10-31 7:10 Kent Fredric
2011-10-31 4:52 Kent Fredric
2011-10-31 2:48 Kent Fredric
2011-10-31 2:48 Kent Fredric
2011-10-31 2:48 Kent Fredric
2011-10-31 2:48 Kent Fredric
2011-10-31 2:48 Kent Fredric
2011-10-31 2:48 Kent Fredric
2011-10-31 2:48 Kent Fredric
2011-10-31 2:48 Kent Fredric
2011-10-25 19:46 Kent Fredric
2011-10-25 19:46 Kent Fredric
2011-10-25 19:46 Kent Fredric
2011-10-24 21:17 Kent Fredric
2011-10-24 18:26 Kent Fredric
2011-09-23 6:17 Kent Fredric
2011-08-29 5:44 Kent Fredric
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox