From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from pigeon.gentoo.org ([208.92.234.80] helo=lists.gentoo.org) by finch.gentoo.org with esmtp (Exim 4.60) (envelope-from ) id 1RIGXb-0000Fd-Um for garchives@archives.gentoo.org; Mon, 24 Oct 2011 09:09:56 +0000 Received: from pigeon.gentoo.org (localhost [127.0.0.1]) by pigeon.gentoo.org (Postfix) with SMTP id F363521C03E; Mon, 24 Oct 2011 09:09:48 +0000 (UTC) Received: from smtp.gentoo.org (smtp.gentoo.org [140.211.166.183]) by pigeon.gentoo.org (Postfix) with ESMTP id B395521C03E for ; Mon, 24 Oct 2011 09:09:48 +0000 (UTC) Received: from pelican.gentoo.org (unknown [66.219.59.40]) (using TLSv1 with cipher AECDH-AES256-SHA (256/256 bits)) (No client certificate requested) by smtp.gentoo.org (Postfix) with ESMTPS id B5C4C1B4009 for ; Mon, 24 Oct 2011 09:09:47 +0000 (UTC) Received: from localhost.localdomain (localhost [127.0.0.1]) by pelican.gentoo.org (Postfix) with ESMTP id 29F1280042 for ; Mon, 24 Oct 2011 09:09:47 +0000 (UTC) From: "Kent Fredric" To: gentoo-commits@lists.gentoo.org Content-type: text/plain; charset=UTF-8 Reply-To: gentoo-dev@lists.gentoo.org, "Kent Fredric" Message-ID: <9a1c11bd3efa9bdd66060a80ea34418e1bc17b91.kent@gentoo> Subject: [gentoo-commits] proj/perl-overlay:master commit in: scripts/ X-VCS-Repository: proj/perl-overlay X-VCS-Files: scripts/package_log.pl X-VCS-Directories: scripts/ X-VCS-Committer: kent X-VCS-Committer-Name: Kent Fredric X-VCS-Revision: 9a1c11bd3efa9bdd66060a80ea34418e1bc17b91 Date: Mon, 24 Oct 2011 09:09:47 +0000 (UTC) Precedence: bulk List-Post: List-Help: List-Unsubscribe: List-Subscribe: List-Id: Gentoo Linux mail X-BeenThere: gentoo-commits@lists.gentoo.org Content-Transfer-Encoding: quoted-printable X-Archives-Salt: X-Archives-Hash: a973f9e720374591fe4e68870624fedc commit: 9a1c11bd3efa9bdd66060a80ea34418e1bc17b91 Author: Kent Fredric gmail com> AuthorDate: Mon Oct 24 09:06:51 2011 +0000 Commit: Kent Fredric gmail com> CommitDate: Mon Oct 24 09:06:51 2011 +0000 URL: http://git.overlays.gentoo.org/gitweb/?p=3Dproj/perl-overlay.= git;a=3Dcommit;h=3D9a1c11bd [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=20 +use 5.14.2; +use strict; +use warnings; + +# FILENAME: pvlist.pl +# CREATED: 16/10/11 20:16:03 by Kent Fredric (kentnl) +# 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 =3D do { + require MetaCPAN::API; + require CHI; + my $cache =3D CHI->new( + driver =3D> 'File', + root_dir =3D> '/tmp/gentoo-metacpan-cache' + ); + require WWW::Mechanize::Cached; + my $mech =3D WWW::Mechanize::Cached->new( + cache =3D> $cache, + timeout =3D> 20000, + autocheck =3D> 1, + ); + require HTTP::Tiny::Mech; + MetaCPAN::API->new( + ua =3D> HTTP::Tiny::Mech->new( mechua =3D> $mech ) + ); + }; +} + +my $flags; +my $singleflags; +@ARGV =3D grep { defined } map {=20 + $_ =3D~ /^--(\w+)/ ?=20 + do { $flags->{$1}++ ; undef } + :=20 + do { $_ =3D~ /^-(\w+)/ ?=20 + 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 depend= enices + 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 =3D shift @ARGV; + +my (@want_dists) =3D ( $package, @ARGV ); + +my $oldest_date =3D '2011-09-01T00:00:00.000Z'; +my $newest_date =3D '2012-01-01T00:00:00.000Z'; + +my $search =3D {}; +$search->{query} =3D { + terms =3D> { + distribution =3D> [ @want_dists, ], + minimum_match =3D> 1, + }, +}; +if ( not $flags->{all} ) { + $search->{filter} =3D { + range =3D> { + date =3D> { + from =3D> $oldest_date, + to =3D> $newest_date, + }, + }, + }; +} +$search->{sort} =3D [ + + # { 'author' =3D> 'asc', }, + { 'date' =3D> 'desc', }, +]; +$search->{size} =3D 1024; + +# $flags->{fields} =3D [qw( author name date distribution )], +_log(['initialized: fetching search results']); + +my $results =3D 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 =3D $_[0]; + my ( $str, @args ) =3D @{$conf}; + $str =3D~ 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 =3D %{ $result->{_source} }; + + # say pp \%f; + my ( $date, $distribution, $name, $author, $deps, $version ) =3D @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 =3D 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 ) =3D @_; + state $date_style =3D UNDERLINE . CYAN; + state $gentoo_version =3D BOLD . CYAN; + return sprintf "%s - %s/%s %s", + $date_style . $date . RESET, + ac($author), + dc( $distribution, $name ), + $gentoo_version . gv( $version, { lax =3D> 1 } ) . RESET; +} + +sub dep_line { + my ($dep) =3D @_; + state $gentoo_version =3D BOLD . CYAN; + my $rel =3D ( $dep->{relationship} ne 'requires' ? BRIGHT_BLUE . $dep-= >{relationship} : q[] ); + my $phase =3D ( $dep->{phase} eq 'develop' ? BRIGHT_GREEN : q[] ) . $d= ep->{phase}; + my $version =3D $gentoo_version . gv( $dep->{version}, { lax =3D> 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 ) =3D @_; + my $file; + my @trylist =3D qw( Changes CHANGES ChangeLog ); + my @errors; + + my $success; + + for my $basename ( @trylist ) { + try { + _log(['trying %s for %s', $basename, $release ]); + $file =3D mcpan->source( + author =3D> $author, + release =3D> $release, + path =3D> $basename, + ); + $success =3D $basename; + } catch { + $success =3D 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 =3D CPAN::Changes->load_string($file); + if ( $changes ){ + my @releases =3D $changes->releases(); + return $releases[-1]->serialize() if @releases; + _log(['No releases reported by CPAN::Changes for file %s on %s', $su= ccess, $release ]); + #warn "No releases :( "; + } + #warn "Cant load \$file with CPAN::Changes"; + my @out =3D split /$/m, $file; + return join qq{\n}, splice @out, 0, 10; + +} + +sub ac { + state $cgen =3D mcgen(); + return $cgen->( $_[0] ) . $_[0] . RESET; +} + +sub dc { + state $cgen =3D mcgen(); + return $cgen->( $_[0] ) . $_[1] . RESET; +} + +sub ITALIC() { "\e[3m" } + +sub gen_colour_map { + my (@styles) =3D ( + RESET, + BOLD, + ITALIC, + UNDERLINE, + REVERSE, + ( ( BOLD . ITALIC, BOLD . UNDERLINE, BOLD . REVERSE ), ( ITALIC . UN= DERLINE, ITALIC . REVERSE, ), ( UNDERLINE . REVERSE ), ), + ( BOLD . ITALIC . UNDERLINE, BOLD . ITALIC . REVERSE, ITALIC . UNDER= LINE . REVERSE, ), + ( BOLD . ITALIC . UNDERLINE . REVERSE ), + ); + my (@fgs) =3D ( + 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) =3D ( + "", 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 =3D ( + [ 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 =3D sub { + my ( $style, $fg, $bg ) =3D @_; + for my $bc (@bad) { + my ( $sm, $fgm, $bgm ); + $sm =3D ( not defined $bc->[0] or $bc->[0] eq $style ); + $fgm =3D ( not defined $bc->[1] or $bc->[1] eq $fg ); + $bgm =3D ( 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 =3D {}; + my $cmap =3D gen_colour_map; + my $colour_gen =3D sub { + my $colour =3D shift @{$cmap}; + push @{$cmap}, $colour; + return $colour; + }; + return sub { + my $key =3D $_[0]; + return $colours->{$key} if exists $colours->{$key}; + return ( $colours->{$key} =3D $colour_gen->() ); + }; +} +