* [gentoo-commits] proj/perl-overlay:master commit in: scripts/lib/dep/handler/, scripts/, scripts/lib/
@ 2011-10-31 2:48 Kent Fredric
0 siblings, 0 replies; only message in thread
From: Kent Fredric @ 2011-10-31 2:48 UTC (permalink / raw
To: gentoo-commits
commit: d38f144656ae78ed3d3d0103ad3436de14b89113
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 31 02:35:57 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=d38f1446
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 protection.
+ 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 = env::gentoo::perl_experimental->new();
+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: show_deptree.pl
+# CREATED: 25/10/11 12:15:51 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: show the metadata harvested for a given packages install tree.
+
+# 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) = shift(@ARGV);
+
+
+
+*STDOUT->binmode(':utf8');
+*STDERR->binmode(':utf8');
+
+require deptools;
+
+my ( $release_info ) = deptools::get_deps( $release );
+my $dep_phases = 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 =
+ 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();
+
+
+for my $qi (@squeue) {
+ deptools::dispatch_dependency_handler( $release, @{$qi}, $handler2 );
+}
+
+my $depends = [];
+my $rdepends = [];
+require POSIX;
+my $year = POSIX::strftime('%Y', gmtime);
+
+my $path = deptools::gentooize_pkg($release_info->{distribution} );
+require Gentoo::PerlMod::Version;
+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 ( $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('inherit perl-module');
+$fh->say('');
+
+$fh->say('DESCRIPTION="' . quotemeta( $release_info->{abstract} ) . '"');
+
+my $lics = [];
+my $licmap = {
+ perl_5 => [qw( Artistic GPL-2 )],
+};
+
+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 {
+ $fh->say('LICENSE=""');
+}
+$fh->say('SLOT="0"');
+$fh->say('KEYWORDS="~amd64 ~x86"');
+if( $handler2->has_tdeps ) {
+ $fh->say('IUSE="test"');
+} 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('}');
+ 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=\"\n" . ( join qq{\n}, map { "\t$_" } @{$depends} ) . "\n\"");
+$fh->say("RDEPENDS=\"\n" . ( join qq{\n}, map { "\t$_" } @{$rdepends} ) . "\n\"");
+$fh->say("SRC_TEST=\"do\"");
+
+#say pp( \%modules,);# { pretty => 1 } );
+exit 1;
+
+sub pkg_for_module {
+ my ($module) = shift;
+
+}
+
+sub gen_dep {
+ state $template = qq{\t# %s%s\n\techo %s\n};
+ my ( $module, $version ) = @_;
+
+}
+
diff --git a/scripts/lib/dep/handler/bashcode.pm b/scripts/lib/dep/handler/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) <kentfredric@gmail.com>
+# ABSTRACT: Bash code dep handler
+
+use Moose;
+
+has 'tdeps' => (is => 'rw',isa => 'ArrayRef', lazy => 1, predicate => 'has_tdeps' , default => sub { [] } );
+has 'rdeps' => (is => 'rw', isa => 'ArrayRef', lazy => 1, predicate => 'has_rdeps', default => sub { [] } );
+has 'cdeps' => (is => 'rw', isa => 'ArrayRef', lazy => 1, predicate => 'has_cdeps', default => sub { [] } );
+has 'bdeps' => (is => 'rw', isa => 'ArrayRef', lazy => 1, predicate => 'has_bdeps', default => sub { [] } );
+
+has dep_current => ( is => 'rw' , clearer => 'clear_current' );
+
+sub begin_dep {
+ my ( $self, $release, $module, $declaration ) = @_;
+ $self->dep_current(
+ {
+ for => $module,
+ wanted => $declaration->[0],
+ for_phase => $declaration->[2],
+ priority => $declaration->[3],
+ }
+ );
+}
+
+sub evt_not_any {
+ my ( $self, $module, $declaration ) = @_;
+ my $mesg = "No provider: $module ";
+ $mesg .= $declaration->[0] if defined $declaration->[0];
+ warn($mesg . "\n");
+}
+sub evt_multi {
+ my ( $self, $module, $declaration ) = @_;
+ my $mesg = "Mutli provider: $module ";
+ $mesg .= $declaration->[0] if defined $declaration->[0];
+ warn($mesg . "\n");
+}
+
+sub set_latest {
+ my ( $self, $dep, $pkg ) = @_;
+ $self->dep_current->{choose} = $pkg;
+}
+
+sub perl_dep {
+ my ( $self, $module, $declaration , $pkg ) = @_ ;
+ $self->dep_current->{choose} = $pkg;
+}
+
+sub provider_group {
+ my ( $self, $data ) = @_;
+}
+
+sub done {
+ my ( $self, $module, $declaration ) = @_;
+ my $dc = $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 'requires' );
+
+ my $rec = { dep => $dc->{for} , install => $dc->{choose} };
+ if( $dc->{wanted} ){
+ require Gentoo::PerlMod::Version;
+ $rec->{dep} .= ' ' . $dc->{wanted} . ' ( ' . Gentoo::PerlMod::Version::gentooize_version( $dc->{wanted} , { lax => 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 = $dep->{module};
my $required = ( $dep->{relationship} eq 'requires' );
- next unless $required;
- next if $phase eq 'develop';
+ #next unless $required;
+ #next if $phase eq 'develop';
$phases{$phase} //= [];
$modules{$module} //= [];
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
+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
+
+use MetaCPAN::API;
+use CPAN::Changes;
+
+my $mcpan = MetaCPAN::API->new();
+
+my (@want_dists) = 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 = '2011-09-01T00:00:00.000Z';
+my $newest_date = '2012-01-01T00:00:00.000Z';
+
+my (@styles) = (
+ "\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[3m\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) = ( "\e[30m", "\e[31m", "\e[32m", "\e[33m", "\e[34m", "\e[35m", "\e[36m", "\e[37m" );
+my (@bgs) = ( "\e[49m", "\e[41m", "\e[42m", "\e[43m", "\e[44m", "\e[45m", "\e[46m", "\e[47m", "\e[40m", );
+
+my @bad = (
+ [ 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 ) = @_;
+ 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;
+}
+
+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) = @colours;
+my (@dist_color_map) = @colours;
+
+sub next_c {
+ my $i = $_[0];
+ my $colour = 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] } = next_c \@author_color_map );
+}
+
+sub dist_colour {
+ return $dist_colours{ $_[0] } if exists $dist_colours{ $_[0] };
+ return ( $dist_colours{ $_[0] } = 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 = $mcpan->post(
+ 'release',
+ {
+ query => {
+ terms => {
+ distribution => [ @want_dists, ],
+ minimum_match => 1,
+ }
+ },
+ filter => {
+ range => {
+ date => {
+ from => $oldest_date,
+ to => $newest_date,
+ },
+ },
+ },
+ sort => [
+ # { 'author' => 'asc', },
+ { 'date' => 'desc' , }
+ ],
+ fields => [qw( author name date distribution )],
+ size => 1024,
+ }
+);
+use Try::Tiny;
+use Data::Dump qw( pp );
+for my $result ( @{ $results->{hits}->{hits} } ) {
+
+ my %f = %{ $result->{fields} };
+ my ( $date, $distribution, $name, $author ) = @f{qw( date distribution name author)};
+
+ my $file;
+ try {
+ $file = $mcpan->source(
+ author => $author,
+ release => $name,
+ path => 'Changes',
+ );
+ };
+ my ( $changes, @releases);
+ if ( $file ) {
+ $changes = CPAN::Changes->load_string( $file );
+ }
+ if ( $changes ){
+ @releases = $changes->releases();
+ }
+
+ say sprintf "%s - %s/%s\e[0m", $date, ac($author), dc($distribution,$name);
+ 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 =
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();
+
for my $qi (@squeue) {
- deptools::dispatch_dependency_handler( $release, @{$qi}, $handler );
+ deptools::dispatch_dependency_handler( $release, @{$qi}, $handler2 );
}
#say pp( \%modules,);# { pretty => 1 } );
exit 1;
-
-
sub pkg_for_module {
my ($module) = shift;
@@ -85,4 +87,3 @@ sub gen_dep {
}
-
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2011-10-31 2:48 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-10-31 2:48 [gentoo-commits] proj/perl-overlay:master commit in: scripts/lib/dep/handler/, scripts/, scripts/lib/ Kent Fredric
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox