* [gentoo-commits] proj/perl-overlay:eclass-moretests commit in: scripts/, scripts/lib/env/gentoo/, scripts/lib/
@ 2012-02-16 0:26 Kent Fredric
0 siblings, 0 replies; 2+ messages in thread
From: Kent Fredric @ 2012-02-16 0:26 UTC (permalink / raw
To: gentoo-commits
commit: 941b37a86a97d67652e5edf3942bdef1105aad2d
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 24 11:50:07 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 24 18:23:18 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=941b37a8
[Scripts/package_log.pl] refactor guts of package_log.pl
---
scripts/lib/colorcarp.pm | 57 ++++++++---
scripts/lib/coloriterator.pm | 103 ++++++++++++++++++++
scripts/lib/env/gentoo/perl_experimental.pm | 3 +-
scripts/lib/metacpan.pm | 41 ++++++++
scripts/package_log.pl | 140 +++++----------------------
5 files changed, 213 insertions(+), 131 deletions(-)
diff --git a/scripts/lib/colorcarp.pm b/scripts/lib/colorcarp.pm
index f06d6c3..bc878eb 100644
--- a/scripts/lib/colorcarp.pm
+++ b/scripts/lib/colorcarp.pm
@@ -1,30 +1,55 @@
use strict;
use warnings;
+
package colorcarp;
+
# FILENAME: colorcarp.pm
# CREATED: 02/08/11 16:11:38 by Kent Fredric (kentnl) <kentfredric@gmail.com>
# ABSTRACT: Easy currier for making coloured carp functions.
+=head1 SYNOPSIS
+
+ use colorcarp
+ defaults => { attributes => [qw( on_white )], method => 'confess' },
+ carper => { -as => 'redcarp' , attributes => [qw( red )] },
+ carper => { -as => 'bluecarp' , attributes => [qw( blue )] };
-sub import {
- my $inject = [ caller ]->[0];
- my $params = $_[1] ;
- for my $method ( keys %{$params} ){
- my ( $foreground, $background, $realcall ) = @{ $params->{$method} };
- eval "{ package $inject ; sub $method {
- my \$value = shift;
- color: {
- last color if \$ENV{NO_COLOR};
- \$value =~ s/^(.*)\$/\e[${foreground};${background}m \$1 \e[0m\n/mg;
- }
- \@_ = ( \$value );
- require Carp;
- goto \&Carp::${realcall}
- }}"
+=cut
+
+use Sub::Exporter -setup => {
+ exports => [ carper => \&build_carper, ],
+ collectors => [ defaults => \&defaults_collector ],
+};
+sub defaults_collector {
+ my ( $collection, $config ) = @_;
+ $collection->{attributes} ||= [];
+ if( @{ $collection->{attributes} } ){
+ require Term::ANSIColor;
+ return if not Term::ANSIColor::colorvalid(@{ $collection->{attributes} });
+ }
+ $collection->{method} ||= 'confess'
+ if( not grep { $_ eq $collection->{method} } qw( confess carp cluck croak ) ){
+ return;
}
+ return 1;
}
+sub build_carper {
+ my ( $class, $name, $args , $col ) = @_;
+ my $attributes = ( $args->{attributes} || [] );
+ unshift @$attributes, @{ $col->{defaults}->{attributes} };
+
+ require Carp;
+ my $call = Carp->can( $args->{method} || $col->{defaults}->{method} );
-1;
+ return sub {
+ require Term::ANSIColor;
+ my $value = shift;
+ @_ = ( Term::ANSIColor::colored( $attributes, $value ) );
+ goto $call;
+ };
+
+}
+1;
diff --git a/scripts/lib/coloriterator.pm b/scripts/lib/coloriterator.pm
new file mode 100644
index 0000000..3709083
--- /dev/null
+++ b/scripts/lib/coloriterator.pm
@@ -0,0 +1,103 @@
+use strict;
+use warnings;
+
+package coloriterator;
+
+# FILENAME: coloriterator.pm
+# CREATED: 25/10/11 00:08:36 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Iterate/Assign colors to keys
+
+=head1 SYNOPSIS
+
+ use coloriterator
+ coloriser => { -as => author_color },
+ coloriser => { -as => dist_color };
+
+ # Foo will always be the same color.
+
+ for (qw( foo bar foo baz )){
+ print dist_color($_) . $_ ;
+ }
+=cut
+
+use Sub::Exporter -setup => { exports => [ coloriser => \&build_coloriser ], };
+
+use Term::ANSIColor qw( :constants );
+
+sub ITALIC() { "\e[3m" }
+
+sub build_coloriser {
+ my ( $class, $name, $args ) = @_;
+ my $colors = {};
+ my $cmap = gen_color_map();
+ return sub {
+ my $key = $_[0];
+ return $colors->{$key} if exists $colors->{$key};
+ my $color = shift @{$cmap};
+ push @{$cmap}, $color;
+ $colors->{$key} = $color;
+ return $color;
+ };
+}
+
+sub gen_color_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 (@colors);
+ 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 @colors, $style . $fg . $bg;
+
+ }
+ }
+ }
+ return \@colors;
+}
+
+1;
+
diff --git a/scripts/lib/env/gentoo/perl_experimental.pm b/scripts/lib/env/gentoo/perl_experimental.pm
index 81ac6ef..dbc9ff0 100644
--- a/scripts/lib/env/gentoo/perl_experimental.pm
+++ b/scripts/lib/env/gentoo/perl_experimental.pm
@@ -36,7 +36,8 @@ sub _build_root {
return $root;
}
-use colorcarp { redconfess => [ 31, 47, 'confess' ] };
+use colorcarp
+ carper => { attributes => [qw( red on_white )], method => 'confess' , -as => 'redconfess' };
sub check_script {
my ( $self, $scriptname ) = @_;
diff --git a/scripts/lib/metacpan.pm b/scripts/lib/metacpan.pm
new file mode 100644
index 0000000..f80d7db
--- /dev/null
+++ b/scripts/lib/metacpan.pm
@@ -0,0 +1,41 @@
+use strict;
+use warnings;
+
+# FILENAME: metacpan.pm
+# CREATED: 25/10/11 00:29:25 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: A thin shim wrapper for metacpan::api with caching.
+#
+package metacpan;
+use File::Spec;
+
+use Sub::Exporter -setup => { exports => [ mcpan => \&build_mcpan ], };
+
+sub build_mcpan {
+ my $mcpan;
+ return sub {
+ $mcpan ||= do {
+ require CHI;
+ my $cache = CHI->new(
+ driver => 'File',
+ root_dir => File::Spec->catdir( File::Spec->tmpdir, 'gentoo-metacpan-cache' ),
+ );
+ require WWW::Mechanize::Cached;
+ my $mech = WWW::Mechanize::Cached->new(
+ cache => $cache,
+ timeout => 20000,
+ autocheck => 1,
+ );
+ require HTTP::Tiny::Mech;
+ my $tinymech = HTTP::Tiny::Mech->new( mechua => $mech );
+ require MetaCPAN::API;
+
+ MetaCPAN::API->new( ua => $tinymech );
+
+ };
+ return $mcpan;
+
+ };
+}
+
+1;
+
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index 595b213..244aceb 100644
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -18,26 +18,8 @@ use warnings;
# * 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 )
- );
- };
-}
+
+use metacpan qw( mcpan );
my $flags;
my $singleflags;
@@ -121,10 +103,33 @@ my $results = mcpan->post( 'release', $search );
_log(['fetched %s results', scalar @{$results->{hits}->{hits}} ]);
+use Term::ANSIColor qw( :constants );
+
+use Try::Tiny;
+
+
+use coloriterator
+ coloriser => { -as => 'author_colour' },
+ coloriser => { -as => 'dist_colour' };
+
+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] ) {
@@ -136,7 +141,6 @@ sub _log {
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} } ) {
@@ -160,10 +164,7 @@ for my $result ( @{ $results->{hits}->{hits} } ) {
}
-sub gv {
- require Gentoo::PerlMod::Version;
- goto \&Gentoo::PerlMod::Version::gentooize_version;
-}
+
sub entry_heading {
my ( $date, $author, $distribution, $name, $version ) = @_;
@@ -184,9 +185,6 @@ sub dep_line {
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;
@@ -232,89 +230,3 @@ sub change_for {
}
-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] 2+ messages in thread
* [gentoo-commits] proj/perl-overlay:eclass-moretests commit in: scripts/, scripts/lib/env/gentoo/, scripts/lib/
@ 2012-02-16 0:26 Kent Fredric
0 siblings, 0 replies; 2+ messages in thread
From: Kent Fredric @ 2012-02-16 0:26 UTC (permalink / raw
To: gentoo-commits
commit: af3f201ecb8868ab0ba4013d5180f8bbfbfbbaba
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 24 16:27:23 2011 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Mon Oct 24 18:23:18 2011 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=af3f201e
[scripts] fix colorcarp code, normalize body
---
scripts/lib/colorcarp.pm | 54 ++++++++++++-----
scripts/lib/env/gentoo/perl_experimental.pm | 2 +-
scripts/package_log.pl | 86 ++++++++++++++-------------
3 files changed, 83 insertions(+), 59 deletions(-)
diff --git a/scripts/lib/colorcarp.pm b/scripts/lib/colorcarp.pm
index bc878eb..fa18ab5 100644
--- a/scripts/lib/colorcarp.pm
+++ b/scripts/lib/colorcarp.pm
@@ -16,31 +16,51 @@ package colorcarp;
=cut
-use Sub::Exporter -setup => {
- exports => [ carper => \&build_carper, ],
- collectors => [ defaults => \&defaults_collector ],
+use Sub::Exporter -setup => {
+ exports => [ carper => \&build_carper, ],
+ collectors => [ defaults => \&defaults_collector ],
};
-sub defaults_collector {
- my ( $collection, $config ) = @_;
- $collection->{attributes} ||= [];
- if( @{ $collection->{attributes} } ){
- require Term::ANSIColor;
- return if not Term::ANSIColor::colorvalid(@{ $collection->{attributes} });
+
+sub _lint_opts {
+ my ( $hash, $set_unset ) = @_;
+
+ if ( $set_unset and ( not exists $hash->{attributes} or not defined $hash->{attributes} ) ) {
+ $hash->{attributes} = [];
+ }
+
+ #use Data::Dump;
+ #Data::Dump::pp( \@_ );
+ if ( exists $hash->{attributes} and defined $hash->{attributes} ) {
+ not ref $hash->{attributes} eq 'ARRAY' and do { require Carp; Carp::confess('attributes is not an arrayref') }
}
- $collection->{method} ||= 'confess'
- if( not grep { $_ eq $collection->{method} } qw( confess carp cluck croak ) ){
- return;
+ if ( $set_unset and ( not exists $hash->{method} or not defined $hash->{method} ) ) {
+ $hash->{method} = 'confess';
}
+ if ( exists $hash->{method} and defined $hash->{method} ) {
+
+ if ( not grep { $_ eq $hash->{method} } qw( confess carp cluck croak ) ) {
+ require Carp;
+ Carp::confess('method is not one of confess,carp,cluck,croak');
+ }
+ }
+}
+
+sub defaults_collector {
+ my ( $collection, $config ) = @_;
+ _lint_opts( $collection, 1 );
return 1;
}
sub build_carper {
- my ( $class, $name, $args , $col ) = @_;
- my $attributes = ( $args->{attributes} || [] );
- unshift @$attributes, @{ $col->{defaults}->{attributes} };
-
+ my ( $class, $name, $args, $col ) = @_;
+ _lint_opts( $col->{defaults}, 1 );
+ _lint_opts( $args, 0 );
+
+ my $attributes = [ @{ $col->{defaults}->{attributes} || [] }, @{ $args->{attributes} || [] } ];
+ my $method = $args->{method} || $col->{defaults}->{method} || 'ćonfess';
+
require Carp;
- my $call = Carp->can( $args->{method} || $col->{defaults}->{method} );
+ my $call = Carp->can($method);
return sub {
require Term::ANSIColor;
diff --git a/scripts/lib/env/gentoo/perl_experimental.pm b/scripts/lib/env/gentoo/perl_experimental.pm
index dbc9ff0..ea00924 100644
--- a/scripts/lib/env/gentoo/perl_experimental.pm
+++ b/scripts/lib/env/gentoo/perl_experimental.pm
@@ -37,7 +37,7 @@ sub _build_root {
}
use colorcarp
- carper => { attributes => [qw( red on_white )], method => 'confess' , -as => 'redconfess' };
+ carper => { attributes => [qw( red on_white )] , -as => 'redconfess' };
sub check_script {
my ( $self, $scriptname ) = @_;
diff --git a/scripts/package_log.pl b/scripts/package_log.pl
index 244aceb..69deb38 100644
--- a/scripts/package_log.pl
+++ b/scripts/package_log.pl
@@ -1,8 +1,23 @@
#!/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 Term::ANSIColor qw( :constants );
+use Try::Tiny;
+use coloriterator
+ coloriser => { -as => 'author_colour' },
+ coloriser => { -as => 'dist_colour' };
+
# 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
@@ -19,22 +34,19 @@ use warnings;
# * CPAN::Changes
#
-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 = grep { defined } map {
+ $_ =~ /^--(\w+)/
+ ? do { $flags->{$1}++; undef }
+ : do {
+ $_ =~ /^-(\w+)/
+ ? do { $singleflags->{$1}++; undef }
+ : do { $_ }
+ }
} @ARGV;
-if( $flags->{help} or $singleflags->{h} ) {
+if ( $flags->{help} or $singleflags->{h} ) {
print <<"EOF";
package_log.pl
@@ -62,7 +74,7 @@ USAGE:
--deps Show Dependency data ( as reported via metadata )
--trace Turn on extra debugging.
EOF
-exit 0;
+ exit 0;
}
my $package = shift @ARGV;
@@ -97,20 +109,11 @@ $search->{sort} = [
$search->{size} = 1024;
# $flags->{fields} = [qw( author name date distribution )],
-_log(['initialized: fetching search results']);
+_log( ['initialized: fetching search results'] );
my $results = mcpan->post( 'release', $search );
-_log(['fetched %s results', scalar @{$results->{hits}->{hits}} ]);
-
-use Term::ANSIColor qw( :constants );
-
-use Try::Tiny;
-
-
-use coloriterator
- coloriser => { -as => 'author_colour' },
- coloriser => { -as => 'dist_colour' };
+_log( [ 'fetched %s results', scalar @{ $results->{hits}->{hits} } ] );
sub ac {
return author_colour( $_[0] ) . $_[0] . RESET;
@@ -138,25 +141,24 @@ sub _log {
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 );
+ return *STDERR->print( sprintf "\e[7m* %s:\e[0m " . $str, 'package_log.pl', @args );
}
-
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 ]);
+ _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]);
+ _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]);
+ _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";
@@ -164,8 +166,6 @@ for my $result ( @{ $results->{hits}->{hits} } ) {
}
-
-
sub entry_heading {
my ( $date, $author, $distribution, $name, $version ) = @_;
state $date_style = UNDERLINE . CYAN;
@@ -185,6 +185,7 @@ sub dep_line {
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;
}
+
sub change_for {
my ( $author, $release ) = @_;
my $file;
@@ -193,24 +194,25 @@ sub change_for {
my $success;
- for my $basename ( @trylist ) {
+ for my $basename (@trylist) {
try {
- _log(['trying %s for %s', $basename, $release ]);
+ _log( [ 'trying %s for %s', $basename, $release ] );
$file = mcpan->source(
- author => $author,
- release => $release,
- path => $basename,
+ author => $author,
+ release => $release,
+ path => $basename,
);
$success = $basename;
- } catch {
+ }
+ catch {
$success = 0;
- _log(['failed with %s for %s : %s', $basename, $release, $_ ]);
+ _log( [ 'failed with %s for %s : %s', $basename, $release, $_ ] );
push @errors, $_;
};
last if $success;
}
if ( !$success ) {
- _log(['no changes file %s ', $release ]);
+ _log( [ 'no changes file %s ', $release ] );
warn for @errors;
}
@@ -218,12 +220,14 @@ sub change_for {
require CPAN::Changes;
my $changes = CPAN::Changes->load_string($file);
- if ( $changes ){
+ 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 ]);
+ _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;
^ permalink raw reply related [flat|nested] 2+ messages in thread
end of thread, other threads:[~2012-02-16 0:44 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2012-02-16 0:26 [gentoo-commits] proj/perl-overlay:eclass-moretests commit in: scripts/, scripts/lib/env/gentoo/, scripts/lib/ Kent Fredric
-- strict thread matches above, loose matches on Subject: below --
2012-02-16 0:26 Kent Fredric
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox