package DhMakeRaku;

# ABSTRACT: Manage Debian package files of Raku modules

use strict;
use warnings;
use autodie qw(:all);

use Exporter qw/import/;

use Path::Tiny;
use Pod::POM;
use v5.32;
use Text::Wrap;
use Config::INI::Reader;
use Config::Model 2.150 qw/cme/;
use Pod::POM::View::Text;
use JSON;
use Git;
use Dpkg::Changelog::Debian;

$Text::Wrap::columns = 72;

use feature qw/signatures/;
no warnings qw/experimental::signatures/;

our @EXPORT_OK = qw/setup_debian_files setup_git commit set_remote upgrade/;

sub add_missing_tag {
    my $version = get_version_from_meta6();
    my $blame_line =  Git::command_oneline('blame', '-L', '/"version"/,+1', 'META6.json');
    my $commit_nb = (split / /, $blame_line)[0];
    # Raku custom has tags with a leading 'v'
    my $tag = 'v'.$version;
    Git::command_oneline(tag => $tag => $commit_nb);
    return $tag;
}

sub setup_git ($config, $arg) {
    my $init = 0;
    my $cwd = path('.')->absolute;
    my $upstream_remote = $config->{upstream_remote};
    my $upstream_branch = $config->{upstream_branch};
    my $debian_branch = $config->{debian_branch};

    my ($pkg_dir, $git, $package, $tag);
    if ($cwd->child('.git')->is_dir) {
        my $repo = Git->repository();
        if (grep {$_ eq 'upstream'} $repo->command('remote')) {
            say "renaming ambiguous remote name from upstream to $upstream_remote";
            $repo->command_oneline(remote => rename => upstream => $upstream_remote);
        }

        $package = $cwd->basename;
        if ($arg->{git}) {
            # looks like user has specified a new remote
            say " Setting remote $upstream_remote to $arg->{git}";
            $repo->command_oneline(qw/remote set-url/, $upstream_remote, $arg->{git});
        }
        $git = $repo->command_oneline(remote => 'get-url', $upstream_remote);
        $pkg_dir = $cwd;
        $tag = $arg->{tag};
    }
    else {
        say "setup git";
        $package = $arg->{pkg} ||  die "missing 'pkg' arg\n";
        $git = $arg->{git};
        $tag = $arg->{tag} ||  die "missing 'tag' arg\n";

        if ($cwd->basename ne $package) {
            die "missing 'git' arg\n" unless $git;
            $pkg_dir = $cwd->child($package);
            if (not $pkg_dir->exists) {
                Git::command_oneline(qw/clone --origin/, $upstream_remote, $git, $package);
                chdir $pkg_dir;
                my @refs = split m!/!, Git::command_oneline('symbolic-ref', "refs/remotes/$upstream_remote/HEAD");
                my $branch = pop @refs;
                Git::command_oneline('branch', '--move', $branch, $upstream_branch);
                if ($tag !~ /\d/) {
                    # need to get actual version and tag
                    Git::command_oneline(checkout => $tag);
                    $tag = add_missing_tag();
                }
                Git::command_oneline('checkout', '-b', $debian_branch, $tag);
                $init = 1;
            }
            else {
                chdir $pkg_dir;
            }
        }
    }
    return ($pkg_dir, $git, $package, $tag, $init);
}

sub set_remote ($name, $url) {
    my @remotes = Git::command_oneline(qw/remote show/);
    if (grep {$_ eq $name} @remotes) {
        my $current = Git::command_oneline(qw/remote get-url/, $name);
        if ($current ne $url) {
            say "Setting remote $name to $url...";
            Git::command_oneline(qw/remote set-url/, $name, $url);
        }
    }
    else {
        say "Creating remote $name to $url...";
        Git::command_oneline(qw/remote add/, $name, $url);
        Git::command_oneline(qw/remote set-url/, $name, '--push', $url);
    }
}

my %dispatch = (
    "README.rakudoc" => \&get_description_from_pod,
);

sub get_description ($dir) {
    my $desc;
    while ( my ($file, $func) = each %dispatch) {
        if ($dir->child($file)->exists) {
            $desc = $func->($dir->child($file));
        }
    }
    warn "Could not find description\n" unless $desc;
    return $desc;
}

sub get_description_from_pod ($file) {
    my $parser = Pod::POM->new();
    my $pom = $parser->parse_file($file->stringify)
        || die $parser->error();

    my $txt;
    foreach my $s ($pom->head1->@*) {
        next unless $s->title() =~ /description/i;
        my $pod_desc = $s->text;
        my $desc = $pod_desc->present('Pod::POM::View::Text');
        $desc =~ s/L<([^|]+)\|.*?>/$1/;
        $desc =~ s/(.)\n(.)/$1 $2/g;
        $txt = wrap('', '', $desc);
        chomp($txt);
        last;
    }

    return $txt;
}

# list modules provided by rakudo
my %core_dep = map {$_ => 1} qw/Test/;

sub is_core_dep($raku_dep) {
    return $core_dep{$raku_dep} // 0;
}

sub raku_dep_to_debian_dep ($raku_dep) {
    my ($pkg) = (split /\b:\b/, $raku_dep);
    my ($version) = ($raku_dep =~ /ver(?:sion)?<([\w.]+)\+?>/);
    my $dep = "raku-".lc($pkg =~ s/::/-/gr);
    $dep .= " (>= $version)" if $version;
    return $dep;
}

sub setup_dependencies($control, $package, $pkg_dir) {
    my $file = path('META6.json');
    # utf8 decode is done by JSON module, so slurp_raw must be used
    my $data =  decode_json($file->slurp_raw);
    return unless $data->{depends};

    foreach my $raku_dep ($data->{depends}->@*) {
        # skip when dependency has hints, don't know how to use them
        # see https://design.raku.org/S22.html#depends
        next if ref $raku_dep;

        next if is_core_dep($raku_dep);

        my $dep = raku_dep_to_debian_dep($raku_dep);
        say "check dependency $dep";
        $control->load(qq{source Build-Depends:.ensure("$dep")}.
                       qq{ - binary:$package Depends:.ensure("$dep")});
    }

    foreach my $raku_dep ($data->{"test-depends"}->@*) {
        next if is_core_dep($raku_dep);
        my $dep = raku_dep_to_debian_dep($raku_dep);
        say "check test dependency $dep";
        $control->load(qq{source Build-Depends:.ensure("$dep")});
    }
}

sub setup_control ($root, $pkg_dir, $homepage, $package) {
    say "setup control";

    # control file
    $root->load(<<"EOL");
control source
 Maintainer="Debian Rakudo Maintainers <pkg-rakudo-devel\@lists.alioth.debian.org>"
 Uploaders:.ensure("$ENV{DEBFULLNAME} <$ENV{DEBEMAIL}>")
 Section=interpreters
 Build-Depends:="debhelper-compat (= 13)",dh-sequence-raku
 Vcs-Browser="https://salsa.debian.org/perl6-team/modules/$package"
 Vcs-Git="https://salsa.debian.org/perl6-team/modules/$package.git"
 Homepage="$homepage"
 Rules-Requires-Root="no"

- binary:$package
 Synopsis=.json($package/META6.json/description)
 Synopsis=~s/^(an?|the)\\s+//i
 Architecture=any
 Depends="\${misc:Depends}","\${raku:Depends}"
EOL

    my $desc = get_description($pkg_dir);
    my $desc_obj = $root->grab("control binary:$package Description");
    if ($desc or not $desc_obj->fetch(check => 'no')) {
        $desc //= 'Please fill description manually';
        $desc_obj->store($desc);
    }

    setup_dependencies($root->grab("control"),$package, $pkg_dir);

    return;
}

sub get_version_from_meta6 {
    my $file = path('META6.json');
    # utf8 decode is done by JSON module, so slurp_raw must be used
    my $data =  decode_json($file->slurp_raw);
    my $version = ( $data->{version} =~ s/^v//r );
    if ($version) {
        return $version;
    }
    else {
        die "Could not find version from META6.json";
    }
}

sub setup_changelog ($root) {
    my $version = get_version_from_meta6;
    my $log = $root->fetch_element_value('changelog');
    # this changes the default value provided by cme
    $log =~ s/\([0.-]+\)/"($version-1)"/e;
    $log =~ s/\.\.\./Initial release/;
    $root->store_element_value(changelog => $log);
}

sub update_debian_copyright($in) {
    my $email = $ENV{DEBEMAIL};
    my $name = $ENV{DEBFULLNAME};
    my @l = localtime;
    my $year = $l[5]+1900;
    my $oldyear = $year - 1;

    my @cop_lines = defined $in ? split /\n/, $in : () ;
    my $done = 0;
    foreach my $cop (@cop_lines) {
        next unless ($cop =~ /$name/);
        $done = 1;

        # append current year
        $cop =~ s/(\d+),?\s+$name/$1, $year, $name/;

        # suppress duplicate current year (for idempotency)
        $cop =~ s/$year, $year/$year/;

        # create ranges with new year when needed
        $cop =~ s/-$oldyear,\s*$year,?\s+$name/-$year, $name/g;
        $cop =~ s/$oldyear,\s*$year,?\s+$name/$oldyear-$year, $name/g;
    }
    if (not $done) {
        push @cop_lines, "$year, $name <$email>";
    }
    return join("\n", @cop_lines);
}

sub setup_copyright($root, $homepage, $package) {
    # copyright file
    say "setup copyright";
    $root->load(<<"EOL");
copyright
 Upstream-Name=.json($package/META6.json/name)
 Source="$homepage"
EOL

    my $cop_obj = $root->grab(
        step => q!copyright Files:"debian/*" Copyright!,
        check => 'no'
    );
    my $new_cop = update_debian_copyright($cop_obj->fetch(check => 'no'));
    $cop_obj->store($new_cop);

    my $license = $root->grab_value(q!copyright Files:"*" License short_name!);
    $root->load(qq!copyright Files:"debian/*" License short_name="$license"!);
}

sub setup_patches ($pkg_dir) {
    say "checking patches";

    # need to setup quilt when run in build process
    if (not -e $ENV{HOME}.'/.quiltrc') {
        say "File ~/.quiltrc not found. Setting up quilt for Debian in QUILT_* environment variables";
        $pkg_dir->child('debian/patches')->mkpath;
         $ENV{QUILT_PATCHES}="debian/patches";
         $ENV{QUILT_PATCH_OPTS} = "--reject-format=unified";
         $ENV{QUILT_DIFF_ARGS} = "-p ab --no-timestamps --no-index --color=auto";
         $ENV{QUILT_REFRESH_ARGS} = "-p ab --no-timestamps --no-index";
    }

    my $patch_name = 'rm-shebang';
    my $i = 0;
    my $create_patch = 0;
    my $has_series = 0;
    while (my $out = `quilt push -q 2>&1`) {
        if ($out =~ /failed/i) {
            die "quilt push failed:\n$out";
        }
        if ($out =~ /no series/i) {
            $create_patch = 1;
            last;
        }
        if ($out =~ /fully applied/i) {
            $create_patch = 1;
            $has_series = 1;
            last;
        }
        if ($out =~ /Now at patch $patch_name/i) {
            $has_series = 1;
            last;
        }
        if ($i++ > 500) {
            die "Internal bug: quilt push is looping indefinitely. Please contact the author";
        }
    }

    my @files_to_patch;
    $pkg_dir->child("lib")->visit(
        sub {
            my ($path, $state) = @_;
            return if $path->is_dir;
            my ($first) = $path->lines_utf8({count => 1});
            if ( $first =~ m(^#!) ) {
                say "Need to patch $path to remove shebang line";
                push @files_to_patch, $path->relative($pkg_dir);
            }
        },
        { recurse => 1},
    );

    if (not @files_to_patch) {
        system ("quilt pop -a") if $has_series;
        return;
    }

    if ($create_patch) {
        $pkg_dir->child('debian')->mkpath;
        say "Creating patch $patch_name";
        system("quilt new $patch_name");
    }

    foreach my $file (@files_to_patch) {
        say "patching $file";
        system ("quilt add $file");
        my @lines = $file->lines_utf8;
        shift @lines; # lob off #! line
        $file->spew_utf8(@lines);
    }

    system ("quilt refresh");
    system ("quilt pop -a");
    return $patch_name;
}

sub setup_patch_data ($root, $patch_name) {
    $root->load(qq!patches:$patch_name
Synopsis="Rm shebang from Raku module files"
Description="Upstream shebang line is pointless and trigger lintian warnings."
Author="$ENV{DEBEMAIL}"
Applied-Upstream=not-needed
!);
}

sub get_watch_content ($git, $package) {
    my $watch;
    if ($git =~ /github/) {
        $git =~ s/\.git$//;
        $watch = <<"EOW";
version=4
opts="filenamemangle=s%(?:.*?)?v?(\\d[\\d.]*\@ARCHIVE_EXT@)%\@PACKAGE\@-\$1%" \\
   $git/tags \\
   (?:.*?/)?v?\@ANY_VERSION@\@ARCHIVE_EXT@
EOW
    }
    else {
        # watch file for cgit sites
        $watch = <<"EOW";
version=4
opts=filenamemangle=s/.+\\/v?(\\d\\S+)\\.tar\\.gz/$package-\$1\\.tar\\.gz/ \\
  $git .*?-?(\\d\\S+)\\.tar\\.gz
EOW
    }

    return $watch;
}

sub setup_watch_file ($root, $git, $package) {
    say "setup watch file";
    my $watch = get_watch_content($git, $package);
    $root->store_element_value(name => "watch", value => $watch);
    return;
}

sub commit () {
    system("git add debian/");
    system('git commit -m "Initial version created with dh-make-raku"');
}

sub setup_readme_source ($pkg_dir) {
    my $deb_dir = $pkg_dir->child('debian');
    $deb_dir->mkpath;
    my $readme = $deb_dir->child("README.source");
    return if $readme->exists;

    say "Setting up README.source";
    $deb_dir->child("README.source")->spew(<<EOF);
This package was created by dh-make-raku.

It can be built with the following command:

    gbp buildpackage

EOF
}

sub install_docs($root, $package, $pkg_dir) {
    foreach my $file ($pkg_dir->children(qr/^README/)) {
        my $elt_name = $file->basename;
        $root->load(qq!install:"$package.docs" content:.ensure("$elt_name")!);
    }
}

sub setup_debian_files ($config, $pkg_dir, $git, $package, $tag, $init) {
    my $patch_name = setup_patches ($pkg_dir);

    my $instance = cme(application => 'dpkg', name => $package);
    my $root = $instance->config_root;
    my $homepage = ($git =~ s/\.git$//r);

    setup_control ($root, $pkg_dir, $homepage, $package);

    setup_changelog ($root) if $init;

    $root->instance->update;

    setup_copyright ($root, $homepage, $package);

    if ($pkg_dir->child('examples')->is_dir) {
        $root->load(qq(examples:$package content:="examples/*"));
    }

    setup_patch_data ($root, $patch_name) if $patch_name;

    setup_watch_file ($root, $git, $package);

    install_docs($root, $package, $pkg_dir);

    # upstream/metadata not yet supported by cme-dpkg

    if ($init) {
        say "setup source format";
        $root->load(q!source format="3.0 (quilt)"!);
    }

    $root->apply_fixes;

    print "writing Debian files...";
    $instance->write_back;
    say "done";

    setup_readme_source ($pkg_dir);

    if ($tag) {
        my $tag_pattern = $tag;
        $tag_pattern =~ s/[\d.]+/%(version)s/;

        $pkg_dir->child('debian/gbp.conf')->spew(qq!
[DEFAULT]
pristine-tar = False
pristine-tar-commit = False
upstream-tag = $tag_pattern
debian-branch = $config->{debian_branch}
upstream-branch = $config->{upstream_branch}
!);
    }

    return $root;
}

sub gbp_conf ($arg, $class = 'DEFAULT') {
    my $config_hash = Config::INI::Reader->read_file('debian/gbp.conf');
    return $config_hash->{$class}{$arg};
}

sub upgrade ($config, $version) {
    my $tag = gbp_conf('upstream-tag') eq 'v%(version)s' ? "v$version" : $version;

    my $repo = Git->repository();

    if (grep {$_ eq $tag} $repo->command(qw/tag --merged/)) {
        say "Upstream tag $tag was already merged";
    }
    else {
        $repo->command_oneline('fetch', '--all');
        $repo->command_oneline('checkout', $config->{upstream_branch});
        $repo->command_oneline('merge', $tag);
        $repo->command_oneline('checkout', $config->{debian_branch});
        $repo->command_oneline('merge', $config->{upstream_branch});
    }

    my $changelog = Dpkg::Changelog::Debian->new();
    my $count = $changelog->load('debian/changelog');

    # update debian/changelog if needed
    my ($last_entry) = $changelog->get_range({count => 1});
    if ($last_entry->get_version =~ /^$version/) {
        say "changelog entry for version $version already done";
    } else {
        say "creating new changelog entry for version $version";
        system(qw/gbp dch/, "--new-version=$version-1",qw!--snapshot --auto debian/!) == 0
            or die "gb dch failed: $!";
    }
}

1;
