# -*- perl -*-
# dgit
# Debian::Dgit::Core: functions common to programs from all binary packages
#
# Copyright (C)2015-2020,2022,2023,2025 Ian Jackson
# Copyright (C)2020,2025                Sean Whitton
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 3 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <https://www.gnu.org/licenses/>.

package Debian::Dgit::Core;

use strict;
use warnings;

use Carp;
use POSIX;
use Config;
use Data::Dumper;
use Debian::Dgit::I18n;

BEGIN {
    use Exporter ();
    our (@ISA, @EXPORT);

    @ISA = qw(Exporter);
    @EXPORT = qw(fail failmsg
		 waitstatusmsg failedcmd_waitstatus
		 failedcmd_report_cmd failedcmd
		 runcmd runcmd_quieten
		 shell_cmd cmdoutput cmdoutput_errok
		 git_for_each_ref
		 $failmsg_prefix
		 initdebug enabledebug enabledebuglevel
                 printdebug debugcmd
		 $printdebug_when_debuglevel $debugcmd_when_debuglevel
		 $debugprefix *debuglevel *DEBUG
		 shellquote printcmd messagequote);
}

our $printdebug_when_debuglevel = 1;
our $debugcmd_when_debuglevel = 1;

# Set this variable (locally) at the top of an `eval { }` when
#  - general code within the eval might call fail
#  - these errors are nonfatal and maybe not even errors
# This replaces `dgit: error: ` at the start of the message.
our $failmsg_prefix;

our $debugprefix;
our $debuglevel = 0;

sub initdebug ($) {
    ($debugprefix) = @_;
    open DEBUG, ">/dev/null" or confess "$!";
}

sub enabledebug () {
    open DEBUG, ">&STDERR" or confess "$!";
    DEBUG->autoflush(1);
    $debuglevel ||= 1;
}

sub enabledebuglevel ($) {
    my ($newlevel) = @_; # may be undef (eg from env var)
    confess if $debuglevel;
    $newlevel //= 0;
    $newlevel += 0;
    return unless $newlevel;
    $debuglevel = $newlevel;
    enabledebug();
}

sub printdebug {
    # Prints a prefix, and @_, to DEBUG.  @_ should normally contain
    # a trailing \n.

    # With no (or only empty) arguments just prints the prefix and
    # leaves the caller to do more with DEBUG.  The caller should make
    # sure then to call printdebug with something ending in "\n" to
    # get the prefix right in subsequent calls.

    return unless $debuglevel >= $printdebug_when_debuglevel;
    our $printdebug_noprefix;
    print DEBUG $debugprefix unless $printdebug_noprefix;
    pop @_ while @_ and !length $_[-1];
    return unless @_;
    print DEBUG @_ or confess "$!";
    $printdebug_noprefix = $_[-1] !~ m{\n$};
}

sub messagequote ($) {
    local ($_) = @_;
    s{\\}{\\\\}g;
    s{\n}{\\n}g;
    s{\x08}{\\b}g;
    s{\t}{\\t}g;
    s{[\000-\037\177]}{ sprintf "\\x%02x", ord $& }ge;
    $_;
}

sub shellquote {
    # Quote an argument list for use as a fragment of shell text.
    #
    # Shell quoting doctrine in dgit.git:
    #  * perl lists are always unquoted argument lists
    #  * perl scalars are always individual arguments,
    #    or if being passed to a shell, quoted shell text.
    #
    # So shellquote returns a scalar.
    #
    # When invoking ssh-like programs, that concatenate the arguments
    # with spaces and then treat the result as a shell command, we never
    # use the concatenation.  We pass the intended script as a single
    # parameter (which is in accordance with the above doctrine).
    my @out;
    local $_;
    defined or confess __ 'internal error' foreach @_;
    foreach my $a (@_) {
	$_ = $a;
	if (!length || m{[^-=_./:0-9a-z]}i) {
	    s{['\\]}{'\\$&'}g;
	    push @out, "'$_'";
	} else {
	    push @out, $_;
	}
    }
    return join ' ', @out;
}

sub printcmd {
    my $fh = shift @_;
    my $intro = shift @_;
    print $fh $intro." ".(shellquote @_)."\n" or confess "$!";
}

sub debugcmd {
    my $extraprefix = shift @_;
    printcmd(\*DEBUG,$debugprefix.$extraprefix,@_)
	if $debuglevel >= $debugcmd_when_debuglevel;
}

sub _us () {
    $::us // ($0 =~ m#[^/]*$#, $&);
}

sub failmsg {
    my $s = "@_";
    $s =~ s/\n\n$/\n/g;
    my $prefix;
    my $prefixnl;
    if (defined $failmsg_prefix) {
	$prefixnl = '';
	$prefix = $failmsg_prefix;
	$s .= "\n";
    } else {
	$prefixnl = "\n";
	$s = f_ "error: %s\n", "$s";
	$prefix = _us().": ";
    }
    $s =~ s/^/$prefix/gm;
    return $prefixnl.$s;
}

sub fail {
    die failmsg @_;
}

our @signames = split / /, $Config{sig_name};

sub waitstatusmsg () {
    if (!$?) {
	return __ "terminated, reporting successful completion";
    } elsif (!($? & 255)) {
	return f_ "failed with error exit status %s", WEXITSTATUS($?);
    } elsif (WIFSIGNALED($?)) {
	my $signum=WTERMSIG($?);
	return f_ "died due to fatal signal %s",
	    ($signames[$signum] // "number $signum").
	    ($? & 128 ? " (core dumped)" : ""); # POSIX(3pm) has no WCOREDUMP
    } else {
	return f_ "failed with unknown wait status %s", $?;
    }
}

sub failedcmd_report_cmd {
    my $intro = shift @_;
    $intro //= __ "failed command";
    { local ($!); printcmd \*STDERR, _us().": $intro:", @_ or confess "$!"; };
}

sub failedcmd_waitstatus {
    if ($? < 0) {
	return f_ "failed to fork/exec: %s", $!;
    } elsif ($?) {
	return f_ "subprocess %s", waitstatusmsg();
    } else {
	return __ "subprocess produced invalid output";
    }
}

sub failedcmd {
    # Expects $!,$? as set by close - see below.
    # To use with system(), set $?=-1 first.
    #
    # Actual behaviour of perl operations:
    #   success              $!==0       $?==0       close of piped open
    #   program failed       $!==0       $? >0       close of piped open
    #   syscall failure      $! >0       $?=-1       close of piped open
    #   failure              $! >0       unchanged   close of something else
    #   success              trashed     $?==0       system
    #   program failed       trashed     $? >0       system
    #   syscall failure      $! >0       unchanged   system
    failedcmd_report_cmd undef, @_;
    fail failedcmd_waitstatus();
}

sub runcmd {
    debugcmd "+",@_;
    $!=0; $?=-1;
    failedcmd @_ if system @_;
}

sub shell_cmd {
    my ($first_shell, @cmd) = @_;
    return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
}

# Runs the command in @_, but capturing its stdout and stderr.
# Prints those to our stderr only if the command fails.
sub runcmd_quieten {
    debugcmd "+",@_;
    $!=0; $?=-1;
    my @real_cmd = shell_cmd <<'END', @_;
                        set +e; output=$("$@" 2>&1); rc=$?; set -e
                        if [ $rc = 0 ]; then exit 0; fi
                        printf >&2 "%s\n" "$output"
                        exit $rc
END
    failedcmd @_ if system @real_cmd;
}

sub cmdoutput_errok {
    confess Dumper(\@_)." ?" if grep { !defined } @_;
    local $printdebug_when_debuglevel = $debugcmd_when_debuglevel;
    debugcmd "|",@_;
    open P, "-|", @_ or confess "$_[0] $!";
    my $d;
    $!=0; $?=0;
    { local $/ = undef; $d = <P>; }
    confess "$!" if P->error;
    if (!close P) { printdebug "=>!$?\n"; return undef; }
    chomp $d;
    if ($debuglevel > 0) {
	$d =~ m/^.*/;
	my $dd = $&;
	my $more = (length $' ? '...' : ''); #');
	$dd =~ s{[^\n -~]|\\}{ sprintf "\\x%02x", ord $& }ge;
	printdebug "=> \`$dd'",$more,"\n";
    }
    return $d;
}

sub cmdoutput {
    my $d = cmdoutput_errok @_;
    defined $d or failedcmd @_;
    return $d;
}

sub git_for_each_ref ($$;$) {
    my ($pattern,$func,$gitdir) = @_;
    # calls $func->($objid,$objtype,$fullrefname,$reftail);
    # $reftail is RHS of ref after refs/[^/]+/
    # breaks if $pattern matches any ref `refs/blah' where blah has no `/'
    # $pattern may be an array ref to mean multiple patterns
    $pattern = [ $pattern ] unless ref $pattern;
    my @cmd = (qw(git for-each-ref), @$pattern);
    if (defined $gitdir) {
	@cmd = ('sh','-ec','cd "$1"; shift; exec "$@"','x', $gitdir, @cmd);
    }
    open GFER, "-|", @cmd or confess "$!";
    debugcmd "|", @cmd;
    while (<GFER>) {
	chomp or confess "$_ ?";
	printdebug "|> ", $_, "\n";
	m#^(\w+)\s+(\w+)\s+(refs/[^/]+/(\S+))$# or confess "$_ ?";
	$func->($1,$2,$3,$4);
    }
    $!=0; $?=0; close GFER or confess "$pattern $? $!";
}

1;