diff options
| -rw-r--r-- | scripts/lib/dep/handler/stdout.pm | 107 | ||||
| -rw-r--r-- | scripts/lib/dep/module.pm | 34 | ||||
| -rw-r--r-- | scripts/lib/dep/provided.pm | 56 | ||||
| -rw-r--r-- | scripts/lib/dep/specialvs.pm | 63 | ||||
| -rw-r--r-- | scripts/lib/dep/wanted.pm | 40 | ||||
| -rw-r--r-- | scripts/lib/deptools.pm | 225 | ||||
| -rwxr-xr-x | 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 000000000..a652da6a8 --- /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 000000000..26f5fe67a --- /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 000000000..19c058ec7 --- /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 000000000..19b6ff5bf --- /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 000000000..f2b13c63b --- /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 000000000..a4cdc5111 --- /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 e49728dc8..ef6d8e7ab 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 -} |