* [gentoo-commits] proj/perl-overlay:master commit in: scripts/lib/dep/handler/, scripts/, scripts/lib/, scripts/lib/dep/
@ 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: ae542435b657a9af7585b4e4a977d2ba3d5797fc
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Mon Oct 31 01:19:44 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=ae542435
overhauld and refactor deptree displayer
---
scripts/lib/dep/handler/stdout.pm | 107 ++++++++++
scripts/lib/dep/module.pm | 34 ++++
scripts/lib/dep/provided.pm | 56 ++++++
scripts/lib/dep/specialvs.pm | 63 ++++++
scripts/lib/dep/wanted.pm | 40 ++++
scripts/lib/deptools.pm | 225 +++++++++++++++++++++
scripts/show_deptree.pl | 394 ++-----------------------------------
7 files changed, 542 insertions(+), 377 deletions(-)
diff --git a/scripts/lib/dep/handler/stdout.pm b/scripts/lib/dep/handler/stdout.pm
new file mode 100644
index 0000000..a652da6
--- /dev/null
+++ b/scripts/lib/dep/handler/stdout.pm
@@ -0,0 +1,107 @@
+use strict;
+use warnings;
+
+package dep::handler::stdout;
+
+# FILENAME: stdout.pm
+# CREATED: 31/10/11 13:30:29 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Dispatch dependency information to STDOUT.
+
+use Moose;
+has 'indent' => ( is => 'rw' );
+has 'tail' => ( is => 'rw' );
+__PACKAGE__->meta->make_immutable;
+
+sub begin_dep {
+ my ( $self, $release, $module, $declaration ) = @_;
+ $self->indent(" \e[1;92m*");
+ $self->tail(" \e[1;92m-\n\n");
+ my $wantstring = $self->_want_string( $release, $module, $declaration );
+ return *STDOUT->printf( "\e[1;93m%s\e[0m\n", $wantstring );
+}
+
+sub evt_not_any {
+ my ( $self, $module, $declaration ) = @_;
+ return *STDOUT->printf( "%sWARNING: NO PROVIDER FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
+}
+
+sub evt_multi {
+ my ( $self, $module, $declaration ) = @_;
+ $self->indent(" \e[1;91m*");
+ $self->tail(" \e[1;91m-\n\n");
+
+ return *STDOUT->printf( "%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
+}
+
+sub set_latest {
+ my ( $self, $dep, $pkg ) = @_;
+ return *STDOUT->printf( "%s\e[1;95m latest: %s => %s ( %s )\n", $self->indent, @{$dep}, $pkg );
+}
+
+sub _want_string {
+ my ( $self, $release, $module, $declaration ) = @_;
+ return $release . " -> " . $declaration->[2] . " " . $declaration->[3] . " " . $self->_depstring( $module, $declaration );
+}
+
+sub _depstring {
+ my ( $self, $module, $declaration ) = @_;
+
+ my $depstring = $module;
+
+ if ( $declaration->[1] ne '0.0.0' ) {
+ $depstring .= " " . $declaration->[0] . " ( " . $declaration->[1] . " ) ";
+ }
+ return $depstring;
+}
+
+sub _xwrap {
+ my $self = shift;
+ require Text::Wrap;
+ local $Text::Wrap::break = qr/,/;
+ local $Text::Wrap::overflow = 'huge';
+ local $Text::Wrap::columns = 128;
+ $Text::Wrap::overflow = 'huge';
+ my $pre = " ";
+ my $lines = Text::Wrap::wrap( $pre, $pre, @_ );
+ return $lines;
+}
+sub perl_dep {
+ my ( $self, $module, $declaration , $pkg ) = @_ ;
+ *STDOUT->printf("%s %s%s -> %s%s\n", $self->indent, "\e[1;94m", $module, "\e[0m\e[94m", $pkg );
+}
+sub provider_group {
+ my ( $self, $data ) = @_;
+
+ my $want_string = $self->_want_string( $data->{release}, $data->{module}, $data->{declaration} );
+ my $depstring = $self->_depstring( $data->{module}, $data->{declaration} );
+
+ my $prefix = $depstring . ' in ' . $data->{provider};
+
+ my $lines = $self->_xwrap( join q[, ], @{ $data->{versions} } );
+ my (@slines) = split /$/m, $lines;
+ $_ =~ s/[\r\n]*//m for @slines;
+
+ *STDOUT->printf( " %s%s -> %s%s (%s)\n", "\e[1;92m", $depstring, "\e[0m\e[92m", $data->{provider}, $data->{gentoo_pkg} );
+ *STDOUT->printf( "%s newest: %s\e[0m\n", $self->indent, $data->{newest} );
+ *STDOUT->printf( "%s oldest: %s\e[0m\n", $self->indent, $data->{oldest} );
+
+ my $v = $data->{closest};
+ if ( not $data->{has_closest} ) { $v = 'undef' }
+
+ *STDOUT->printf( "%s closest: %s\e[0m\n", $self->indent, $v );
+
+ for (@slines) {
+ *STDOUT->printf( "%s %s%s -> %s%s\n", $self->indent, "\e[1;94m", $data->{provider}, "\e[0m\e[94m", $_ );
+ }
+
+}
+
+sub done {
+ my ( $self, $module, $declaration ) = @_;
+ return *STDOUT->print( $self->tail );
+}
+
+no Moose;
+__PACKAGE__->meta->make_immutable;
+1;
+
diff --git a/scripts/lib/dep/module.pm b/scripts/lib/dep/module.pm
new file mode 100644
index 0000000..26f5fe6
--- /dev/null
+++ b/scripts/lib/dep/module.pm
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+
+package dep::module;
+
+# FILENAME: module.pm
+# CREATED: 31/10/11 13:44:00 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: A dependency record for a single module
+
+use Moose;
+
+has 'name' => ( isa => "Str", required => 1, is => 'rw', );
+has 'version_string' => ( isa => 'Maybe[Str]', is => 'rw', init_arg => 'version', predicate => 'has_version_string' );
+has 'version' => ( is => 'rw', lazy_build => 1, init_arg => undef );
+has 'parent' => ( is => 'rw', required => 1, weak_ref => 1 );
+
+sub _build_version {
+ require version;
+ my $self = shift;
+ return version->parse( $self->version_string );
+}
+
+sub debug_string {
+ my $self = shift;
+ return sprintf '%s ( %s ) => %s', $self->parent->version,
+ $self->parent->can_gv ? $self->parent->gv : 'undef',
+ $self->has_version_string ? '"' . $self->version_string . '"' : 'undef';
+}
+
+__PACKAGE__->meta->make_immutable;
+
+no Moose;
+1;
+
diff --git a/scripts/lib/dep/provided.pm b/scripts/lib/dep/provided.pm
new file mode 100644
index 0000000..19c058e
--- /dev/null
+++ b/scripts/lib/dep/provided.pm
@@ -0,0 +1,56 @@
+use strict;
+use warnings;
+
+package dep::provided;
+
+# FILENAME: provided.pm
+# CREATED: 31/10/11 13:42:24 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: repesents a provided package
+
+use Moose;
+require dep::module;
+
+has 'distribution' => ( isa => 'Defined', is => 'rw', required => 1 );
+has 'version' => ( is => 'rw', required => 1 );
+has 'maturity' => ( is => 'rw', required => 1 );
+has 'status' => ( is => 'rw', required => 1 );
+has 'gv' => ( is => 'rw', lazy_build => 1 );
+has '_modules' => ( isa => 'ArrayRef', required => 1, init_arg => '_source.module', is => 'rw', );
+has 'modules' => ( isa => 'ArrayRef[dep::module]', lazy_build => 1, is => 'rw' );
+
+__PACKAGE__->meta->make_immutable;
+
+sub _build_modules {
+ my $self = shift;
+ return [ map { dep::module->new( %{$_}, parent => $self ) } @{ $self->_modules } ];
+}
+
+sub _build_gv {
+ require Gentoo::PerlMod::Version;
+ use Try::Tiny;
+ my ($self) = @_;
+ my $v;
+ try {
+ $v = Gentoo::PerlMod::Version::gentooize_version( $self->version, { lax => 1 } );
+ }
+ catch {
+ $v = undef;
+ };
+ return $v;
+}
+
+sub can_gv {
+ return defined $_[0]->gv;
+}
+
+sub is_dev {
+ return $_[0]->maturity eq 'development';
+}
+
+sub is_backpan {
+ return $_[0]->status eq 'backpan';
+}
+
+no Moose;
+1;
+
diff --git a/scripts/lib/dep/specialvs.pm b/scripts/lib/dep/specialvs.pm
new file mode 100644
index 0000000..19b6ff5
--- /dev/null
+++ b/scripts/lib/dep/specialvs.pm
@@ -0,0 +1,63 @@
+use strict;
+use warnings;
+
+package dep::specialvs;
+
+# FILENAME: specialvs.pm
+# CREATED: 31/10/11 13:38:14 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Collect special version information about a dependency
+
+use Moose;
+
+has newest => ( isa => 'HashRef', default => sub { {} }, is => 'rw' );
+has newestx => ( isa => 'HashRef', default => sub { {} }, is => 'rw' );
+
+has oldest => ( isa => 'HashRef', default => sub { {} }, is => 'rw' );
+has oldestx => ( isa => 'HashRef', default => sub { {} }, is => 'rw' );
+
+has closest => ( isa => 'HashRef', default => sub { {} }, is => 'rw' );
+has closestx => ( isa => 'HashRef', default => sub { {} }, is => 'rw' );
+
+has latest => ( is => 'rw', predicate => 'has_latest' );
+has latestx => ( is => 'rw', predicate => 'has_latestx' );
+
+sub set_latest_mod {
+ my ( $self, $provider, $mod ) = @_;
+ return if $self->has_latest;
+ $self->latest( [ $provider, $mod->debug_string ] );
+ $self->latestx( [ $provider, $mod ] );
+}
+
+sub set_newest_mod {
+ my ( $self, $key, $mod ) = @_;
+ return if exists $self->newest->{$key};
+ $self->newest->{$key} = $mod->debug_string;
+ $self->newestx->{$key} = $mod;
+}
+
+sub set_oldest_mod {
+ my ( $self, $key, $mod ) = @_;
+
+ $self->oldest->{$key} = $mod->debug_string;
+ $self->oldestx->{$key} = $mod;
+}
+
+sub set_closest_mod {
+ my ( $self, $key, $mod ) = @_;
+ if ( not defined $self->closestx->{$key} ) {
+ $self->closestx->{$key} = $mod;
+ $self->closest->{$key} = $mod->debug_string;
+ return;
+ }
+ if ( $self->closestx->{$key}->version >= $mod->version ) {
+ $self->closestx->{$key} = $mod;
+ $self->closest->{$key} = $mod->debug_string;
+ }
+ return;
+}
+
+__PACKAGE__->meta->make_immutable;
+
+no Moose;
+1;
+
diff --git a/scripts/lib/dep/wanted.pm b/scripts/lib/dep/wanted.pm
new file mode 100644
index 0000000..f2b13c6
--- /dev/null
+++ b/scripts/lib/dep/wanted.pm
@@ -0,0 +1,40 @@
+use strict;
+use warnings;
+
+package dep::wanted;
+
+# FILENAME: wanted.pm
+# CREATED: 31/10/11 13:45:03 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: a record for something wanted to be a dep
+
+use Moose;
+has [qw( module version_string )] => ( isa => 'Str', is => 'rw', 'required' => 1 );
+has [qw( gentoo_version version )] => ( is => 'rw', lazy_build => 1 );
+
+sub _build_gentoo_version {
+ my $self = shift;
+ require Gentoo::PerlMod::Version;
+ return Gentoo::PerlMod::Version::gentooize_version( $self->version_string );
+}
+
+sub _build_version {
+ my $self = shift;
+ require version;
+ return version->parse( $self->version_string );
+}
+
+sub no_version_dep {
+ return not defined $_[0]->version_string;
+}
+
+sub provides {
+ require metacpan;
+ my $self = shift;
+ require dep::provided;
+ return map { dep::provided->new( %{$_} ) } metacpan->find_dist_simple( $self->module );
+}
+
+no Moose;
+__PACKAGE__->meta->make_immutable;
+1;
+
diff --git a/scripts/lib/deptools.pm b/scripts/lib/deptools.pm
new file mode 100644
index 0000000..a4cdc51
--- /dev/null
+++ b/scripts/lib/deptools.pm
@@ -0,0 +1,225 @@
+use 5.010000;
+use strict;
+use warnings;
+
+package deptools;
+
+# FILENAME: deptools.pm
+# CREATED: 31/10/11 09:30:24 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Miscelanous bits for computing deps for Perl modules
+
+sub virtual($) { return 'virtual/perl-' . shift }
+sub lang($) { return 'dev-lang/' . shift }
+
+sub _vmap_langs {
+ return ( 'perl', 'perl_debug', );
+}
+
+sub _vmap_perl_native {
+ return (
+ 'Archive-Tar', 'Attribute-Handlers', 'AutoLoader', 'CGI',
+ 'Class-ISA', 'Compress-Raw-Bzip2', 'Compress-Raw-Zlib', 'CPAN-Meta',
+ 'CPAN-Meta-YAML', 'Data-Dumper', 'DB_File', 'Digest-MD5',
+ 'Digest-SHA', 'Encode', 'ExtUtils-CBuilder', 'ExtUtils-Command',
+ 'ExtUtils-Install', 'ExtUtils-MakeMaker', 'ExtUtils-Manifest', 'ExtUtils-ParseXS',
+ 'File-Path', 'File-Temp', 'Filter', 'Getopt-Long',
+ 'i18n-langtags', 'IO', 'IO-Compress', 'IO-Zlib',
+ 'IPC-Cmd', 'JSON-PP', 'libnet', 'Locale-MakeText-Simple',
+ 'Math-BigInt', 'Math-BigInt-FastCalc', 'Memoize', 'MIME-Base64',
+ 'Module-Build', 'Module-CoreList', 'Module-Load', 'Module-Load-Conditional',
+ 'Module-Loaded', 'Module-Metadata', 'Module-Pluggable', 'Package-Constants',
+ 'Params-Check', 'parent', 'Parse-CPAN-Meta', 'Perl-OSType',
+ 'Pod-Escapes', 'podlators', 'Pod-Simple', 'Safe',
+ 'Scalar-List-Utils', 'Storable', 'Switch', 'Sys-Syslog',
+ 'Term-ANSIColor', 'Test', 'Test-Harness', 'Test-Simple',
+ 'Text-Balanced', 'Text-Tabs+Wrap', 'Thread-Queue', 'threads',
+ 'Thread-Semaphore', 'threads-shared', 'Time-HiRes', 'Time-Local',
+ 'Time-Piece', 'version', 'Version-Requirements', 'XSLoader',
+ );
+}
+
+sub _vmap_perl_strange {
+ return (
+ 'Digest' => virtual 'digest-base',
+ 'PathTools' => virtual 'File-Spec',
+ 'Locale-MakeText' => virtual 'locale-maketext',
+ 'Net-Ping' => virtual 'net-ping',
+ 'Pod-Parser' => virtual 'PodParser',
+ );
+}
+
+sub _vmap_overlay_native {
+ return (
+ 'Archive-Extract', 'B-Debug', 'B-Lint', 'constant', 'CPAN',
+ 'CPANPLUS', 'CPANPLUS-Dist-Build', 'Devel-DProf', 'Devel-PPPort', 'Devel-SelfStubber',
+ 'Dumpvalue', 'ExtUtils-Constant', 'ExtUtils-MakeMaker', 'File-Fetch', 'Filter-Simple',
+ 'HTTP-Tiny', 'i18n-langtags', 'if', 'IPC-SysV', 'Log-Message',
+ 'Log-Message-Simple', 'Math-Complex', 'Module-CoreList', 'NEXT', 'Object-Accessor',
+ 'Pod-LaTeX', 'Pod-Perldoc', 'Pod-Plainer', 'SelfLoader', 'Term-UI',
+ 'Unicode-Collate', 'Unicode-Normalize',
+ );
+}
+
+sub _vmap {
+ return (
+ ( map { $_, lang $_ } _vmap_langs() ),
+ ( map { $_, virtual $_ } _vmap_perl_native(), _vmap_overlay_native() ),
+ _vmap_perl_strange(),
+ );
+}
+
+sub gentooize_pkg {
+ my ( $pkg, $version ) = @_;
+ state $vmap = { _vmap() };
+ my $outpkg = 'dev-perl/' . $pkg;
+ if ( exists $vmap->{$pkg} ) {
+ $outpkg = $vmap->{$pkg};
+ }
+ if ( not $version or $version eq '0.0.0' ) {
+ return $outpkg;
+ }
+ return '\\>=' . $outpkg . '-' . $version;
+}
+
+sub provider_map {
+
+ require dep::wanted;
+ my $wanted = dep::wanted->new(
+ module => $_[0],
+ version_string => $_[1],
+ );
+ my @providers = $wanted->provides;
+
+ my %moduleprov;
+
+ require dep::specialvs;
+ my $specialvs = dep::specialvs->new();
+
+
+ for my $provider (@providers) {
+
+ next if $provider->is_backpan;
+ next if $provider->is_dev;
+
+ next unless $provider->can_gv;
+
+ my @provided_matching_mods;
+ for my $mod ( @{ $provider->modules } ) {
+
+ next unless $mod->name eq $wanted->module;
+
+ # specials
+ $specialvs->set_latest_mod( $provider->distribution , $mod );
+ $specialvs->set_newest_mod( $provider->distribution, $mod );
+ $specialvs->set_oldest_mod( $provider->distribution, $mod );
+
+ if ( $wanted->no_version_dep or $mod->version >= $wanted->version ) {
+ $specialvs->set_closest_mod( $provider->distribution, $mod );
+ }
+
+ push @provided_matching_mods, $mod->debug_string
+ if $mod->name eq $wanted->module;
+ }
+ $moduleprov{ $provider->distribution } //= [];
+ push @{ $moduleprov{ $provider->distribution } }, @provided_matching_mods;
+ }
+ return \%moduleprov, $specialvs;
+}
+sub get_deps {
+ my ($release) = shift;
+
+ my ( $author, $distrelease );
+
+ $release =~ qr{^([^/]+)/(.*$)};
+ ( $author, $distrelease ) = ( "$1", "$2" );
+ require metacpan;
+ return metacpan->find_release( $author, $distrelease );
+}
+
+sub get_dep_phases {
+ my ($release) = shift;
+ my %phases;
+ my %modules;
+ my ( $result, ) = get_deps($release);
+ for my $dep ( @{ $result->{dependency} } ) {
+ my $phase = $dep->{phase};
+ my $module = $dep->{module};
+ my $required = ( $dep->{relationship} eq 'requires' );
+
+ next unless $required;
+ next if $phase eq 'develop';
+
+ $phases{$phase} //= [];
+ $modules{$module} //= [];
+
+ require Gentoo::PerlMod::Version;
+ my $v = Gentoo::PerlMod::Version::gentooize_version( $dep->{version}, { lax => 1 } );
+
+ push @{ $phases{$phase} }, [ $dep->{module}, $dep->{version}, $v, $dep->{relationship} ];
+ push @{ $modules{$module} }, [ $dep->{version}, $v, $dep->{phase}, $dep->{relationship} ];
+ }
+ return { phases => \%phases, modules => \%modules };
+}
+
+sub dispatch_dependency_handler {
+
+ my ( $release, $module, $declaration, $feeder ) = @_;
+
+ my ( $moduleprov, $specialvs ) = provider_map( $module, $declaration->[0] );
+
+ my $pc = scalar keys %$moduleprov;
+
+ my $multi = ( $pc > 1 );
+ my $any = ( $pc > 0 );
+
+ $feeder->begin_dep( $release, $module, $declaration );
+
+
+ if( $module eq 'perl' ){
+ $feeder->perl_dep( $module, $declaration , gentooize_pkg( 'perl', $declaration->[1] ));
+ return $feeder->done;
+ }
+
+ if ( not $any ) { $feeder->evt_not_any( $module, $declaration ); }
+
+ if ($multi) { $feeder->evt_multi( $module, $declaration ); }
+
+ #pp {
+ # moduleprov => $moduleprov,
+ # specialvs => $specialvs,
+ # release => $release,
+ # module => $module,
+ # declaration => $declaration,
+ # latest => $specialvs->latest,
+ #};
+ if( $specialvs->has_latest ) {
+ $feeder->set_latest( $specialvs->latest,
+ gentooize_pkg( $specialvs->latest->[0],
+ $declaration->[1] )
+ );
+ }
+
+ for my $prov ( keys %{$moduleprov} ) {
+
+ my $data = {
+ release => $release,
+ versions => $moduleprov->{$prov},
+ provider => $prov,
+ gentoo_pkg => gentooize_pkg($prov),
+ newest => $specialvs->newest->{$prov},
+ newestx => $specialvs->newestx->{$prov},
+ oldest => $specialvs->oldest->{$prov},
+ oldestx => $specialvs->oldestx->{$prov},
+ has_closest => exists $specialvs->closest->{$prov},
+ closest => $specialvs->closest->{$prov},
+ closestx => $specialvs->closestx->{$prov},
+ declaration => $declaration,
+ module => $module,
+ };
+ $feeder->provider_group($data);
+ }
+ $feeder->done( $module, $declaration );
+
+}
+1;
+
diff --git a/scripts/show_deptree.pl b/scripts/show_deptree.pl
index e49728d..ef6d8e7 100755
--- a/scripts/show_deptree.pl
+++ b/scripts/show_deptree.pl
@@ -9,10 +9,7 @@ use warnings;
use FindBin;
use lib "$FindBin::Bin/lib";
use env::gentoo::perl_experimental;
-use metacpan qw( mcpan );
use utf8;
-use Gentoo::PerlMod::Version qw( gentooize_version );
-use Text::Wrap;
my $flags;
my $singleflags;
@@ -37,389 +34,45 @@ if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
#
# gen_ebuild.pl DOY/Moose-2.0301-TRIAL
#
-my ($release) = shift(@ARGV);
-
-*STDOUT->binmode(':utf8');
-*STDERR->binmode(':utf8');
-
-my %phases;
-my %modules;
-my %providers;
-
-my $dep_phases = get_dep_phases($release);
-%phases = %{ $dep_phases->{phases} };
-%modules = %{ $dep_phases->{modules} };
-
-use Data::Dump qw( pp );
-use JSON qw( to_json encode_json );
-use Try::Tiny;
-use version ();
-
-sub provider_map {
- my ( $module, $version ) = @_;
- my @providers = metacpan->find_dist_simple($module);
- my %moduleprov;
-
- my %specialvs;
-
- my $wanted_version = version->parse($version);
-
- for my $provider (@providers) {
-
- #next if $provider->{status} eq 'backpan';
- next if $provider->{maturity} eq 'developer';
-
- # pp $provider;
-
- my $dist = $provider->{distribution};
- my $distv = $provider->{version} // 'undef';
- my $gv = 'undef';
- if ( $distv ne 'undef' ) {
- try {
- $gv = gentooize_version( $distv, { lax => 1 } );
- }
- catch {
- $gv = '???';
- };
- }
-
- #next if $gv eq '???';
-
- $moduleprov{$dist} //= [];
-
- my @provided_matching_mods;
- for my $mod ( @{ $provider->{'_source.module'} } ) {
- next unless $mod->{name} eq $module;
- my $modv = $mod->{version} // 'undef';
-
- my $got_version = version->parse( $mod->{version} );
-
- my $dv = $distv;
- $dv = sprintf "%s ( %s ) => \"%s\"", $distv, $gv, $modv;
-
- # specials
-
- $specialvs{newest} //= {};
- $specialvs{oldest} //= {};
- $specialvs{closest} //= {};
- $specialvs{closestx} //= {};
- $specialvs{latest} = [ $dist, $dv ] if not exists $specialvs{latest};
- $specialvs{newest}->{$dist} = $dv if not exists $specialvs{newest}->{$dist};
- $specialvs{oldest}->{$dist} = $dv;
-
- if ( not defined $version or $got_version >= $wanted_version ) {
-
- if ( not defined $specialvs{closestx}->{$dist} ) {
- $specialvs{closestx}->{$dist} = $got_version;
- $specialvs{closest}->{$dist} = $dv;
- }
- else {
- if ( $specialvs{closestx}->{$dist} >= $got_version ) {
- $specialvs{closestx}->{$dist} = $got_version;
- $specialvs{closest}->{$dist} = $dv;
- }
- }
- }
-
- #
-
- push @provided_matching_mods, $dv
- if $mod->{name} eq $module;
- }
- push @{ $moduleprov{$dist} }, @provided_matching_mods;
- }
- return \%moduleprov, \%specialvs;
-}
-
-sub handle_declaration {
- my ( $release, $module, $declaration, $output ) = @_;
-
- my $depstring = $module;
- if ( $declaration->[1] ne '0.0.0' ) {
- $depstring .= " " . $declaration->[0] . " ( " . $declaration->[1] . " ) ";
- }
-
- my $want_string = "$release -> " . $declaration->[2] . " " . $declaration->[3] . " " . $depstring;
-
- my ( $moduleprov, $specialvs ) = provider_map( $module, $declaration->[0] );
-
- my $to_pkg = sub {
- my $pkg = shift;
- my $xpkg = gentooize_pkg($pkg);
- if ( $declaration->[1] eq '0.0.0' ) {
- return $xpkg;
- }
- return '\\>=' . $xpkg . '-' . $declaration->[1];
- };
-
- my $pc = scalar keys %$moduleprov;
-
- my $multi = ( $pc > 1 );
- my $any = ( $pc > 0 );
-
- $output->printf( "\e[1;93m%s\e[0m\n", $want_string );
-
- if ( not $any ) {
- return $output->printf( "%sWARNING: NO PROVIDER FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
- }
- if ($multi) {
- $output->printf( "%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
- }
-
- my $indent = " \e[1;92m*";
- $indent = " \e[1;91m*" if $multi;
-
- $output->printf(
- "%s\e[1;95m latest: %s => %s ( %s )\n",
- $indent,
- @{ $specialvs->{latest} },
- $to_pkg->( $specialvs->{latest}->[0] )
- );
-
- for my $prov ( keys %{$moduleprov} ) {
- my $prefix = $depstring . ' in ' . $prov;
- my $lines = xwrap( join q[, ], @{ $moduleprov->{$prov} } );
- my (@slines) = split /$/m, $lines;
- $_ =~ s/[\r\n]*//m for @slines;
- $output->printf( " %s%s -> %s%s (%s)\n", "\e[1;92m", $depstring, "\e[0m\e[92m", $prov, gentooize_pkg($prov) );
- $output->printf( "%s newest: %s\e[0m\n", $indent, $specialvs->{newest}->{$prov} );
- $output->printf( "%s oldest: %s\e[0m\n", $indent, $specialvs->{oldest}->{$prov} );
- my $v = $specialvs->{closest}->{$prov};
- if ( not defined $v ) { $v = 'undef' }
- $output->printf( "%s closest: %s\e[0m\n", $indent, $v );
-
- for (@slines) {
+sub help {
+ return <<'EOF';
+gen_ebuild.pl
- $output->printf( "%s %s%s -> %s%s\n", $indent, "\e[1;94m", $prov, "\e[0m\e[94m", $_ );
- }
- }
- if ($multi) {
- $output->print(" \e[1;91m-\n\n");
- }
- else {
- $output->print(" \e[1;92m-\n\n");
- }
+USAGE:
-}
+ show_deptree.pl DOY/Moose-2.0301-TRIAL
-sub virtual($) {
- my $i = shift;
- return 'virtual/perl-' . $i;
+EOF
}
+my ($release) = shift(@ARGV);
-sub gentooize_pkg {
- my $pkg = shift;
- my %vmap = (
- 'perl' => 'dev-lang/perl',
- 'perl_debug' => 'dev-lang/perl_debug', # doesn't actually exist
- (
- map { $_, virtual $_ }
- qw(
- Archive-Tar
- Attribute-Handlers
- AutoLoader
- CGI
- Class-ISA
- Compress-Raw-Bzip2
- Compress-Raw-Zlib
- CPAN-Meta
- CPAN-Meta-YAML
- Data-Dumper
- DB_File
- Digest-MD5
- Digest-SHA
- Encode
- ExtUtils-CBuilder
- ExtUtils-Command
- ExtUtils-Install
- ExtUtils-MakeMaker
- ExtUtils-Manifest
- ExtUtils-ParseXS
- File-Path
- File-Temp
- Filter
- Getopt-Long
- i18n-langtags
- IO
- IO-Compress
- IO-Zlib
- IPC-Cmd
- JSON-PP
- libnet
- Locale-MakeText-Simple
- Math-BigInt
- Math-BigInt-FastCalc
- Memoize
- MIME-Base64
- Module-Build
- Module-CoreList
- Module-Load
- Module-Load-Conditional
- Module-Loaded
- Module-Metadata
- Module-Pluggable
- Package-Constants
- Params-Check
- parent
- Parse-CPAN-Meta
- Perl-OSType
- Pod-Escapes
- podlators
- Pod-Simple
- Safe
- Scalar-List-Utils
- Storable
- Switch
- Sys-Syslog
- Term-ANSIColor
- Test
- Test-Harness
- Test-Simple
- Text-Balanced
- Text-Tabs+Wrap
- Thread-Queue
- threads
- Thread-Semaphore
- threads-shared
- Time-HiRes
- Time-Local
- Time-Piece
- version
- Version-Requirements
- XSLoader
- )
- ),
- 'Digest' => virtual 'digest-base',
- 'PathTools' => virtual 'File-Spec',
- 'Locale-MakeText' => virtual 'locale-maketext',
- 'Net-Ping' => virtual 'net-ping',
- 'Pod-Parser' => virtual 'PodParser',
- ## Overlay
- (
- map { $_, virtual $_ }
- qw(
- Archive-Extract
- B-Debug
- B-Lint
- constant
- CPAN
- CPANPLUS
- CPANPLUS-Dist-Build
- Devel-DProf
- Devel-PPPort
- Devel-SelfStubber
- Dumpvalue
- ExtUtils-Constant
- ExtUtils-MakeMaker
- File-Fetch
- Filter-Simple
- HTTP-Tiny
- i18n-langtags
- if
- IPC-SysV
- Log-Message
- Log-Message-Simple
- Math-Complex
- Module-CoreList
- NEXT
- Object-Accessor
- Pod-LaTeX
- Pod-Perldoc
- Pod-Plainer
- SelfLoader
- Term-UI
- Unicode-Collate
- Unicode-Normalize
- )
- ),
- );
+*STDOUT->binmode(':utf8');
+*STDERR->binmode(':utf8');
- if ( exists $vmap{$pkg} ) {
- return $vmap{$pkg};
- }
- return 'dev-perl/' . $pkg;
-}
+require deptools;
+my $dep_phases = deptools::get_dep_phases($release);
my @queue;
-for my $module ( keys %modules ) {
- for my $declaration ( @{ $modules{$module} } ) {
+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;
+my $handler = dep::handler::stdout->new();
+
for my $qi (@squeue) {
- handle_declaration( $release, @{$qi}, *STDOUT );
+ deptools::dispatch_dependency_handler( $release, @{$qi}, $handler );
}
-use Data::Dump qw( pp );
-use JSON qw( to_json encode_json );
-
#say pp( \%modules,);# { pretty => 1 } );
exit 1;
-sub xwrap {
- local $Text::Wrap::break = qr/,/;
- local $Text::Wrap::overflow = 'huge';
- local $Text::Wrap::columns = 128;
- $Text::Wrap::overflow = 'huge';
- my $pre = " ";
- my $lines = wrap( $pre, $pre, @_ );
- return $lines;
-}
-
-sub clines {
- my ( $c, $prefix, $lines ) = @_;
- $lines =~ s/^/$prefix>>$c/mg;
- $lines =~ s/$/\e[0m/mg;
- return $lines;
-}
-
-sub get_dep_phases {
- my ($release) = shift;
- my %phases;
- my %modules;
- my ( $result, ) = get_deps($release);
- for my $dep ( @{ $result->{dependency} } ) {
- my $phase = $dep->{phase};
- my $module = $dep->{module};
- my $required = ( $dep->{relationship} eq 'requires' );
-
- next unless $required;
- next if $phase eq 'develop';
- $phases{$phase} //= [];
- $modules{$module} //= [];
-
- my $v = gentooize_version( $dep->{version}, { lax => 1 } );
-
- push @{ $phases{$phase} }, [ $dep->{module}, $dep->{version}, $v, $dep->{relationship} ];
- push @{ $modules{$module} }, [ $dep->{version}, $v, $dep->{phase}, $dep->{relationship} ];
- }
- return { phases => \%phases, modules => \%modules };
-}
-
-sub to_curl {
- my ( $target, $query ) = @_;
-
- my $query_json = to_json( $query, { pretty => 1 } );
- print 'curl -XPOST api.metacpan.org/v0/' . $target . '/_search -d \'';
- print $query_json;
- print qq{'\n};
-
-}
-
-sub get_deps {
- my ($release) = shift;
-
- my ( $author, $distrelease );
-
- $release =~ qr{^([^/]+)/(.*$)};
- ( $author, $distrelease ) = ( "$1", "$2" );
- return metacpan->find_release( $author, $distrelease );
-}
sub pkg_for_module {
my ($module) = shift;
@@ -432,17 +85,4 @@ sub gen_dep {
}
-sub help {
- return <<'EOF';
-gen_ebuild.pl
-
-USAGE:
- gen_ebuild.pl DOY/Moose-2.0301-TRIAL
-
- edit ./Moose-2.30.100_rc.ebuild
-
- done!
-
-EOF
-}
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2011-10-31 2:49 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/, scripts/lib/dep/ Kent Fredric
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox