#!/usr/bin/env perl
#
# upd - download the matching binary from the latest Gitea/GitHub release.
#
#   ./upd https://git.fhi.mpg.de/mike/mgsh
#   ./upd https://github.com/sxyazi/yazi --install ~/bin --name yazi,ya
#   ./upd --all                       # everything listed in the config file
#   ./upd --all --check               # exit 10 if any update is available
#
# Needs only Perl core modules plus curl (or wget) for HTTPS.

use strict;
use warnings;
use Getopt::Long qw(GetOptions);
use File::Basename qw(basename dirname);
use File::Spec;
use File::Temp qw(tempdir);
use POSIX qw(uname strftime);
use Digest::SHA qw(sha256_hex);
use JSON::PP ();

my $UA = 'upd/2.0 (perl)';

# Exit codes: 0 ok, 1 usage, 2 error, 10 update available (--check only).
use constant { EX_OK => 0, EX_USAGE => 1, EX_ERROR => 2, EX_OUTDATED => 10 };

# Options that belong to a single repository. Anything else is global and
# applies to every entry of an --all run.
my @SPEC_KEYS = qw(install name tag asset pattern os arch forge token version-flag pre);

my %opt = ('version-flag' => '--version', timeout => 30);

# Leftovers from an interrupted install must not linger next to the binary.
my @TMPFILES;
END { unlink @TMPFILES if @TMPFILES }

# Run only when executed directly, so the subs below can be require'd and
# exercised on their own.
main() unless caller;

sub main {
    GetOptions(
        \%opt,
        'repo=s', 'tag=s', 'install|dest|i=s', 'name=s', 'asset=s', 'pattern=s',
        'os=s', 'arch=s', 'token=s', 'forge=s', 'version-flag=s', 'timeout=i',
        'config=s', 'all', 'check', 'pre', 'force', 'list', 'dry-run',
        'quiet', 'verbose', 'help',
    ) or usage(EX_USAGE);
    usage(EX_OK) if $opt{help};
    $| = 1;

    for my $sig (qw(INT TERM HUP)) {
        $SIG{$sig} = sub { unlink @TMPFILES; @TMPFILES = (); exit 130 };
    }

    my @specs;
    eval { @specs = build_specs(); 1 } or do {
        warn trim($@) . "\n";
        exit EX_ERROR;
    };

    my @results;
    for my $spec (@specs) {
        my $res = eval { update_one($spec) };
        $res = { status => 'error', label => label_of($spec), msg => trim($@ || 'failed') }
          unless defined $res;
        push @results, $res;
        warn "$res->{label}: $res->{msg}\n" if $res->{status} eq 'error';
    }

    summary(\@results) if @specs > 1 && !$opt{list};
    exit worst_code(\@results);
}

sub build_specs {
    if ($opt{all}) {
        my $path = $opt{config} // config_path();
        my @s = read_config($path);
        die "No entries in $path.\n" unless @s;
        return @s;
    }
    my $url = $opt{repo} // shift(@ARGV) // $ENV{UPD_REPO};
    unless (defined $url && length $url) {
        warn "Error: missing repository URL.\n\n";
        usage(EX_USAGE);
    }
    my %s = (repo => $url);
    $s{$_} = $opt{$_} for grep { defined $opt{$_} } @SPEC_KEYS;
    return (\%s);
}

# ==============================================================================
# One repository, end to end
# ==============================================================================

sub update_one {
    my $spec = shift;

    my ($base, $owner, $repo) = parse_repo($spec->{repo});
    my $forge = detect_forge($base, $spec->{forge});
    my %ctx   = (
        base  => $base,
        owner => $owner,
        repo  => $repo,
        forge => $forge,
        token => resolve_token($forge, $spec->{token}),
        api   => api_base($base, $forge) . '/repos/' . uri_esc($owner) . '/' . uri_esc($repo),
    );

    my @names = parse_names($spec->{name} // $repo, $repo);
    my ($os, $arch) = detect_platform($spec);

    info("Repo:     $base/$owner/$repo [$forge]");
    info("Platform: $os/$arch");

    my $rel = fetch_release(\%ctx, $spec);
    my $tag = $rel->{tag_name};

    if ($opt{list}) {
        list_releases($rel->{_list} || [$rel]);
        return { status => 'listed', label => $names[0]{out}, msg => '' };
    }

    info("Release:  $tag ($rel->{published_at})" . ($rel->{prerelease} ? ' [prerelease]' : ''));

    my @assets = @{ $rel->{assets} || [] };
    die "Release $tag has no assets.\n" unless @assets;

    my $asset = pick_asset(\@assets, $names[0]{src}, $os, $arch, $spec);
    unless ($asset) {
        my $have = join "\n  ", map { $_->{name} } @assets;
        die "No asset for $os/$arch in release $tag.\nAvailable:\n  $have\n"
          . "Select one explicitly with --asset <name> or --pattern <regex>.\n";
    }
    info("Asset:    $asset->{name} (" . human_size($asset->{size}) . ")");

    my @targets = resolve_targets($spec, \@names, $os);
    info("Target:   " . join(', ', map { $_->{dest} } @targets));

    my @stale = grep { !target_current($_, $tag, $asset, $spec) } @targets;
    unless (@stale || $opt{force}) {
        info("Already up to date ($tag) - nothing to do.");
        return { status => 'current', label => $names[0]{out}, msg => $tag };
    }
    @stale = @targets if $opt{force};

    if ($opt{check}) {
        my $have = join ', ', map { installed_tag($_) } @stale;
        info("Update available: $tag (installed: $have)");
        return { status => 'outdated', label => $names[0]{out}, msg => "$tag (have: $have)" };
    }

    my ($dl_url) = asset_url(\%ctx, $asset);
    if ($opt{'dry-run'}) {
        print "[dry-run] would download: $dl_url\n";
        print "[dry-run] would install to: $_->{dest}\n" for @stale;
        return { status => 'dry', label => $names[0]{out}, msg => $tag };
    }

    # --- download -------------------------------------------------------------

    my $tmpdir = tempdir(CLEANUP => 1);
    my $dl     = File::Spec->catfile($tmpdir, $asset->{name});

    info("Downloading $dl_url ...");
    my (undef, $dl_hdr) = asset_url(\%ctx, $asset);
    my $res = http_request(url => $dl_url, headers => { %{ auth_headers(\%ctx) }, %$dl_hdr },
                           file => $dl, progress => 1);
    die "Download failed (HTTP $res->{status}): $dl_url\n" unless $res->{status} == 200;

    my $got = -s $dl // 0;
    die "Incomplete download: $got of $asset->{size} bytes.\n"
      if $asset->{size} && $got < $asset->{size};

    verify_download(\%ctx, $dl, $asset, \@assets, $tmpdir);

    # --- extract and install --------------------------------------------------

    my $root = extract_if_archive($dl, $tmpdir);
    for my $t (@stale) {
        my $src = defined $root ? find_in_tree($root, $t->{name})
                                : $dl;
        die "Binary '$t->{name}' not found inside $asset->{name}.\n" unless defined $src;
        warn "Warning: $t->{name} does not look like an executable.\n"
          unless looks_executable($src);

        install_atomic($src, $t->{dest});
        strip_quarantine($t->{dest}) if $os eq 'darwin';
        write_state($t, \%ctx, $spec, $tag, $asset);
        info("Installed: $t->{dest} ($tag)");
        my $v = installed_version($t->{dest}, $spec);
        info("Version:   $v") if length $v;
    }

    my %dirs = map { dirname($_->{dest}) => 1 } @stale;
    warn "Note: $_ is not in \$PATH.\n" for grep { !in_path($_) } sort keys %dirs;

    return { status => 'updated', label => $names[0]{out}, msg => $tag };
}

# ==============================================================================
# Release selection
# ==============================================================================

sub fetch_release {
    my ($ctx, $spec) = @_;

    # A specific tag: both forges have a direct endpoint. Fall back to the list
    # so "26.5.6" also finds a tag named "v26.5.6".
    if (defined $spec->{tag}) {
        my $t   = $spec->{tag};
        my $hit = api_get($ctx, "$ctx->{api}/releases/tags/" . uri_esc($t), soft => 1);
        return $hit if $hit && $hit->{tag_name};
        my $list = api_get($ctx, releases_url($ctx));
        ($hit) = grep { $_->{tag_name} eq $t } @$list;
        ($hit) = grep { norm_ver($_->{tag_name}) eq norm_ver($t) } @$list unless $hit;
        die "Release '$t' not found (--list shows all).\n" unless $hit;
        return $hit;
    }

    # The plain case is one request: the forge already knows its latest
    # non-draft, non-prerelease release.
    unless ($spec->{pre} || $opt{list}) {
        my $latest = api_get($ctx, "$ctx->{api}/releases/latest", soft => 1);
        return $latest if $latest && $latest->{tag_name};
        verbose('no /releases/latest, falling back to the release list');
    }

    my $list = api_get($ctx, releases_url($ctx));
    die "No releases found in $ctx->{owner}/$ctx->{repo}.\n"
      unless ref $list eq 'ARRAY' && @$list;

    if ($opt{list}) {
        return { tag_name => '', published_at => '', assets => [], _list => $list };
    }
    my ($rel) = grep { !$_->{draft} && ($spec->{pre} || !$_->{prerelease}) } @$list;
    die "No suitable release found (try --pre).\n" unless $rel;
    return $rel;
}

sub releases_url {
    my $ctx = shift;
    return $ctx->{forge} eq 'github' ? "$ctx->{api}/releases?per_page=50"
                                     : "$ctx->{api}/releases?limit=50&draft=false";
}

# ==============================================================================
# Asset selection
# ==============================================================================

# Aliases commonly used in release asset names, including Rust target triples.
sub os_alias {
    my $o = shift;
    return $o eq 'darwin'  ? [qw(darwin macos osx mac apple)]
         : $o eq 'windows' ? [qw(windows win)]
         :                   [$o];
}

# --- Asset name matching ------------------------------------------------------

# Can this machine turn the asset into a binary? Bare names and tarballs
# always qualify; single-file compression needs its decompressor present.
sub unpackable {
    my $n = lc shift;
    return 1 if $n =~ /\.(tar\.gz|tgz|tar\.bz2|tbz|tar\.xz|txz|tar\.zst|tzst|tar)$/;
    return which('unzip') ? 1 : 0 if $n =~ /\.zip$/;
    return (which('7zz') || which('7z') || which('7za')) ? 1 : 0 if $n =~ /\.7z$/;
    return decompressor($1) ? 1 : 0 if $n =~ /\.(gz|bz2|xz|zst|lz4|lzma)$/;
    return 0 if $n =~ /\.(rar|dmg|pkg|msi|deb|rpm)$/;
    return 1;    # bare binary or an unversioned name
}

# Compound tokens that name OS and architecture in one word. Rewritten before
# matching so the normal token rules apply. "win32" is Node-speak for Windows
# in general (pnpm-win32-x64.zip), so it contributes no architecture.
sub normalize_tokens {
    my $n = shift;
    $n =~ s/(?<![a-z0-9])win64(?![a-z0-9])/windows-amd64/g;
    $n =~ s/(?<![a-z0-9])win32(?![a-z0-9])/windows/g;
    return $n;
}

sub arch_alias {
    my $a = shift;
    return $a eq 'amd64'   ? [qw(amd64 x86_64 x64 64bit)]
         : $a eq 'arm64'   ? [qw(arm64 aarch64)]
         : $a eq '386'     ? [qw(386 i386 i686 x86 32bit)]
         : $a eq 'arm'     ? [qw(arm armv7 armv6 armhf)]
         : $a eq 'riscv64' ? [qw(riscv64 riscv64gc)]
         :                   [$a];
}

# Glibc vs musl builds: pick what this system actually runs.
my $MUSL;
sub prefers_musl {
    return $MUSL if defined $MUSL;
    return $MUSL = 1 if -f '/etc/alpine-release';
    my $ldd = which('ldd');
    my $out = $ldd ? capture(5, $ldd, '--version') : '';
    return $MUSL = $out =~ /musl/i ? 1 : 0;
}

# NB: no lexical $a/$b in here - they would shadow sort's globals below.
sub pick_asset {
    my ($assets, $bin, $want_os, $want_arch, $spec) = @_;

    if (defined $spec->{asset}) {
        my ($hit) = grep { $_->{name} eq $spec->{asset} } @$assets;
        die "Asset '$spec->{asset}' is not part of the release.\n" unless $hit;
        return $hit;
    }
    if (defined $spec->{pattern}) {
        my $re = qr/$spec->{pattern}/;
        my ($hit) = grep { $_->{name} =~ $re } @$assets;
        return $hit;
    }

    my $os_re   = join '|', @{ os_alias($want_os) };
    my @arches  = @{ arch_alias($want_arch) };
    # Universal macOS builds serve both architectures.
    push @arches, qw(universal universal2) if $want_os eq 'darwin';
    my $arch_re = join '|', @arches;

    my (@cand, @rejected);
    for my $as (@$assets) {
        my $n = lc $as->{name};
        my $m = normalize_tokens($n);

        # Checksums, signatures and OS packages are not plain binaries.
        if ($n =~ /\.(sha\d*|sha256sum|md5|asc|sig|pem|sbom|json|txt|deb|rpm|apk|dmg|pkg|msi|snap|flatpak|appimage)$/) {
            push @rejected, "$n (not a binary)";
            next;
        }
        # Cross-compile targets whose triples contain a host OS token:
        # aarch64-linux-android is Android, not Linux.
        if ($m =~ /(?:^|[^a-z0-9])(?:android\w*|ios|wasi|wasm\w*|emscripten)(?:[^a-z0-9]|$)/) {
            push @rejected, "$n (foreign target)";
            next;
        }
        unless ($m =~ /(?:^|[^a-z0-9])(?:$os_re)(?:[^a-z0-9]|$)/) {
            push @rejected, "$n (os)";
            next;
        }
        unless ($m =~ /(?:^|[^a-z0-9])(?:$arch_re)(?:[^a-z0-9]|$)/) {
            push @rejected, "$n (arch)";
            next;
        }
        # Keep 32-bit "arm" off "arm64" and "386" off "x86_64".
        if (   ($want_arch eq 'arm'   && $m =~ /arm64|aarch64/)
            || ($want_arch eq '386'   && $m =~ /x86[_-]?64|amd64/)
            || ($want_arch eq 'amd64' && $m =~ /arm64|aarch64/)) {
            push @rejected, "$n (wider arch)";
            next;
        }

        my $score = 0;
        $score += 10 if index($n, lc $bin) == 0;    # named after the binary
        $score += 3  if $n =~ /\.(tar\.gz|tgz|zip|tar\.xz|tar\.bz2|tar\.zst|tzst)$/ || $n !~ /\./;
        $score -= 5  if $n =~ /debug|symbols|static-pie|profile/;
        # Only avoid formats this machine has no tool for - restic, for one,
        # ships nothing but .bz2, and bunzip2 handles that fine.
        $score -= 8  if !unpackable($n);

        # Toolchain preference is a tie-break, not a penalty: a project that
        # ships musl only (or mingw only) must not be downranked for it.
        my $pref = 0;
        if ($want_os eq 'linux' && $n =~ /musl|gnu/) {
            my $libc = prefers_musl() ? 'musl' : 'gnu';
            $pref = $n =~ /\Q$libc\E/ ? 0 : 1;
        }
        elsif ($want_os eq 'windows' && $n =~ /msvc|gnu/) {
            $pref = $n =~ /msvc/ ? 0 : 1;    # msvc is the normal Windows build
        }
        push @cand, [ $score, $pref, length($n), $as ];
    }

    # Best score, then preferred toolchain, then the shortest name (which
    # avoids special variants like -baseline or -static).
    @cand = sort { $b->[0] <=> $a->[0] || $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2] } @cand;
    if ($opt{verbose}) {
        verbose(sprintf 'candidate score=%-3d pref=%d %s', @{$_}[0, 1], $_->[3]{name}) for @cand;
        verbose("rejected: $_") for @rejected;
    }
    return @cand ? $cand[0][3] : undef;
}

# ==============================================================================
# Install targets and state
# ==============================================================================

sub resolve_targets {
    my ($spec, $names, $os) = @_;
    my $want = $spec->{install} // $ENV{UPD_INSTALL};
    $want =~ s{^~(?=/|$)}{$ENV{HOME} // '~'}e if defined $want;
    my $ext = $os eq 'windows' ? '.exe' : '';

    # --install is a directory unless it clearly points at a single binary:
    # an existing file, or a last segment that is one of the binary names.
    # Everything else is a directory (and gets created) - otherwise a config
    # line like "install=~/bin" would create a *file* called bin.
    my ($dir, $single);
    if (defined $want && length $want) {
        my $leaf   = basename($want);
        my $is_bin = grep { $leaf eq $_->{out} || $leaf eq $_->{out} . $ext } @$names;
        if (!-d $want && ($is_bin || -f $want)) {
            die "--install points at the file '$want' but " . scalar(@$names)
              . " binaries were requested; give a directory instead.\n" if @$names > 1;
            $single = $want;
            $dir    = dirname($want);
        }
        else {
            ($dir = $want) =~ s{(?<=.)/+$}{};
        }
    }
    else {
        $dir = default_dir($names->[0]{out});
    }
    make_dir($dir);

    my @t;
    for my $n (@$names) {
        my $dest = $single // File::Spec->catfile($dir, $n->{out} . $ext);
        # Replacing a symlink would silently break the link, so follow it.
        if (-l $dest) {
            require Cwd;
            if (my $real = Cwd::abs_path($dest)) {
                info("Note:     $dest is a symlink, installing to $real");
                $dest = $real;
            }
        }
        push @t, { name => $n->{src}, out => $n->{out}, dest => $dest };
    }
    return @t;
}

# Without --install: replace the binary already on PATH, else ~/.local/bin.
sub default_dir {
    my $bin = shift;
    for my $dir (split /:/, ($ENV{PATH} // '')) {
        next unless length $dir;
        my $p = File::Spec->catfile($dir, $bin);
        return $dir if -x $p && -w $dir;
    }
    return File::Spec->catdir($ENV{HOME} // '.', '.local', 'bin');
}

sub make_dir {
    my $dir = shift;
    return if -d $dir || $opt{'dry-run'} || $opt{list} || $opt{check};
    require File::Path;
    File::Path::make_path($dir)
      or die "Cannot create target directory $dir: $!\n";
}

sub state_dir {
    my $base = $ENV{XDG_STATE_HOME}
      || File::Spec->catdir($ENV{HOME} // '.', '.local', 'state');
    return File::Spec->catdir($base, 'upd');
}

sub cache_dir {
    my $base = $ENV{XDG_CACHE_HOME} || File::Spec->catdir($ENV{HOME} // '.', '.cache');
    return File::Spec->catdir($base, 'upd');
}

# One state file per installed path; readable name plus a hash for uniqueness.
sub state_file {
    my $dest = shift;
    (my $key = $dest) =~ s{[^A-Za-z0-9._-]+}{_}g;
    $key =~ s{^_+|_+$}{}g;
    $key = substr($key, -70) if length $key > 70;
    return File::Spec->catfile(state_dir(), $key . '.' . substr(sha256_hex($dest), 0, 8) . '.json');
}

# Identity of a release asset: the digest if the forge publishes one (GitHub
# does), otherwise its upload time - this is what makes rolling tags such as
# "nightly" detectable.
sub asset_stamp {
    my $a = shift;
    return $a->{digest}                if $a->{digest};
    return "t:$a->{updated_at}"        if $a->{updated_at};
    return "t:$a->{created_at}"        if $a->{created_at};
    return 's:' . ($a->{size} // 0);
}

sub target_current {
    my ($t, $tag, $asset, $spec) = @_;
    return 0 unless -f $t->{dest};

    my $st = read_json(state_file($t->{dest}));
    if ($st && defined $st->{tag}) {
        return 0 unless $st->{tag} eq $tag;
        return 0 unless ($st->{asset} // '') eq $asset->{name};
        return 0 unless ($st->{stamp} // '') eq asset_stamp($asset);
        # A locally replaced binary counts as out of date.
        my $same = ($st->{binary_sha256} // '') eq file_sha256($t->{dest});
        verbose("$t->{dest}: state matches but binary differs") unless $same;
        return $same;
    }

    # No state yet (first run after an install by other means): ask the binary.
    my $v = installed_version($t->{dest}, $spec);
    verbose("$t->{dest}: no state file, binary reports '" . ($v // '') . "'");
    return length($v) && $v eq norm_ver($tag) ? 1 : 0;
}

sub installed_tag {
    my $t  = shift;
    my $st = read_json(state_file($t->{dest}));
    return $st->{tag} if $st && defined $st->{tag};
    return '-' unless -f $t->{dest};
    my $v = installed_version($t->{dest}, {});
    return length($v) ? $v : 'unknown';
}

sub write_state {
    my ($t, $ctx, $spec, $tag, $asset) = @_;
    make_dir_always(state_dir());
    write_json(state_file($t->{dest}), {
        dest          => $t->{dest},
        binary        => $t->{out},
        repo          => "$ctx->{base}/$ctx->{owner}/$ctx->{repo}",
        forge         => $ctx->{forge},
        tag           => $tag,
        asset         => $asset->{name},
        asset_size    => $asset->{size},
        stamp         => asset_stamp($asset),
        binary_sha256 => file_sha256($t->{dest}),
        installed_at  => strftime('%Y-%m-%dT%H:%M:%SZ', gmtime),
    });
}

sub make_dir_always {
    my $dir = shift;
    return if -d $dir;
    require File::Path;
    File::Path::make_path($dir) or die "Cannot create $dir: $!\n";
}

# ==============================================================================
# Config file (--all)
# ==============================================================================

sub config_path {
    my $base = $ENV{XDG_CONFIG_HOME} || File::Spec->catdir($ENV{HOME} // '.', '.config');
    return File::Spec->catfile($base, 'upd', 'tools');
}

# One entry per line: <repo-url> [key=value ...] [pre]
sub read_config {
    my $path = shift;
    open my $fh, '<', $path
      or die "Cannot read config $path: $!\n"
           . "Format: one line per tool, e.g.\n"
           . "  https://github.com/sxyazi/yazi  install=~/bin  name=yazi,ya\n";

    my (@out, $ln);
    while (my $line = <$fh>) {
        $ln++;
        $line =~ s/^\s+|\s+$//g;
        next if !length $line || $line =~ /^#/;

        my @tok = map { unquote($_) } $line =~ /("(?:\\.|[^"])*"|\S+)/g;
        my %s = (repo => shift @tok);
        for my $t (@tok) {
            my ($k, $v) = split /=/, $t, 2;
            $k = lc $k;
            die "$path:$ln: unknown key '$k' (allowed: " . join(', ', @SPEC_KEYS) . ")\n"
              unless grep { $_ eq $k } @SPEC_KEYS;
            $s{$k} = defined $v ? $v : 1;
        }
        # Global flags still win, so --force/--pre on the command line apply.
        $s{$_} = $opt{$_} for grep { defined $opt{$_} } @SPEC_KEYS;
        push @out, \%s;
    }
    close $fh;
    return @out;
}

sub unquote {
    my $s = shift;
    if ($s =~ s/^"(.*)"$/$1/s) { $s =~ s/\\(.)/$1/g }
    return $s;
}

# "yazi,ya" -> two binaries; "yazi:yazi-nightly" -> install yazi under a
# different file name. src is what to look for, out is what to write.
sub parse_names {
    my ($list, $fallback) = @_;
    my @n;
    for my $part (split /\s*,\s*/, $list) {
        next unless length $part;
        my ($src, $out) = split /:/, $part, 2;
        push @n, { src => $src, out => (defined $out && length $out) ? $out : $src };
    }
    return @n ? @n : ({ src => $fallback, out => $fallback });
}

sub label_of {
    my $spec = shift;
    return (parse_names($spec->{name}, '?'))[0]{out} if defined $spec->{name};
    my $r = $spec->{repo} // '?';
    $r =~ s{/+$}{};
    return basename($r);
}

sub summary {
    my $res = shift;
    # --quiet is meant for cron: report only what needs attention.
    my @rows = $opt{quiet}
      ? grep { $_->{status} =~ /^(error|outdated|updated)$/ } @$res
      : @$res;
    return unless @rows;
    my $w = 0;
    for (@rows) { $w = length $_->{label} if length $_->{label} > $w }
    print "\nSummary:\n";
    printf "  %-9s %-*s %s\n", $_->{status}, $w, $_->{label}, $_->{msg} // '' for @rows;
}

sub worst_code {
    my $res = shift;
    return EX_ERROR    if grep { $_->{status} eq 'error' } @$res;
    return EX_OUTDATED if grep { $_->{status} eq 'outdated' } @$res;
    return EX_OK;
}

# ==============================================================================
# HTTP
# ==============================================================================

# Use HTTP::Tiny only if it can really do TLS - otherwise curl/wget.
my $HTTP;
sub http_tiny {
    return $HTTP if defined $HTTP;
    $HTTP = eval {
        require HTTP::Tiny;
        HTTP::Tiny->can_ssl or die "no ssl\n";
        HTTP::Tiny->new(agent => $UA, timeout => $opt{timeout}, verify_SSL => 1);
    } || 0;
    return $HTTP;
}

sub transport {
    return 'tiny' if http_tiny();
    return 'curl' if which('curl');
    return 'wget' if which('wget');
    die "Found neither a TLS-capable HTTP::Tiny nor curl/wget.\n";
}

# wget cannot report response headers usefully, so no conditional requests.
sub conditional_ok { return transport() ne 'wget' }

sub auth_headers {
    my $ctx = shift;
    return {} unless $ctx->{token};
    # GitHub wants "Bearer", Gitea wants "token".
    return { Authorization => $ctx->{forge} eq 'github' ? "Bearer $ctx->{token}"
                                                        : "token $ctx->{token}" };
}

# Returns { status, headers => {lc => value}, content } - content only when no
# 'file' was given. Never dies on HTTP status; callers decide.
sub http_request {
    my %a  = @_;
    my $hdr = $a{headers} || {};

    if (my $h = http_tiny()) {
        my %o = (headers => $hdr);
        my $out;
        if ($a{file}) {
            open $out, '>', $a{file} or die "Cannot write $a{file}: $!\n";
            binmode $out;
            $o{data_callback} = sub { print {$out} $_[0] };
        }
        my $r = $h->get($a{url}, \%o);
        close $out if $out;
        return { status => $r->{status}, headers => $r->{headers} || {},
                 content => $a{file} ? '' : $r->{content} };
    }

    my $tmp = tempdir(CLEANUP => 1);
    my $body = $a{file} // File::Spec->catfile($tmp, 'body');
    my $hf   = File::Spec->catfile($tmp, 'head');

    if (transport() eq 'wget') {
        my @cmd = ('wget', '-q', '-O', $body, '--timeout', $opt{timeout}, "--user-agent=$UA",
                   map { "--header=$_: $hdr->{$_}" } sort keys %$hdr);
        my $rc = system(@cmd, $a{url});
        return { status => $rc == 0 ? 200 : 599, headers => {},
                 content => $a{file} ? '' : slurp($body) };
    }

    my @prog = ($a{progress} && !$opt{quiet} && -t STDOUT) ? ('--progress-bar') : ('-sS');
    my @cmd  = ('curl', @prog, '-L', '--retry', '2', '--connect-timeout', $opt{timeout},
                '-A', $UA, '-D', $hf, '-o', $body, '-w', '%{http_code}',
                map { ('-H', "$_: $hdr->{$_}") } sort keys %$hdr);

    my $code = '';
    if (open my $ph, '-|', @cmd, $a{url}) {
        local $/;
        $code = <$ph> // '';
        close $ph;
    }
    my $rc = $? >> 8;
    $code =~ s/\D//g;
    die "curl failed (exit $rc): $a{url}\n" if $rc != 0 && !length $code;
    die "curl failed (exit $rc, HTTP $code): $a{url}\n" if $rc != 0 && $code =~ /^[45]/;

    return { status => $code || 599, headers => parse_headers($hf),
             content => $a{file} ? '' : slurp($body) };
}

# Keep only the last response block; -L may have walked through redirects.
sub parse_headers {
    my $path = shift;
    open my $fh, '<', $path or return {};
    my %h;
    while (my $l = <$fh>) {
        $l =~ s/\r?\n$//;
        %h = () , next if $l =~ m{^HTTP/};
        $h{lc $1} = $2 if $l =~ /^([^:]+):\s*(.*)$/;
    }
    close $fh;
    return \%h;
}

sub slurp {
    my $path = shift;
    open my $fh, '<', $path or return '';
    binmode $fh;
    local $/;
    return <$fh> // '';
}

# GET a JSON API endpoint, revalidating a cached copy via ETag where supported.
# soft => 1 returns undef instead of dying on 404.
sub api_get {
    my ($ctx, $url, %o) = @_;
    my $accept = $ctx->{forge} eq 'github' ? 'application/vnd.github+json' : 'application/json';
    my %hdr    = (%{ auth_headers($ctx) }, Accept => $accept);
    $hdr{'X-GitHub-Api-Version'} = '2022-11-28' if $ctx->{forge} eq 'github';

    my $cf     = cache_file($url);
    my $cached = read_json($cf);
    $hdr{'If-None-Match'} = $cached->{etag}
      if $cached && $cached->{etag} && conditional_ok();

    my $r = http_request(url => $url, headers => \%hdr);

    if ($r->{status} == 304 && $cached) {
        verbose("304 not modified, using cached $url");
        return decode_json_or_die($cached->{body}, $url, $ctx);
    }
    return undef if $o{soft} && $r->{status} == 404;
    if ($r->{status} == 403 || $r->{status} == 429) {
        my $left = $r->{headers}{'x-ratelimit-remaining'};
        die "$ctx->{forge} rate limit reached"
          . (defined $left ? " (remaining: $left)" : '')
          . ". Set a token via --token or \$GITHUB_TOKEN.\n"
          if defined $left && $left eq '0';
    }
    die "HTTP $r->{status}: $url\n" unless $r->{status} == 200;

    my $data = decode_json_or_die($r->{content}, $url, $ctx);
    if (my $etag = $r->{headers}{etag}) {
        make_dir_always(cache_dir());
        write_json($cf, { url => $url, etag => $etag, body => $r->{content} });
    }
    return $data;
}

sub decode_json_or_die {
    my ($body, $url, $ctx) = @_;
    my $data = eval { JSON::PP->new->utf8->decode($body) };
    die "Response from $url is not JSON (is this really a $ctx->{forge} instance?).\n"
      unless defined $data;
    die ucfirst($ctx->{forge}) . " error: $data->{message}\n"
      if ref $data eq 'HASH' && $data->{message};
    return $data;
}

sub cache_file {
    my $url = shift;
    return File::Spec->catfile(cache_dir(), substr(sha256_hex($url), 0, 16) . '.json');
}

# Private GitHub assets are only reachable through the API URL; curl/HTTP::Tiny
# drop the Authorization header on the cross-host redirect to storage.
sub asset_url {
    my ($ctx, $a) = @_;
    return ("$ctx->{api}/releases/assets/$a->{id}", { Accept => 'application/octet-stream' })
      if $ctx->{forge} eq 'github' && $ctx->{token} && $a->{id};
    return ($a->{browser_download_url}, {});
}

# ==============================================================================
# Verification, extraction, installation
# ==============================================================================

sub verify_download {
    my ($ctx, $file, $asset, $assets, $tmpdir) = @_;

    my ($want, $src);
    if (($asset->{digest} // '') =~ /^sha256:([0-9a-f]{64})$/i) {
        ($want, $src) = (lc $1, 'asset digest');
    }
    else {
        my ($sum) = grep { $_->{name} eq "$asset->{name}.sha256" } @$assets;
        ($sum) = grep { $_->{name} =~ /^(sha256sums?(\.txt)?|checksums?\.txt)$/i } @$assets
          unless $sum;
        return unless $sum;

        my $sf = File::Spec->catfile($tmpdir, 'sums');
        my ($u, $h) = asset_url($ctx, $sum);
        my $r = eval {
            http_request(url => $u, headers => { %{ auth_headers($ctx) }, %$h }, file => $sf);
        };
        unless ($r && $r->{status} == 200) {
            warn "Checksum file could not be downloaded, skipping verification.\n";
            return;
        }
        open my $fh, '<', $sf or return;
        while (my $l = <$fh>) {
            # "<hash>  <name>", or just "<hash>" in a single-file .sha256
            next unless my ($hash, $fn) = $l =~ /^([0-9a-fA-F]{64})(?:\s+\*?(\S+))?/;
            next if defined $fn && basename($fn) ne $asset->{name};
            ($want, $src) = (lc $hash, $sum->{name});
            last;
        }
        close $fh;
        return unless $want;
    }

    my $got = file_sha256($file);
    die "SHA256 mismatch ($src)!\n  expected: $want\n  got:      $got\n" if $got ne $want;
    info("SHA256:   ok ($src)");
}

sub file_sha256 {
    my $path = shift;
    open my $fh, '<', $path or die "Cannot read $path: $!\n";
    binmode $fh;
    my $d = Digest::SHA->new(256)->addfile($fh)->hexdigest;
    close $fh;
    return $d;
}

# Single-file compression: the asset is the binary, just squeezed. Each entry
# lists the tools that can expand it, in order of preference; the first one
# found wins. All of them write to stdout with the flags given.
sub DECOMP {
    return {
        gz   => { tools => [qw(gzip gunzip)],     args => ['-dc'] },
        bz2  => { tools => [qw(bzip2 bunzip2)],   args => ['-dc'] },
        xz   => { tools => [qw(xz unxz)],         args => ['-dc'] },
        lzma => { tools => [qw(xz unxz lzma)],    args => ['-dc'] },
        zst  => { tools => [qw(zstd unzstd)],     args => ['-dcq'] },
        lz4  => { tools => [qw(lz4 unlz4)],       args => ['-dcq'] },
    };
}

sub decompressor {
    my $ext = shift;
    my $e   = DECOMP()->{$ext} or return;
    for my $t (@{ $e->{tools} }) {
        my $p = which($t) or next;
        return { prog => $p, args => $e->{args} };
    }
    return;
}

sub decompress_to {
    my ($dec, $src, $dst) = @_;
    open my $out, '>', $dst or die "Cannot write $dst: $!\n";
    binmode $out;
    my $pid = open my $in, '-|';
    die "fork failed: $!\n" unless defined $pid;
    unless ($pid) {
        open STDIN, '<', File::Spec->devnull;
        exec $dec->{prog}, @{ $dec->{args} }, $src;
        exit 127;
    }
    binmode $in;
    my $buf;
    print {$out} $buf while read $in, $buf, 1 << 20;
    close $in;
    my $rc = $?;
    close $out or die "Error writing $dst: $!\n";
    die "Failed to decompress $src (" . basename($dec->{prog}) . " exit "
      . ($rc >> 8) . ").\n" if $rc != 0;
}

# Returns the root of the extracted tree, or undef if the asset is a bare
# binary (then the download itself is the binary).
sub extract_if_archive {
    my ($file, $tmpdir) = @_;
    my $lc = lc basename($file);

    my $out = File::Spec->catdir($tmpdir, 'x');

    if ($lc =~ /\.(tar\.gz|tgz|tar\.bz2|tbz|tar\.xz|txz|tar\.zst|tzst|tar)$/) {
        mkdir $out or die "mkdir $out: $!\n";
        system('tar', '-xf', $file, '-C', $out) == 0 or die "Failed to extract $file.\n";
    }
    elsif ($lc =~ /\.zip$/) {
        which('unzip') or die "unzip not found, but needed for $lc.\n";
        mkdir $out or die "mkdir $out: $!\n";
        system('unzip', '-q', $file, '-d', $out) == 0 or die "Failed to extract $file.\n";
    }
    elsif ($lc =~ /\.7z$/) {
        my $z = which('7zz') || which('7z') || which('7za')
          or die "7z not found, but needed for $lc.\n";
        mkdir $out or die "mkdir $out: $!\n";
        system($z, 'x', '-y', "-o$out", $file) == 0 or die "Failed to extract $file.\n";
    }
    elsif (my ($ext) = $lc =~ /\.(gz|bz2|xz|zst|lz4|lzma)$/) {
        # A single compressed file, e.g. restic_0.19.1_darwin_arm64.bz2 -
        # the binary itself, just squeezed.
        my $dec = decompressor($ext)
          or die "Cannot unpack .$ext - install " . join('/', @{ DECOMP()->{$ext}{tools} })
               . " or pick another asset with --asset/--pattern.\n";
        mkdir $out or die "mkdir $out: $!\n";
        (my $stem = basename($file)) =~ s/\.\Q$ext\E$//i;
        my $plain = File::Spec->catfile($out, $stem);
        decompress_to($dec, $file, $plain);
    }
    else {
        return undef;    # bare binary
    }
    return $out;
}

# Look for a file called $name; fall back to the single executable in the tree.
sub find_in_tree {
    my ($root, $name) = @_;

    my @found;
    my @stack = ($root);
    while (my $dir = pop @stack) {
        opendir my $dh, $dir or next;
        for my $e (readdir $dh) {
            next if $e eq '.' || $e eq '..';
            my $p = File::Spec->catfile($dir, $e);
            if (-d $p) { push @stack, $p; next }
            push @found, $p;
        }
        closedir $dh;
    }

    my ($exact) = grep { basename($_) eq $name || basename($_) eq "$name.exe" } @found;
    return $exact if $exact;

    my @exec = grep { looks_executable($_) } @found;
    return $exec[0] if @exec == 1;
    verbose("archive contains " . scalar(@found) . " files, "
            . scalar(@exec) . " of them executable");
    return undef;
}

# Magic bytes beat guessing by file size: ELF, Mach-O (incl. fat), PE, script.
sub looks_executable {
    my $path = shift;
    open my $fh, '<', $path or return 0;
    binmode $fh;
    read $fh, my $m, 4;
    close $fh;
    return 0 unless defined $m && length $m >= 2;
    return 1 if $m =~ /^\x7fELF/;
    return 1 if $m =~ /^(?:\xcf\xfa\xed\xfe|\xce\xfa\xed\xfe|\xca\xfe\xba\xbe|\xbe\xba\xfe\xca)/;
    return 1 if $m =~ /^MZ/;
    return 1 if $m =~ /^#!/;
    return 0;
}

sub install_atomic {
    my ($src, $dest) = @_;
    my $dir = dirname($dest);
    -d $dir or die "Target directory $dir does not exist.\n";
    -w $dir or die "No write permission in $dir (use sudo, or pick another --install path).\n";

    my $tmp = "$dest.new.$$";
    push @TMPFILES, $tmp;
    open my $in,  '<', $src or die "Cannot read $src: $!\n";
    open my $out, '>', $tmp or die "Cannot write $tmp: $!\n";
    binmode $in;
    binmode $out;
    my $buf;
    print {$out} $buf while read $in, $buf, 1 << 20;
    close $in;
    close $out or die "Error writing $tmp: $!\n";
    chmod 0755, $tmp;

    # rename is atomic and works even while $dest is currently running.
    rename $tmp, $dest or do {
        my $err = $!;
        unlink $tmp;
        die "Cannot replace $dest: $err\n";
    };
    @TMPFILES = grep { $_ ne $tmp } @TMPFILES;
}

sub strip_quarantine {
    my $dest = shift;
    return unless -x '/usr/bin/xattr';
    system(qq{/usr/bin/xattr -d com.apple.quarantine \Q$dest\E >/dev/null 2>&1});
}

# ==============================================================================
# Helpers
# ==============================================================================

sub info    { print "$_[0]\n" unless $opt{quiet} }
sub verbose { print "  $_[0]\n" if $opt{verbose} }
sub trim    { my $s = shift // ''; $s =~ s/^\s+|\s+$//g; return $s }

sub parse_repo {
    my $url = shift;
    $url =~ s{/+$}{};
    $url =~ s{\.git$}{};
    $url = "https://$url" unless $url =~ m{^https?://};
    my ($scheme_host, $path) = $url =~ m{^(https?://[^/]+)(/.*)?$}
      or die "Cannot parse repository URL: $url\n";
    $path //= '';
    $path =~ s{^/}{};
    # Anything before <owner>/<repo> is a base path (Gitea under a sub-path).
    my @seg = split m{/}, $path;
    die "Repository URL needs <owner>/<repo>: $url\n" if @seg < 2;
    my ($o, $r) = splice @seg, -2;
    return ($scheme_host . (@seg ? '/' . join('/', @seg) : ''), $o, $r);
}

sub uri_esc {
    my $s = shift;
    $s =~ s{([^A-Za-z0-9._~-])}{sprintf '%%%02X', ord $1}ge;
    return $s;
}

sub host_of { my ($h) = ($_[0] // '') =~ m{^https?://([^/:]+)}i; return lc($h // '') }

# Gitea and GitHub expose the same release JSON, only under different API
# roots and with different auth headers.
sub detect_forge {
    my ($b, $override) = @_;
    if (defined $override) {
        my $f = lc $override;
        die "Unknown forge '$override' (use github or gitea).\n"
          unless $f eq 'github' || $f eq 'gitea';
        return $f;
    }
    return host_of($b) =~ /(^|\.)github\.com$/ ? 'github' : 'gitea';
}

sub api_base {
    my ($b, $f) = @_;
    return "$b/api/v1" unless $f eq 'github';
    return 'https://api.github.com' if host_of($b) =~ /(^|\.)github\.com$/;
    return "$b/api/v3";    # GitHub Enterprise
}

sub resolve_token {
    my ($forge, $explicit) = @_;
    return $explicit if defined $explicit;
    my @env = $forge eq 'github' ? qw(UPD_TOKEN GITHUB_TOKEN GH_TOKEN)
            :                      qw(UPD_TOKEN GITEA_TOKEN);
    for my $k (@env) {
        return $ENV{$k} if defined $ENV{$k} && length $ENV{$k};
    }
    return '';
}

sub detect_platform {
    my $spec = shift || {};
    my ($sysname, undef, undef, undef, $machine) = uname();
    my $o = lc $sysname;
    $o = 'windows' if $o =~ /mingw|msys|cygwin|windows/;
    $o = 'darwin'  if $o =~ /darwin/;
    $o = 'linux'   if $o =~ /linux/;

    my $m = lc $machine;
    my $a = $m =~ /^(x86_64|amd64)$/          ? 'amd64'
          : $m =~ /^(aarch64|arm64)$/         ? 'arm64'
          : $m =~ /^(i[3-6]86|x86)$/          ? '386'
          : $m =~ /^armv?[5-8]/               ? 'arm'
          : $m =~ /^(ppc64le|riscv64|s390x)$/ ? $m
          :                                     $m;

    return ($spec->{os} // $o, $spec->{arch} // $a);
}

sub in_path {
    my $dir = shift;
    return grep { $_ eq $dir } split /:/, ($ENV{PATH} // '');
}

sub norm_ver { my $v = shift // ''; $v =~ s/^v//i; $v =~ s/^\s+|\s+$//g; return $v }

# Run a program and capture stdout+stderr, with a timeout and no stdin.
sub capture {
    my ($timeout, $prog, @args) = @_;
    my $pid = open my $fh, '-|';
    return '' unless defined $pid;
    unless ($pid) {
        open STDIN,  '<', File::Spec->devnull;
        open STDERR, '>&', \*STDOUT;
        exec $prog, @args;
        exit 127;
    }
    my $out = '';
    local $SIG{ALRM} = sub { kill 'TERM', $pid };
    alarm $timeout;
    { local $/; $out = <$fh> // '' }
    alarm 0;
    close $fh;
    return $out;
}

# Legacy fallback: ask the binary for its version (used when no state exists).
sub installed_version {
    my ($path, $spec) = @_;
    return '' unless -x $path;
    my $flag = $spec->{'version-flag'} // $opt{'version-flag'};
    my $out  = capture(10, $path, $flag);
    my ($v)  = $out =~ /(\d+\.\d+(?:\.\d+)*(?:[-+][\w.]+)?)/;
    return norm_ver($v);
}

sub list_releases {
    my $rels = shift;
    for my $r (@$rels) {
        printf "%-12s %s%s\n", $r->{tag_name}, substr($r->{published_at} // '', 0, 10),
          $r->{prerelease} ? '  [prerelease]' : '';
        printf "    %-32s %s\n", $_->{name}, human_size($_->{size})
          for @{ $r->{assets} || [] };
    }
}

sub human_size {
    my $n = shift // 0;
    return sprintf '%.1f MB', $n / 1024 / 1024 if $n >= 1024 * 1024;
    return sprintf '%.1f kB', $n / 1024        if $n >= 1024;
    return "$n B";
}

sub which {
    my $cmd = shift;
    for my $dir (split /:/, ($ENV{PATH} // '')) {
        my $p = File::Spec->catfile($dir, $cmd);
        return $p if -x $p && !-d $p;
    }
    return;
}

sub read_json {
    my $path = shift;
    return undef unless -f $path;
    my $body = slurp($path);
    return eval { JSON::PP->new->utf8->decode($body) };
}

sub write_json {
    my ($path, $data) = @_;
    my $tmp = "$path.$$";
    push @TMPFILES, $tmp;
    open my $fh, '>', $tmp or die "Cannot write $tmp: $!\n";
    print {$fh} JSON::PP->new->utf8->canonical->pretty->encode($data);
    close $fh or die "Cannot write $tmp: $!\n";
    rename $tmp, $path or die "Cannot update $path: $!\n";
    @TMPFILES = grep { $_ ne $tmp } @TMPFILES;
}

sub usage {
    my $rc = shift;
    print <<"USAGE";
upd - download the matching binary from the latest Gitea/GitHub release

  upd [OPTIONS] REPO-URL
  upd --all [OPTIONS]

  REPO-URL    e.g. https://git.fhi.mpg.de/mike/mgsh
                   https://github.com/sxyazi/yazi
              (or use --repo / \$UPD_REPO)

Options:
  --install PATH, -i  target directory (created if missing), e.g. ~/bin.
                      A path whose last segment is one of the binary names,
                      or an existing file, means that exact file.
                      Also \$UPD_INSTALL. Default: the directory of a
                      same-named binary in \$PATH, else ~/.local/bin
  --name A[,B...]     binary name(s) to take out of one asset, e.g.
                      "yazi,ya" installs both. Use "SRC:DST" to install
                      under a different name (default: repository name)
  --all               update every entry of the config file
  --config PATH       config file (default: ~/.config/upd/tools)
  --check             only report whether an update is available
  --tag VERSION       install a specific release ("v1.2.3" or "1.2.3")
  --pre               consider prereleases as well
  --asset NAME        exact asset name instead of auto-detection
  --pattern REGEX     select the asset by regex
  --os OS             darwin|linux|windows|freebsd (default: detected)
  --arch ARCH         amd64|arm64|386|arm (default: detected)
  --forge NAME        github|gitea (default: github for github.com hosts,
                      gitea otherwise; needed for GitHub Enterprise)
  --token TOKEN       API token for private repositories. Also read from
                      \$UPD_TOKEN, then \$GITHUB_TOKEN/\$GH_TOKEN (GitHub)
                      or \$GITEA_TOKEN (Gitea)
  --version-flag F    flag to query the version of a binary installed
                      without upd (default: --version)
  --force             install even if it is already up to date
  --list              show releases and their assets
  --dry-run           show what would happen, write nothing
  --verbose           show asset scoring and cache decisions
  --quiet             print errors only
  --timeout SEC       network timeout (default: 30)
  --help              this help

Config file (one line per tool, "#" comments):
  https://git.fhi.mpg.de/mike/mgsh  install=~/bin
  https://github.com/sxyazi/yazi    install=~/bin  name=yazi,ya
  Keys: @{[ join ', ', @SPEC_KEYS ]}

State is kept in @{[ state_dir() ]}
Exit codes: 0 ok, 1 usage, 2 error, 10 update available (--check)
USAGE
    exit $rc;
}

1;