package App::cpm::Installer::Unpacker;

# Based on https://github.com/miyagawa/cpanminus/blob/7b574ede70cebce3709743ec1727f90d745e8580/Menlo-Legacy/lib/Menlo/CLI/Compat.pm#L2756-L2891
use v5.24;
use warnings;
use experimental qw(lexical_subs signatures);

use App::cpm::Util ();
use File::Basename ();
use File::Temp ();
use File::Which ();
use IPC::Run3 ();

sub run3 ($cmd, $outfile = undef) {
    my $out;
    IPC::Run3::run3 $cmd, \undef, ($outfile ? $outfile : \$out), \my $err;
    return ($?, $out, $err);
}

sub new ($class, %argv) {
    my $self = bless \%argv, $class;
    $self->_init_untar;
    $self->_init_unzip;
    $self;
}

sub unpack ($self, $file) {
    my $method = $file =~ /\.zip$/ ? $self->{method}{unzip} : $self->{method}{untar};
    $self->$method($file);
}

sub describe ($self) {
    my %describe = (
        map { ($_, $self->{$_}) }
        grep $self->{$_},
        qw(Archive::Tar unzip Archive::Zip),
    );
    if ($self->{tar}) {
        $describe{tar} = sprintf "%s (%s%s)",
            $self->{tar},
            $self->{tar_kind},
            $self->{tar_bad} ? ", bad" : "",
        ;
    }
    \%describe;
}

sub _init_untar ($self) {
    my $tar = $self->{tar} = File::Which::which('gtar') || File::Which::which("tar");
    if ($tar) {
        my ($exit, $out, $err) = run3 [$tar, '--version'];
        if ($out =~ /bsdtar/) {
            $self->{tar_kind} = 'bsd';
        } elsif ($out =~ /GNU/) {
            $self->{tar_kind} = 'gnu';
        } elsif ($^O eq 'openbsd') {
            $self->{tar_kind} = 'openbsd';
        } else {
            $self->{tar_kind} = 'unknown';
        }
        $self->{tar_bad} = 1 if $out =~ /GNU.*1\.13/i || $^O eq 'MSWin32' || $^O eq 'solaris' || $^O eq 'hpux';
    }

    if ($tar and !$self->{tar_bad}) {
        $self->{method}{untar} = *_untar;
        return if !$self->{_init_all};
    }

    if ($tar) {
        $self->{method}{untar} = *_untar_bad;
        return if !$self->{_init_all};
    }

    if (eval { require Archive::Tar }) {
        $self->{"Archive::Tar"} = Archive::Tar->VERSION;
        $self->{method}{untar} = *_untar_module;
        return if !$self->{_init_all};
    }

    return if $self->{_init_all};
    $self->{method}{untar} = sub ($, @) { die "There is no backend for untar" };
}

sub _init_unzip ($self) {
    my $unzip = $self->{unzip} = File::Which::which("unzip");
    if ($unzip) {
        $self->{method}{unzip} = *_unzip;
        return if !$self->{_init_all};
    }

    if (eval { require Archive::Zip }) {
        $self->{"Archive::Zip"} = Archive::Zip->VERSION;
        $self->{method}{unzip} = *_unzip_module;
        return if !$self->{_init_all};
    }

    return if $self->{_init_all};
    $self->{method}{unzip} = sub ($, @) { die "There is no backend for unzip" };
}

sub _untar ($self, $file) {
    my $wantarray = wantarray;

    my ($exit, $out, $err);
    {
        my $ar = $file =~ /\.bz2$/ ? 'j' : 'z';
        ($exit, $out, $err) = run3 [$self->{tar}, "${ar}tf", $file];
        last if $exit != 0;
        my $root = $self->_find_tarroot(split /\r?\n/, $out);
        my @no_same_owner = $self->{tar_kind} eq 'openbsd' ? () : ('-o');
        ($exit, $out, $err) = run3 [$self->{tar}, "${ar}xf", $file, @no_same_owner];
        return $root if $exit == 0 and -d $root;
    }
    return if !$wantarray;
    return (undef, $err || $out);
}

sub _untar_bad ($self, $file) {
    my $wantarray = wantarray;
    my ($exit, $out, $err);
    {
        my $ar = $file =~ /\.bz2$/ ? \&App::cpm::Util::bunzip2 : \&App::cpm::Util::gunzip;
        my $temp = File::Temp->new(SUFFIX => '.tar', EXLOCK => 0);
        my $ok;
        ($ok, $err) = $ar->($file, $temp->filename);
        if (!$ok) {
            last;
        }

        # XXX /usr/bin/tar: Cannot connect to C: resolve failed
        my @opt = $^O eq 'MSWin32' && $self->{tar_kind} ne "bsd" ? ('--force-local') : ();
        ($exit, $out, $err) = run3 [$self->{tar}, @opt, "-tf", $temp->filename];
        last if $exit != 0 || !$out;
        my $root = $self->_find_tarroot(split /\r?\n/, $out);
        ($exit, $out, $err) = run3 [$self->{tar}, @opt, "-xf", $temp->filename, "-o"];
        return $root if $exit == 0 and -d $root;
    }
    return if !$wantarray;
    return (undef, $err || $out);
}

sub _untar_module ($self, $file) {
    my $wantarray = wantarray;
    no warnings 'once';
    local $Archive::Tar::WARN = 0;
    my $t = Archive::Tar->new;
    {
        my $ok = $t->read($file);
        last if !$ok;
        my $root = $self->_find_tarroot($t->list_files);
        my @file = $t->extract;
        return $root if @file and -d $root;
    }
    return if !$wantarray;
    return (undef, $t->error);
}

sub _find_tarroot ($self, $root, @others) {
    FILE: {
        chomp $root;
        $root =~ s!^\./!!;
        $root =~ s{^(.+?)/.*$}{$1};
        if (!length $root) { # archive had ./ as the first entry, so try again
            $root = shift @others;
            redo FILE if $root;
        }
    }
    $root;
}

sub _unzip ($self, $file) {
    my $wantarray = wantarray;

    my ($exit, $out, $err);
    {
        ($exit, $out, $err) = run3 [$self->{unzip}, '-t', $file];
        last if $exit != 0;
        my $root = $self->_find_ziproot(split /\r?\n/, $out);
        ($exit, $out, $err) = run3 [$self->{unzip}, '-q', $file];
        return $root if $exit == 0 and -d $root;
    }
    return if !$wantarray;
    return (undef, $err || $out);
}

sub _unzip_module ($self, $file) {
    my $wantarray = wantarray;

    no warnings 'once';
    my $err = ''; local $Archive::Zip::ErrorHandler = sub (@argv) { $err .= "@argv" };
    my $zip = Archive::Zip->new;
    UNZIP: {
        my $status = $zip->read($file);
        last UNZIP if $status != Archive::Zip::AZ_OK();
        for my $member ($zip->members) {
            my $af = $member->fileName;
            next if $af =~ m!^(/|\.\./)!;
            my $status = $member->extractToFileNamed($af);
            last UNZIP if $status != Archive::Zip::AZ_OK();
        }
        my ($root) = $zip->membersMatching(qr{^[^/]+/$});
        last UNZIP if !$root;
        $root = $root->fileName;
        $root =~ s{/$}{};
        return $root if -d $root;
    }
    return if !$wantarray;
    return (undef, $err);
}

sub _find_ziproot ($self, $, $root, @others) {
    FILE: {
        chomp $root;
        if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}) {
            $root = shift @others;
            redo FILE if $root;
        }
    }
    $root;
}

1;
