#
# Copyright (c) 2003-2020 Christian Jaeger, copying@christianjaeger.ch
#
# This is free software, offered under either the same terms as perl 5
# or the terms of the Artistic License version 2 or the terms of the
# MIT License (Expat version). See the file COPYING.md that came
# bundled with this file.
#

=head1 NAME

Chj::IO::CommandCommon

=head1 SYNOPSIS

 - not to be used directly -

=head1 DESCRIPTION

Common superclass ('mixin'?) for Chj::IO::Command and Chj::IO::CommandBidirectional.

=head1 NOTE

This is alpha software! Read the status section in the package README
or on the L<website|http://functional-perl.org/>.

=cut

#'

package Chj::IO::CommandCommon;

use strict;
use warnings;
use warnings FATAL => 'uninitialized';

use Chj::xperlfunc;
use Chj::xpipe;
use Carp;
use NEXT;
use Chj::singlequote 'singlequote_sh';

my %metadata;    # numified => [pid, cmd+args]

sub PID ()      {0}
sub CMD_ARGS () {1}

sub pid {
    my $self = shift;
    my $meta = $metadata{ pack "I", $self }
        || die "missing metadata";    # || []; why?
    $$meta[PID]
}

sub name {
    my $self = shift;
    my $meta = $metadata{ pack "I", $self } || die "missing metadata";
    $$meta[CMD_ARGS][0]               # XX ok? what use is it?
}

sub quotedname {
    my $self = shift;
    my $meta = $metadata{ pack "I", $self } || die "missing metadata";
    join(" ", map { singlequote_sh $_ } @{ $$meta[CMD_ARGS] })
}

sub _launch {
    my ($subname, $otherendclose, $closeinchild, $self, $cmd) = @_;
    my $maybe_env;
    if (ref($$cmd[0]) eq "HASH") {

        # env settings (since with "use threads" $ENV does not work!)
        $maybe_env = shift @$cmd;
    }
    @$cmd or die "$subname: missing cmd arguments";
    my ($readerr, $writeerr) = do {
        local $^F = 0;
        xpipe
    };
    if (my $pid = xfork) {
        $metadata{ pack "I", $self } = [$pid, $cmd];
        &$otherendclose;
        $writeerr->xclose;    #" here it's clear that it's needed."
            # close all handles that have been given for redirections?
            # or leave that to the user? the latter.
        my $err = $readerr->xcontent;
        if ($err) {
            croak(    __PACKAGE__
                    . "::$subname: could not execute "
                    . join(" ", map { singlequote_sh $_} @$cmd)
                    . ": $err");
        }
        return $self
    } else {
        &$closeinchild;
        if (defined $maybe_env) {
            my @newcmd = ("/usr/bin/env");
            my $env    = $maybe_env;
            for my $k (keys %$env) {
                die "invalid env key starting with '-': " . singlequote_sh($k)
                    if $k =~ /^-/;
                push @newcmd, "$k = $$env{$k}";
            }
            push @newcmd, @$cmd;
            $cmd = \@newcmd;
        }
        if (ref($$cmd[0]) eq "CODE") {
            my $code = shift @$cmd;
            eval {
                $code->(@$cmd);
                die "coderf did return";
            };
            $writeerr->xprint($@);    # [well serialize it?..tja..]
        } else {
            no warnings;
            exec @$cmd;
            $writeerr->xprint($!);
        }
        exit;
    }
}

sub xlaunch {
    my $self = shift;
    my ($otherend, $hdl, @cmd) = @_;
    _launch(
        "xlaunch",
        sub {
            $otherend->xclose;

            # ^important; seems like it's not cleaned up and destroyed
            # otherwise upon return from new_* methods [soon enough],
            # xcontent and the like would block outside.
        },
        sub {
            $otherend->xdup2($hdl);
        },
        $self,
        \@cmd
    )
}

sub xlaunch3 {
    my $self = shift;
    my ($in, $out, $err, @cmd) = @_;
    _launch(
        "xlaunch3",
        sub { },
        sub {
            $in->xdup2(0)  if $in;
            $out->xdup2(1) if $out;
            $err->xdup2(2) if $err;
        },
        $self,
        \@cmd
    )
}

sub wait {
    my $s = shift;
    waitpid $s->pid, 0;
    $?
}

sub finish {
    my $s = shift;
    $s->close;
    my $rv = $s->wait;
    delete $metadata{ pack "I", $s };
    $rv;
}

sub finish_nowait {
    my $s = shift;
    $s->close;
    delete $metadata{ pack "I", $s };
}

sub xfinish {    # Note: does not throw on error exit codes. Just throws
                 # on errors closing.
    my $self = shift;
    $self->xclose;
    waitpid $self->pid, 0;
    delete $metadata{ pack "I", $self };
    $?
}

sub xxfinish {    # does also throw on error exit codes.
    my $self = shift;
    $self->xclose;
    waitpid $self->pid, 0;
    if ($? == 0) {
        delete $metadata{ pack "I", $self };
    } else {
        my $qn = $self->quotedname;
        delete $metadata{ pack "I", $self };  # [XX really? or only in DESTROY?]
        if ($? & 127) {
            croak(    "xxfinish on "
                    . $qn
                    . ": subcommand has been killed with signal "
                    . ($? & 127));
        } else {
            croak(
                "xxfinish on " . $qn . ": subcommand gave error " . ($? >> 8));
        }
    }
}

sub DESTROY {    # no exceptions thrown from here
    my $self = shift;
    local ($@, $!, $?);
    if (defined $metadata{ pack "I", $self }) {
        $self->finish;
    }
    $self->NEXT::DESTROY;
}

1
