# see http://teahut.sakura.ne.jp/b/2008-03-31-1.html (written in Japanese)

package Cpan2Pkg::Base;

use strict;
use warnings;

use File::Path;

sub new {
    my($class, $args) = @_;
    mkpath '/tmp/cpan2pkg';
    bless {
        logfile => '/tmp/cpan2pkg/log',
        debug => $args->{debug},
    }, $class;
}

sub error {
    my($self, $message) = @_;
    $self->log($message, 'error', caller);
}

sub info {
    my($self, $message) = @_;
    $self->log($message, 'info', caller);
}

sub debug {
    my($self, $message) = @_;
    return unless $self->{debug};
    $self->log($message, 'debug', caller);
}

sub log {
    my($self, $message, $level, $package, $file, $line) = @_;
    open my $fh, '>>', $self->{logfile} or return;
    print $fh "[$level] $package->$message at $file:$line\n";
    0;
}

package Cpan2Pkg::Versions;

use strict;
use warnings;

use English qw(-no_match_vars);

sub autobundle {
    my($class) = @_;
    my %versions;

    my $is_list = 0;
    my $list;
    if ($ENV{BUNDLE_SNAPSHOT}) {
        local $INPUT_RECORD_SEPARATOR = undef;
        open my $fh, '<', $ENV{BUNDLE_SNAPSHOT} or return;
        $list = <$fh>
    }
    else {
        $list = qx{sudo cpan -a}; # XXX remove sudo if not needed
    }

    for my $l (split /[\r\n]+/, $list) {
        if ($l =~ /^Package namespace/) {
            $is_list = 1;
        }
        elsif ($is_list) {
            my($module, $version) = $l =~ m{([:\w]+)\s*(\d[.\w]+)};
            next unless $module;
            $versions{$module} = $version eq 'undef' ? undef : $version;
        }
    }

    \%versions;
}

package Cpan2Pkg::ModuleList;

use strict;
use warnings;

use English qw(-no_match_vars);
use File::Path;
use LWP::UserAgent;
use Module::CoreList;
use Module::Depends;

use base qw(Cpan2Pkg::Base);

sub new {
    my($class, @args) = @_;
    my $self = $class->SUPER::new(@args);
    mkpath '/tmp/cpan2pkg/tgz';
    mkpath '/tmp/cpan2pkg/src';
    mkpath '/tmp/cpan2pkg/deb';
    $self->{ua} = LWP::UserAgent->new;
    $self->{ua}->env_proxy;
    $self;
}

sub list {
    my($self) = @_;
    keys %{ $self->{modules} };
}

sub add {
    my($self, $module, $version) = @_;
    return $self->info("add($module) 1") if $self->is_added($module) || $self->is_core($module);
    $module = $self->resolve_module($module) or return;
    return $self->info("add($module) 1") if $self->is_added($module) || $self->is_core($module);
    (my $tgz, my $src, $version) = $self->download_tgz($module, $version) or return;
    my @depends = $self->get_depends($src);
    $self->{modules}{$module} = {
        module => $module,
        version => $version,
        tgz => $tgz,
        src => $src,
        depends => \@depends,
    };
}

sub is_added {
    my($self, $module) = @_;
    grep { $module eq $_ } keys %{ $self->{modules} }
}

sub is_core {
    my($self, $module) = @_;
    return 1 if $module eq 'perl';
    my $version = Module::CoreList->first_release($_);
    return 1 if $version && $version <= $PERL_VERSION;
    return;
}

sub resolve_module {
    my($self, $module) = @_;
    return $self->{resolved}{$module} if $self->{resolved}{$module};
    my $res = $self->get_or_retry("http://search.cpan.org/search?query=$module&mode=module");
    return $self->error("resolve_module($module) 1") unless $res->is_success;
    my ($module2) = $res->content =~ m{<a href="/~[^/]+/([-\w]+?)-\d[.\w]+/">};
    return $self->error("resolve_module($module) 2") unless $module2;
    $module2 =~ s/-/::/g unless $module2 eq 'libwww-perl';
    $self->{resolved}{$module} = $module2;
}

sub get_depends {
    my($self, $src) = @_;
    my $deps = Module::Depends->new->dist_dir($src)->find_modules;
    return grep { !$self->is_added($_) }
            map { $self->resolve_module($_) }
           grep { !$self->is_core($_) }
            uniq(keys %{ $deps->requires || {} }, keys %{ $deps->build_requires || {} });
}

sub download_tgz {
    my($self, $module, $version) = @_;
    (my $url, $version) = $self->get_tgz_url($module, $version);
    return $self->error("download_tgz($module) 1") unless $url;
    my $res = $self->get_or_retry($url);
    return $self->error("download_tgz($module) 2") unless $res->is_success;
    my($tgz) = $url =~ m{([^/]+gz)$};
    return $self->error("download_tgz($module) 3") unless $tgz;
    write_file("/tmp/cpan2pkg/tgz/$tgz", $res->content);
    system "tar zxf /tmp/cpan2pkg/tgz/$tgz -C /tmp/cpan2pkg/src"
        and return $self->error("download_tgz($module) 4");
    my ($dir) = $tgz =~ m{([^/]+)\.(?:tar\.gz|tgz)$};
    return $self->error("download_tgz($module) 5") unless $dir;
    ("/tmp/cpan2pkg/tgz/$tgz", "/tmp/cpan2pkg/src/$dir", $version);
}

sub get_tgz_url {
    my($self, $module, $version) = @_;

    my $path = "/dist/$module";
    $path =~ s/::/-/g;
    my $res = $self->get_or_retry("http://search.cpan.org$path");
    return $self->error("get_tgz_url($module) 1") unless $res->is_success;

    if (defined $version) {
        my @res = $self->extract_tgz_url($res, $module, $version);
        return @res if @res;
        if (my $path = [ $res->content =~ m{<option value="(/~.+?-$version/)">} ]->[0]) {
            $res = $self->{ua}->get_or_retry("http://search.cpan.org$path");
            return $self->error("get_tgz_url($module) 2") unless $res->is_success;
            return $self->extract_tgz_url($res, $module, $version);
        }
        else {
            return $self->extract_tgz_url($res, $module);
        }
    }
    else {
        return $self->extract_tgz_url($res, $module);
    }
}

sub get_or_retry {
    my($self, $url) = @_;
    my $res = $self->{ua}->get($url);
    $res->is_success ? $res : $self->{ua}->get($url);
}

sub extract_tgz_url {
    my($self, $res, $module, $version) = @_;
    my $ver_regex = defined $version ? quotemeta($version) : '\d[.\w]+';
    (my $path, $version)
        = $res->content =~ m{<a href="(/CPAN/.+?-($ver_regex)\.(?:tar\.gz|tgz))">Download</a>};
    return $self->error("extract_tgz_url($module)") unless $path;
    ("http://search.cpan.org$path", $version);
}

sub write_file {
    my($file, $data) = @_;
    open my $fh, '>', $file or return;
    binmode $fh;
    print $fh $data;
}

sub uniq {
    my(@modules) = @_;
    my %hash;
    $hash{$_} = 1 for @modules;
    keys %hash;
}

package Cpan2Pkg::DebMaker;

use strict;
use warnings;
use Carp;

use base qw(Cpan2Pkg::Base);

sub new {
    my($class, @args) = @_;
    my $self = $class->SUPER::new(@args);
    system "which dh-make-perl > /dev/null" and croak "dh-make-perl is not found in PATH";
    $self;
}

sub make {
    my($self, $info) = @_;
    my $pkg = pkgname($info->{module});
    my @depends = qw(perl);
#    push @depends, map { pkgname($_) } @{ $info->{depends} };
    my $depends = join ',', @depends;
    system "sudo dh-make-perl --build --notest --depends '$depends' $info->{src} >/tmp/cpan2pkg/deb/$pkg.log 2>&1"
        and return $self->error("make($info->{module}) 1");
    system "sudo mv /tmp/cpan2pkg/src/$pkg*.deb /tmp/cpan2pkg/deb/"
        and return $self->error("make($info->{module}) 2");
    $pkg;
}

sub pkgname {
    my($module) = @_;
    return $module if $module eq 'libwww-perl';
    $module =~ s{::}{-}g; $module =~ s{_}{-}g;
    'lib'.lc($module).'-perl';
}

sub is_installed {
    my($self, $module) = @_;
    my $pkg = pkgname($module);
    grep { $_ =~ /^$pkg/ } $self->installed_pkgs;
}

sub installed_pkgs {
    my @installed_pkg;
    my $is_pkg = 0;
    for my $l (split /[\r\n]+/, qx{LANG=C dpkg -l 'lib*-perl'}) {
        if ($l =~ /^[+]{3}/) {
            $is_pkg = 1;
        }
        elsif ($is_pkg && $l =~ /^ii/) { # if installed
            my($stat, $pkg, $ver, $desc) = split ' ', $l;
            push @installed_pkg, $pkg;
        }
    }
    @installed_pkg;
}

sub print_installed_pkgs {
    my($self) = @_;
    open my $fh, '>', '/tmp/cpan2pkg/deb/installed' or die;
    print $fh "apt-get -y install $_\n" for $self->installed_pkgs;
}

package Cpan2Pkg::RpmMaker;

use strict;
use warnings;

use base qw(Cpan2Pkg::Base);

sub new {
    my($class, @args) = @_;
    $class->SUPER::new(@args);
}

sub make {
    my($self, $info) = @_;
}

sub is_installed {
    my($self, $module) = @_;
}

sub print_installed_pkgs {
    my($self) = @_;
}

package main;

use strict;
use warnings;
use Data::Dumper; $Data::Dumper::Indent = 1;
use English qw(-no_match_vars);

*uniq = \&Cpan2Pkg::ModuleList::uniq;

sub say { print shift, "\n" }

unlink '/tmp/cpan2pkg/log';

say("execute autobundle...");

my $versions = Cpan2Pkg::Versions->autobundle;

say("making module list...");

my $list = Cpan2Pkg::ModuleList->new;

my @modules;
while (my $l = <>) {
    push @modules, grep { !$list->is_core($_) } split(' ', $l);
}

while (my $module = shift @modules) {
    if (my $ret = $list->add($module, $versions->{$module})) {
        @modules = uniq(@modules, @{ $ret->{depends} });
        say("$ret->{module} added");
    }
    else {
        @modules = grep { $_ ne $module } @modules;
        say("$module failed or skipped");
    }
}

say("making pkgs...");

my $maker = Cpan2Pkg::DebMaker->new;
$maker->print_installed_pkgs;
for my $module (values %{ $list->{modules} }) {
    next if $module->{module} =~ /^Plagger/ || $module->{module} =~ /^Task::Catalyst/;
    next if $maker->is_installed($module->{module});
    if (my $deb = $maker->make($module)) {
        say("$module->{module} created ($deb)");
    }
    else {
        say("$module->{module} failed");
    }
}