diff options
author | Kent Fredric <kentfredric@gmail.com> | 2011-10-31 09:19:03 +1300 |
---|---|---|
committer | Kent Fredric <kentfredric@gmail.com> | 2011-10-31 15:45:47 +1300 |
commit | b768a4ce805c6439d64dd05d4c4fe1fc422b6b2e (patch) | |
tree | 893000b9bcfe2d3d8277f0f30aa34ca3b8b961bf /scripts/show_deptree.pl | |
parent | rename gen_build and make it just a deptree displayer (diff) | |
download | perl-overlay-b768a4ce805c6439d64dd05d4c4fe1fc422b6b2e.tar.gz perl-overlay-b768a4ce805c6439d64dd05d4c4fe1fc422b6b2e.tar.bz2 perl-overlay-b768a4ce805c6439d64dd05d4c4fe1fc422b6b2e.zip |
Reasonably assumptive-but-works chooser of exported dep
Diffstat (limited to 'scripts/show_deptree.pl')
-rwxr-xr-x | scripts/show_deptree.pl | 348 |
1 files changed, 250 insertions, 98 deletions
diff --git a/scripts/show_deptree.pl b/scripts/show_deptree.pl index 14f221b38..8b7889665 100755 --- a/scripts/show_deptree.pl +++ b/scripts/show_deptree.pl @@ -36,7 +36,7 @@ if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; } # usage: # # gen_ebuild.pl DOY/Moose-2.0301-TRIAL -# +# my ($release) = shift(@ARGV); *STDOUT->binmode(':utf8'); @@ -46,8 +46,8 @@ my %phases; my %modules; my %providers; -my $dep_phases = get_dep_phases( $release ); -%phases = %{ $dep_phases->{phases} }; +my $dep_phases = get_dep_phases($release); +%phases = %{ $dep_phases->{phases} }; %modules = %{ $dep_phases->{modules} }; use Data::Dump qw( pp ); @@ -56,28 +56,29 @@ use Try::Tiny; use version (); sub provider_map { - my ( $module , $version ) = @_; - my @providers = metacpan->find_dist_simple( $module ); + my ( $module, $version ) = @_; + my @providers = metacpan->find_dist_simple($module); my %moduleprov; - - my %specialvs; + my %specialvs; - my $wanted_version = version->parse( $version ); + my $wanted_version = version->parse($version); - for my $provider ( @providers ) { + for my $provider (@providers) { - next if $provider->{status} eq 'backpan'; + #next if $provider->{status} eq 'backpan'; next if $provider->{maturity} eq 'developer'; -# pp $provider; - my $dist = $provider->{distribution}; + # pp $provider; + + my $dist = $provider->{distribution}; my $distv = $provider->{version} // 'undef'; my $gv = 'undef'; - if ( $distv ne 'undef' ){ + if ( $distv ne 'undef' ) { try { - $gv = gentooize_version( $distv , { lax => 1 } ); - } catch { + $gv = gentooize_version( $distv, { lax => 1 } ); + } + catch { $gv = '???'; }; } @@ -87,46 +88,41 @@ sub provider_map { $moduleprov{$dist} //= []; my @provided_matching_mods; - for my $mod ( @{ $provider->{'_source.module' } } ) { + 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; - #if( $distv ne $modv ) { - $dv = sprintf "%s ( %s ) => \"%s\"" , $distv , $gv, $modv; - #} - # specials - - $specialvs{newest} //= {}; - $specialvs{oldest} //= {}; - $specialvs{closest} //= {}; + 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{latest} = [ $dist, $dv ] if not exists $specialvs{latest}; $specialvs{newest}->{$dist} = $dv if not exists $specialvs{newest}->{$dist}; - $specialvs{oldest}->{$dist} = $dv; + $specialvs{oldest}->{$dist} = $dv; - # *STDERR->printf("\e[99m%s > %s , %s\n", $got_version, $wanted_version, $got_version > $wanted_version ); + if ( not defined $version or $got_version >= $wanted_version ) { - if ( not defined $version or $got_version >= $wanted_version ){ -# *STDERR->printf("\e[99m%s > %s , %s x2\n", $got_version, $version , 1 ); if ( not defined $specialvs{closestx}->{$dist} ) { -# *STDERR->printf("\e[99m%s > %s => set \n", $got_version, $version ); $specialvs{closestx}->{$dist} = $got_version; - $specialvs{closest}->{$dist} = $dv; - } else { - if( $specialvs{closestx}->{$dist} >= $got_version ) { -# *STDERR->printf("\e[99m%s > %s => << \n", $got_version, $version ); - + $specialvs{closest}->{$dist} = $dv; + } + else { + if ( $specialvs{closestx}->{$dist} >= $got_version ) { $specialvs{closestx}->{$dist} = $got_version; - $specialvs{closest}->{$dist} = $dv; - + $specialvs{closest}->{$dist} = $dv; } } } - # - + + # + push @provided_matching_mods, $dv if $mod->{name} eq $module; } @@ -135,108 +131,264 @@ sub provider_map { return \%moduleprov, \%specialvs; } +sub handle_declaration { + my ( $release, $module, $declaration, $output ) = @_; -for my $module ( keys %modules ) { - for my $declaration ( @{ $modules{$module} } ) { + my $depstring = $module; + if ( $declaration->[1] ne '0.0.0' ) { + $depstring .= " " . $declaration->[0] . " ( " . $declaration->[1] . " ) "; + } - 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 $want_string = "$release -> " . $declaration->[2] . " " . $declaration->[3] . " " . $depstring; + my ( $moduleprov, $specialvs ) = provider_map( $module, $declaration->[0] ); - - 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 $pc = scalar keys %$moduleprov; - my $multi = ( $pc > 1 ); - my $any = ( $pc > 0 ); + my $multi = ( $pc > 1 ); + my $any = ( $pc > 0 ); - *STDOUT->printf("\e[1;93m%s\e[0m\n", $want_string ); + $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" ); + } - if ( not $any ) { - *STDOUT->printf("%sWARNING: NO PROVIDER FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" ); - next; - } - if( $multi ){ - *STDOUT->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) { + + $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"); + } +} - my $indent = " \e[1;92m*"; - $indent = " \e[1;91m*" if $multi; - - *STDOUT->printf("%s latest: %s => %s\n", $indent, @{ $specialvs->{latest} } ); - - 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; - *STDOUT->printf(" %s%s -> %s%s\n", "\e[1;92m", $depstring, "\e[0m\e[92m" ,$prov); - *STDOUT->printf("%s newest: %s\e[0m\n", $indent, $specialvs->{newest}->{$prov}); - *STDOUT->printf("%s oldest: %s\e[0m\n", $indent, $specialvs->{oldest}->{$prov}); - my $v = $specialvs->{closest}->{$prov}; - if( not defined $v ){ $v = 'undef' } - *STDOUT->printf("%s closest: %s\e[0m\n", $indent, $v ); - for ( @slines ) { +sub virtual($) { + my $i = shift; + return 'virtual/perl-' . $i; +} - *STDOUT->printf("%s %s%s -> %s%s\n", $indent, "\e[1;94m", $prov , "\e[0m\e[94m", $_ ); - } - } - if ( $multi ){ - *STDOUT->print(" \e[1;91m-\n\n"); - } else { - *STDOUT->print(" \e[1;92m-\n\n"); - } +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 + ) + ), + ); + + if ( exists $vmap{$pkg} ) { + return $vmap{$pkg}; + } + return 'dev-perl/' . $pkg; +} -}} +for my $module ( keys %modules ) { + for my $declaration ( @{ $modules{$module} } ) { + handle_declaration( $release, $module, $declaration, *STDOUT ); + } +} 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::break = qr/,/; local $Text::Wrap::overflow = 'huge'; - local $Text::Wrap::columns = 128; + local $Text::Wrap::columns = 128; $Text::Wrap::overflow = 'huge'; my $pre = " "; - my $lines = wrap( $pre , $pre, @_ ); + my $lines = wrap( $pre, $pre, @_ ); return $lines; } + sub clines { - my ( $c, $prefix , $lines ) = @_ ; + my ( $c, $prefix, $lines ) = @_; $lines =~ s/^/$prefix>>$c/mg; $lines =~ s/$/\e[0m/mg; return $lines; } sub get_dep_phases { - my ( $release ) = shift; + 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 $phase = $dep->{phase}; + my $module = $dep->{module}; my $required = ( $dep->{relationship} eq 'requires' ); next unless $required; - next if $phase eq 'develop'; + next if $phase eq 'develop'; - $phases{$phase} //= []; + $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} ]; + 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 }; } @@ -258,7 +410,7 @@ sub get_deps { $release =~ qr{^([^/]+)/(.*$)}; ( $author, $distrelease ) = ( "$1", "$2" ); - return metacpan->find_release( $author, $distrelease ); + return metacpan->find_release( $author, $distrelease ); } sub pkg_for_module { |