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 1RKhvk-0003Re-DS for garchives@archives.gentoo.org; Mon, 31 Oct 2011 02:48:56 +0000 Received: from pigeon.gentoo.org (localhost [127.0.0.1]) by pigeon.gentoo.org (Postfix) with SMTP id 982E121C0F3; Mon, 31 Oct 2011 02:48:09 +0000 (UTC) Received: from smtp.gentoo.org (smtp.gentoo.org [140.211.166.183]) by pigeon.gentoo.org (Postfix) with ESMTP id 47A6221C0F3 for ; Mon, 31 Oct 2011 02:48:09 +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 814D71B4020 for ; Mon, 31 Oct 2011 02:48:08 +0000 (UTC) Received: from localhost.localdomain (localhost [127.0.0.1]) by pelican.gentoo.org (Postfix) with ESMTP id EB97280069 for ; Mon, 31 Oct 2011 02:48:07 +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: Subject: [gentoo-commits] proj/perl-overlay:master commit in: scripts/lib/dep/handler/, scripts/, scripts/lib/ X-VCS-Repository: proj/perl-overlay X-VCS-Files: scripts/gen_ebuild.pl scripts/lib/dep/handler/bashcode.pm scripts/lib/deptools.pm scripts/pvlist.pl scripts/show_deptree.pl X-VCS-Directories: scripts/lib/dep/handler/ scripts/ scripts/lib/ X-VCS-Committer: kent X-VCS-Committer-Name: Kent Fredric X-VCS-Revision: d38f144656ae78ed3d3d0103ad3436de14b89113 Date: Mon, 31 Oct 2011 02:48:07 +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: 49285b5c-06af-41f6-b588-34e4f71671ab X-Archives-Hash: 4e2d2d410c224eaa1ec404dfb51725da commit: d38f144656ae78ed3d3d0103ad3436de14b89113 Author: Kent Fredric gmail com> AuthorDate: Mon Oct 31 02:35:57 2011 +0000 Commit: Kent Fredric gmail com> CommitDate: Mon Oct 31 02:45:48 2011 +0000 URL: http://git.overlays.gentoo.org/gitweb/?p=3Dproj/perl-overlay.= git;a=3Dcommit;h=3Dd38f1446 Ebuild Output target --- scripts/gen_ebuild.pl | 191 +++++++++++++++++++++++++++++ scripts/lib/dep/handler/bashcode.pm | 80 ++++++++++++ scripts/lib/deptools.pm | 4 +- scripts/pvlist.pl | 228 +++++++++++++++++++++++++++++= ++++++ scripts/show_deptree.pl | 9 +- 5 files changed, 506 insertions(+), 6 deletions(-) diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl new file mode 100755 index 0000000..4f09d25 --- /dev/null +++ b/scripts/gen_ebuild.pl @@ -0,0 +1,191 @@ +#!/usr/bin/env perl + +eval 'echo "Called with something not perl"' && exit 1 # Non-Perl pro= tection. + if 0; + +use 5.14.2; +use strict; +use warnings; +use FindBin; +use lib "$FindBin::Bin/lib"; +use env::gentoo::perl_experimental; +use utf8; + +my $env =3D env::gentoo::perl_experimental->new(); +my $flags; +my $singleflags; + +@ARGV =3D grep { defined } map { + $_ =3D~ /^--(\w+)/ + ? do { $flags->{$1}++; undef } + : do { + $_ =3D~ /^-(\w+)/ + ? do { $singleflags->{$1}++; undef } + : do { $_ } + } +} @ARGV; + +if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; } + +# FILENAME: show_deptree.pl +# CREATED: 25/10/11 12:15:51 by Kent Fredric (kentnl) +# ABSTRACT: show the metadata harvested for a given packages install tre= e. + +# usage: +# +# gen_ebuild.pl DOY/Moose-2.0301-TRIAL +# +sub help { + return <<'EOF'; +gen_ebuild.pl + +USAGE: + + show_deptree.pl DOY/Moose-2.0301-TRIAL + +EOF +} +my ($release) =3D shift(@ARGV); + + + +*STDOUT->binmode(':utf8'); +*STDERR->binmode(':utf8'); + +require deptools; + +my ( $release_info ) =3D deptools::get_deps( $release ); +my $dep_phases =3D deptools::get_dep_phases($release); + +my @queue; + +for my $module ( keys %{ $dep_phases->{modules} } ) { + for my $declaration ( @{ $dep_phases->{modules}->{$module} } ) { + push @queue, [ $module, $declaration ]; + } +} +my @squeue =3D + 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 =3D dep::handler::stdout->new(); +my $handler2 =3D dep::handler::bashcode->new(); + + +for my $qi (@squeue) { + deptools::dispatch_dependency_handler( $release, @{$qi}, $handler2 ); +} + +my $depends =3D []; +my $rdepends =3D []; +require POSIX; +my $year =3D POSIX::strftime('%Y', gmtime); + +my $path =3D deptools::gentooize_pkg($release_info->{distribution} ); +require Gentoo::PerlMod::Version; +my $version =3D Gentoo::PerlMod::Version::gentooize_version( $release_in= fo->{version} , { lax =3D> 1 } ); +$env->root->subdir($path)->mkpath; +my $file =3D $env->root->subdir($path)->file($release_info->{distributio= n} . '-' . $version . '.ebuild' ); + +my ( $fh ) =3D $file->openw; +say "Writing $file"; +$fh->say("# Copyright 1999-$year Gentoo Foundation"); +$fh->say("# Distributed under the terms of the GNU General Public Licens= e v2"); +$fh->say("# \$Header: \$"); +$fh->say("EAPI=3D4"); +$fh->say("MODULE_AUTHOR=3D" . $release_info->{author}); +$fh->say("MODULE_VERSION=3D" . $release_info->{version}); +$fh->say('inherit perl-module'); +$fh->say(''); + +$fh->say('DESCRIPTION=3D"' . quotemeta( $release_info->{abstract} ) . '"= '); + +my $lics =3D []; +my $licmap =3D { + perl_5 =3D> [qw( Artistic GPL-2 )], +}; + +for my $lic ( @{ $release_info->{license} } ){=20 + if ( exists $licmap->{$lic} ){=20 + push @$lics, @{ $licmap->{$lic}}; + } else { + warn "No Gentoo maping listed for $lic license type"; + } +} + +if( scalar @$lics =3D=3D 1 ){=20 + $fh->say('LICENSE=3D" ' . $lics->[0] . '"'); +} elsif ( scalar @$lics > 1 ){ + $fh->say('LICENSE=3D" || ( ' . (join q{ } , @$lics) . ' )"'); +} else { + $fh->say('LICENSE=3D""'); +} +$fh->say('SLOT=3D"0"'); +$fh->say('KEYWORDS=3D"~amd64 ~x86"'); +if( $handler2->has_tdeps ) {=20 + $fh->say('IUSE=3D"test"'); +} else { + $fh->say('IUSE=3D""'); +} + +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('}'); + 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('}'); + 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('}'); + 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('}'); + push @{ $depends }, 'test? ( $(perl_meta_test) )'; +} + +$fh->say("DEPENDS=3D\"\n" . ( join qq{\n}, map { "\t$_" } @{$depends} )= . "\n\""); +$fh->say("RDEPENDS=3D\"\n" . ( join qq{\n}, map { "\t$_" } @{$rdepends}= ) . "\n\""); +$fh->say("SRC_TEST=3D\"do\""); + +#say pp( \%modules,);# { pretty =3D> 1 } ); +exit 1; + +sub pkg_for_module { + my ($module) =3D shift; + +} + +sub gen_dep { + state $template =3D qq{\t# %s%s\n\techo %s\n}; + my ( $module, $version ) =3D @_; + +} + diff --git a/scripts/lib/dep/handler/bashcode.pm b/scripts/lib/dep/handle= r/bashcode.pm new file mode 100644 index 0000000..eb526e7 --- /dev/null +++ b/scripts/lib/dep/handler/bashcode.pm @@ -0,0 +1,80 @@ +use strict; +use warnings; +package dep::handler::bashcode; +# FILENAME: bashcode.pm +# CREATED: 31/10/11 14:22:06 by Kent Fredric (kentnl) +# ABSTRACT: Bash code dep handler + +use Moose; + +has 'tdeps' =3D> (is =3D> 'rw',isa =3D> 'ArrayRef', lazy =3D> 1, predica= te =3D> 'has_tdeps' , default =3D> sub { [] } ); +has 'rdeps' =3D> (is =3D> 'rw', isa =3D> 'ArrayRef', lazy =3D> 1, predic= ate =3D> 'has_rdeps', default =3D> sub { [] } ); +has 'cdeps' =3D> (is =3D> 'rw', isa =3D> 'ArrayRef', lazy =3D> 1, predic= ate =3D> 'has_cdeps', default =3D> sub { [] } ); +has 'bdeps' =3D> (is =3D> 'rw', isa =3D> 'ArrayRef', lazy =3D> 1, predic= ate =3D> 'has_bdeps', default =3D> sub { [] } ); + +has dep_current =3D> ( is =3D> 'rw' , clearer =3D> 'clear_current' ); + +sub begin_dep { + my ( $self, $release, $module, $declaration ) =3D @_; + $self->dep_current( + { + for =3D> $module,=20 + wanted =3D> $declaration->[0], + for_phase =3D> $declaration->[2], + priority =3D> $declaration->[3], + } + ); +} + +sub evt_not_any { + my ( $self, $module, $declaration ) =3D @_; + my $mesg =3D "No provider: $module "; + $mesg .=3D $declaration->[0] if defined $declaration->[0]; + warn($mesg . "\n"); +} +sub evt_multi { + my ( $self, $module, $declaration ) =3D @_; + my $mesg =3D "Mutli provider: $module "; + $mesg .=3D $declaration->[0] if defined $declaration->[0]; + warn($mesg . "\n"); +} + +sub set_latest { + my ( $self, $dep, $pkg ) =3D @_; + $self->dep_current->{choose} =3D $pkg; +} + +sub perl_dep { + my ( $self, $module, $declaration , $pkg ) =3D @_ ;=20 + $self->dep_current->{choose} =3D $pkg; +} + +sub provider_group {=20 + my ( $self, $data ) =3D @_; +} + +sub done {=20 + my ( $self, $module, $declaration ) =3D @_; + my $dc =3D $self->dep_current; + # *STDOUT->say( $dc->{for_phase} . ' ' . $dc->{priority} . ' ' . $dc= ->{for} . ' ' . $dc->{wanted} . ' ' . $dc->{choose} ); + $self->clear_current; + return if ( $dc->{for_phase} eq 'develop' or $dc->{priority} ne 'requi= res' ); + =20 + my $rec =3D { dep =3D> $dc->{for} , install =3D> $dc->{choose} }; + if( $dc->{wanted} ){=20 + require Gentoo::PerlMod::Version; + $rec->{dep} .=3D ' ' . $dc->{wanted} . ' ( ' . Gentoo::PerlMod::Vers= ion::gentooize_version( $dc->{wanted} , { lax =3D> 1 }) . ' )'; + } + + push @{ $self->bdeps }, $rec if $dc->{for_phase} eq 'build'; + push @{ $self->cdeps }, $rec if $dc->{for_phase} eq 'configure'; + push @{ $self->tdeps }, $rec if $dc->{for_phase} eq 'test'; + push @{ $self->rdeps }, $rec if $dc->{for_phase} eq 'runtime'; + return; +} + +no Moose; +__PACKAGE__->meta->make_immutable; +1; + + diff --git a/scripts/lib/deptools.pm b/scripts/lib/deptools.pm index a4cdc51..a38776d 100644 --- a/scripts/lib/deptools.pm +++ b/scripts/lib/deptools.pm @@ -146,8 +146,8 @@ sub get_dep_phases { my $module =3D $dep->{module}; my $required =3D ( $dep->{relationship} eq 'requires' ); =20 - next unless $required; - next if $phase eq 'develop'; + #next unless $required; + #next if $phase eq 'develop'; =20 $phases{$phase} //=3D []; $modules{$module} //=3D []; diff --git a/scripts/pvlist.pl b/scripts/pvlist.pl new file mode 100644 index 0000000..b248fa0 --- /dev/null +++ b/scripts/pvlist.pl @@ -0,0 +1,228 @@ +#!/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 + +use MetaCPAN::API; +use CPAN::Changes; + +my $mcpan =3D MetaCPAN::API->new(); + +my (@want_dists) =3D qw( + App-cpanminus + App-perlbrew + Archive-Peek + B-Hooks-OP-Check-EntersubForCV + Business-Tax-VAT-Validation + Catalyst-Action-REST + Catalyst-Log-Log4perl + Config-GitLike + DBD-CSV + Data-Handle + DateTime-TimeZone-SystemV + DateTime-TimeZone-Tzfile + Devel-PatchPerl + Dist-Zilla-Plugin-GithubMeta + Dist-Zilla-Plugin-Test-Compile + Dist-Zilla-Plugin-Test-Perl-Critic + Dist-Zilla-Plugin-Twitter + Dist-Zilla-PluginBundle-Author-KENTNL + Filesys-Notify-Simple + Filter-Simple + FindBin-libs + Git-Wrapper + HTML-FormHandler + HTML-Packer + HTML-Template-Pro + IO-Interactive + JavaScript-Packer + KiokuDB-Backend-DBI + Lexical-Types + Lingua-EN-Inflect-Phrase + Module-Extract-Namespaces + Module-Runtime + MojoMojo + Mojolicious + MooseX-SetOnce + MooseX-Types-Structured + Net-Google-DataAPI + Net-IPv4Addr + ORLite-Migraate + Object-ID + POE-Component-SSLify + Padre-Plugin-Vi + Plack + Plack-Middleware-ReverseProxy + Pod-Elemental-Transformer-WikiDoc + Scope-Upper + Spark-Form + Task-Spark-Form + Test-LeakTrace + Test-SharedFork + Test-WWW-Mechanize-Catalyst + Web-Scraper + XML-RSS_LibXML + XML-Smart + XML-XSPF + YAML-LibYAML + autobox-Core + autovivification + perl5i + CPANPLUS + CPANPLUS-Dist-Build + Devel-PPPort + ExtUtils-MakeMaker + Unicode-Collate + Catalyst-Runtime + Moose + Class-MOP + perl + Dist-Zilla + Package-Stash + MetaCPAN-API + Class-Load + Dist-Zilla-PluginBundle-RJBS +); + +my $oldest_date =3D '2011-09-01T00:00:00.000Z'; +my $newest_date =3D '2012-01-01T00:00:00.000Z'; + +my (@styles) =3D ( + "\e[0m", "\e[1m", "\e[3m", "\e[4m", "\e[7m", + ( ( "\e[1m\e[3m", "\e[1m\e[4m", "\e[1m\e[7m", ), ( "\e[3m\e[4m", "\e[3= m\e[7m", ), "\e[4m\e[7m", ), + ( ( "\e[1m\e[3m\e[4m", "\e[1m\e[3m\e7m" ), ( "\e[3m\e[4m\e[7m", ), ), + ( "\e[1m\e[3m\e[4m\e[7m", ), +); + +my (@fgs) =3D ( "\e[30m", "\e[31m", "\e[32m", "\e[33m", "\e[34m", "\e[35= m", "\e[36m", "\e[37m" ); +my (@bgs) =3D ( "\e[49m", "\e[41m", "\e[42m", "\e[43m", "\e[44m", "\e[45= m", "\e[46m", "\e[47m", "\e[40m", ); + +my @bad =3D ( + [ undef, "\e[30m", "\e[40m" ], + [ undef, "\e[30m", "\e[49m" ], + [ undef, "\e[31m", "\e[41m" ], + [ undef, "\e[32m", "\e[42m" ], + [ undef, "\e[33m", "\e[43m" ], + [ undef, "\e[34m", "\e[44m" ], + [ undef, "\e[35m", "\e[45m" ], + [ undef, "\e[36m", "\e[46m" ], + [ undef, "\e[47m", "\e[47m" ], +); + +sub is_bad { + 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; +} + +my (@colours); + +for my $bg (@bgs) { + for my $style (@styles) { + + for my $fg (@fgs) { + next if is_bad( $style, $fg, $bg ); + push @colours, $style . $fg . $bg; + + } + } +} + +my (@author_color_map) =3D @colours; +my (@dist_color_map) =3D @colours; + +sub next_c { + my $i =3D $_[0]; + my $colour =3D shift @{$i}; + push @{$i}, $colour; + return $colour; + +} +sub next_colour { + return next_c \@colours; +} + +my %dist_colours; +my %author_colours; + +sub author_colour { + return $author_colours{ $_[0] } if exists $author_colours{ $_[0] }; + return ( $author_colours{ $_[0] } =3D next_c \@author_color_map ); +} + +sub dist_colour { + return $dist_colours{ $_[0] } if exists $dist_colours{ $_[0] }; + return ( $dist_colours{ $_[0] } =3D next_c \@dist_color_map ); +} + +sub ac { + return author_colour( $_[0] ) . $_[0] . "\e[0m"; +} + +sub dc { + return dist_colour( $_[0] ) . $_[1] . "\e[0m"; +} + +my $results =3D $mcpan->post( + 'release', + { + query =3D> { + terms =3D> { + distribution =3D> [ @want_dists, ], + minimum_match =3D> 1, + } + }, + filter =3D> { + range =3D> { + date =3D> { + from =3D> $oldest_date, + to =3D> $newest_date, + }, + }, + }, + sort =3D> [=20 + # { 'author' =3D> 'asc', }, + { 'date' =3D> 'desc' , } + ], + fields =3D> [qw( author name date distribution )], + size =3D> 1024, + } +); +use Try::Tiny; +use Data::Dump qw( pp ); +for my $result ( @{ $results->{hits}->{hits} } ) { + + my %f =3D %{ $result->{fields} }; + my ( $date, $distribution, $name, $author ) =3D @f{qw( date distributi= on name author)}; + + my $file; + try {=20 + $file =3D $mcpan->source( + author =3D> $author, + release =3D> $name, + path =3D> 'Changes', + ); + }; + my ( $changes, @releases); + if ( $file ) { + $changes =3D CPAN::Changes->load_string( $file ); + } + if ( $changes ){ + @releases =3D $changes->releases(); + } + =20 + say sprintf "%s - %s/%s\e[0m", $date, ac($author), dc($distribution,$n= ame); + if ( @releases ) { + say $releases[-1]->serialize; + } +} diff --git a/scripts/show_deptree.pl b/scripts/show_deptree.pl index ef6d8e7..0c6893c 100755 --- a/scripts/show_deptree.pl +++ b/scripts/show_deptree.pl @@ -63,17 +63,19 @@ my @squeue =3D sort { $a->[1]->[2] cmp $b->[1]->[2] or $a->[1]->[3] cmp $b->[1]->[3] = or $a->[0] cmp $b->[0] } @queue; =20 require dep::handler::stdout; +require dep::handler::bashcode; + my $handler =3D dep::handler::stdout->new(); +my $handler2 =3D dep::handler::bashcode->new(); + =20 for my $qi (@squeue) { - deptools::dispatch_dependency_handler( $release, @{$qi}, $handler ); + deptools::dispatch_dependency_handler( $release, @{$qi}, $handler2 ); } =20 #say pp( \%modules,);# { pretty =3D> 1 } ); exit 1; =20 - - sub pkg_for_module { my ($module) =3D shift; =20 @@ -85,4 +87,3 @@ sub gen_dep { =20 } =20 -