#!/usr/bin/perl
# NOTE: This fixes the brain-dead ActiveState dependency problems.
#
# What's brain-dead?  They use the dist-name of modules instead of the module
# name and they do it very poorly.  Example: build a Test-Harness ppd and it
# requires File::Spec.  Try to install Test-Harness and PPM tries to pull in
# File::Spec 0.82 (with a warning) without the ability to realize it really
# wants PathTools.  QED.  (This program is a partial fix.)

our $CPAN_MIRROR = 'https://voltar.org/cpm/'; # select a mirror please

use strict;
use Compress::Zlib;
use WWW::Mechanize;
use Term::GentooFunctions qw(:all);
use Module::CoreList;
use Data::Dump qw(dump);

my $pauls_skiplist = {Config=>1}; # modules that aren't distributed (but come with perl, like Config.pm)
my $pauls_corelist = # corelist modules that shouldn't be upgraded to separate dist versions
    {constant=>1, IO=>1};

my ($mod_db, $pro_db, $f_db);

&fetch; &parse; &scan; &smarten; &write;

# write {{{
sub write {
    for my $dist_name (grep {exists $f_db->{$_}{a}} keys %$f_db) {
        my @e = @{ $f_db->{$dist_name}{e} };
           $e[1] =~ s/\.ppd$/.fix/ or die "couldn't rename output file";

        $e[0] =~ s/<DEPENDENCY[^>]+>/MYDEPS/g;
        $e[0] =~ s/MYDEPS.*MYDEPS/MYDEPS/s;
        $e[0] =~ s/^\s+MYDEPS/MYDEPS/m;

        my $deps = "";
        my %did = ();
        for (@{ $f_db->{$dist_name}{a}{d} }) {
            next if exists $did{$_->[0]};
            $deps .= "        <DEPENDENCY NAME=\"$_->[0]\" VERSION=\"$_->[1]\"\/>\n";
            $did{$_->[0]} = undef;
        }


        chomp $deps;
        $e[0] =~ s/MYDEPS/$deps/;
         
        ebegin "writing $e[1]";
        open my $out, ">$e[1]" or die "coudln't open output file: $!";
        print $out $e[0];
        close $out;
        eend 1;
    }
}
# }}}
# smarten {{{
sub smarten {
    for my $dist_name (keys %$f_db) {
        my @deps = @{ $f_db->{$dist_name}{d} };
        my @ndep = @deps;
        my $altered = 0;

        my $overall_result = 1;
        for my $dep (@deps) {
            my $mname = $dep->[0];
               $mname =~ s/-/::/g;

            my $difn = $mod_db->{$mname}{d};

            if( $pauls_skiplist->{$mname} ) {
                einfo "$dist_name depends on $dep->[0] ($mname), which is on Paul's special skiplist.";
                @ndep = grep {$_ != $dep} @ndep;
                $altered = 1;
                next;
            }

            my $adep = $dep;
            if( $difn ne "perl" and $difn ne $dep->[0] ) {
                einfo "$dist_name depends on $dep->[0], which doesn't equal $difn, renaming";
                edie "difn='' on $dist_name, $dep->[0]" unless $difn;
                $adep = [$difn, $dep->[1]];
                @ndep = map {$_ == $dep ? $adep : $_} @ndep;
                $altered = 1;
            }

            if( my $core = Module::CoreList->first_release($mname) ) {
                if( $difn eq "perl" ) {
                    einfo "$dist_name depends on $dep->[0] ($mname), which is CORE in perl $core and is only shipped there. Removing.";
                    @ndep = grep {$_ != $adep} @ndep;
                    $altered = 1;
                }

                if( $pauls_corelist->{$difn} ) {
                    einfo "$dist_name depends on $dep->[0] ($mname), which is CORE and is shipped elsewhere, but is ruled by Paul's Core List.";
                    @ndep = grep {$_ != $adep} @ndep;
                    $altered = 1;
                }
            }
        }

        if( $altered ) {
            einfo "tagging $dist_name with renamed and removed dependencies";
            $f_db->{$dist_name}{a} = {
                d => \@ndep,
            };
        }
    }
}
# }}}
# fetch {{{
sub fetch {
    my $mech;

    if( not -f "02packages.details.txt.gz" or (stat _)[9]<(time-86400) ) {
        ebegin "fetching 02packages.details.txt.gz";
        $mech ||= new WWW::Mechanize;
        $mech->get($CPAN_MIRROR . "modules/02packages.details.txt.gz", ":content_file" => "02packages.details.txt.gz");
        eend (my $s = -s "02packages.details.txt.gz");
        edie "not enough file" unless $s;
    }
}
# }}}
# parse {{{
sub parse {
    my $gz = Compress::Zlib::gzopen("02packages.details.txt.gz", "rb") or die "couldn't open 02packages.details.txt.gz file: $!";
    my $line;
    my $status_line_count = undef;
    my $my_line_count = 0;
    my %mod_db;
    my %pro_db;

    $mod_db = \%mod_db;
    $pro_db = \%pro_db;

    ebegin "parsing modules.txt.gz";
    while( my $bytes = $gz->gzreadline($line) ) {
        chomp $line;

        if( my ($package, $version, $author_plus_dir, $dist_fname) = $line =~ m/^(\S+)\s+(\S+)\s+(\w\/\w{2}\/[\w\-]+)\/(\S+)/ ) {
            $version = undef if $version =~ m/undef/;

            my $dist;
            if( $dist_fname =~ m/^(.+?)-v?[\d\.]+(?:[a-z]|E\d+)?\.(?:tar\.gz|tgz|zip|pm\.gz)$/) {
                $dist = $1;

            } else {
                # seriously not worth mentioning when this doesn't work... wow

                # edie "ERROR PARSING package=\"$package\" dist_fname=\"$dist_fname\" (line $.)";
                # zcat modules.txt.gz | grep -v tar.gz$ | grep -v tgz$ | grep -v zip$ | grep -v pm.gz
            }

            $mod_db{$package} = {
                v=>$version,
                p=>$author_plus_dir,
                f=>$dist_fname,
                d=>$dist,
            };

            if( (my @s = split m/\//, $dist) == 2 ) {
                # NOTE: not worth mentioning, ... surprisingly common
                # ewarn "$dist_fname seems to have a subdir, adding {s} and shortening {d}";
                $mod_db{$package}{s} = $s[0];
                $mod_db{$package}{d} = $s[1];
            }

            $my_line_count ++;


        } elsif ( $line =~ m/[A-Z][\w\-]+:\s*\S/ and not $line =~ m/::/ ) { 
            # prolly a status line
            $status_line_count = $1 if $line =~ /^Line-Count:\s+(\d+)/;

        } elsif ( $line =~ m/^\s*$/ ) {
            # yawn

        } else {
            edie "ERROR PARSING LINE $.: $line";
        }
    }

    ewarn "my_line_count: $my_line_count; status_line_count: $status_line_count" if $my_line_count != $status_line_count;
    eend( $my_line_count == $status_line_count );

    ebegin "building dist db";
    for my $mod (keys %mod_db) {
        if( my $dis = $mod_db{$mod}{d} ) {
            $pro_db{$dis} = [] unless exists $pro_db{$dis};

            push @{$pro_db{$dis}}, $mod;
        }
    }
    eend 1;
}
# }}}
# scan {{{
sub scan {
    local $/ = undef;
    my %f_db; $f_db = \%f_db;

    ebegin "parsing ppd files";
    for my $file (glob "*.ppd") {
        open my $fh, $file or die "error opening $file: $!";
        my $entire_file = <$fh>;
        close $fh;

        my ($dist_name) = $entire_file =~ m/SOFTPKG NAME="([^"]+)"/;
        my @dep; # depenedencies
        while( $entire_file =~ m/DEPENDENCY NAME="([^"]+)" VERSION="([^"]+)"/g ) {
            push @dep, [$1, $2];
        }

        my @dis_pro = @{$pro_db->{$dist_name}} if exists $pro_db->{$dist_name};

        ewarn "couldn't find that $dist_name provides anything..." unless @dis_pro;

        $f_db{$dist_name} = {
            p=>\@dis_pro,
            d=>\@dep,
            e=>[$entire_file, $file],
        };
    }
    eend (keys %f_db);
}
# }}}