diff options
Diffstat (limited to 'scripts')
| -rw-r--r-- | scripts/lib/colorcarp.pm | 57 | ||||
| -rw-r--r-- | scripts/lib/coloriterator.pm | 103 | ||||
| -rw-r--r-- | scripts/lib/env/gentoo/perl_experimental.pm | 3 | ||||
| -rw-r--r-- | scripts/lib/metacpan.pm | 41 | ||||
| -rw-r--r-- | 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 f06d6c3dc..bc878eb28 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 000000000..3709083c6 --- /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 81ac6ef69..dbc9ff060 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 000000000..f80d7dbb0 --- /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 595b21321..244acebce 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->() ); - }; -} - |