[gentoo-commits] proj/perl-overlay:master commit in: scripts/lib/dep/handler/, scripts/, scripts/lib/

[Kent Fredric]

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@×××××.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@×××××.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@×××××.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 {
 
 }
 
-