File Coverage

blib/lib/Test/NoTty.pm

Criterion	Covered	Total	%
statement	31	45	68.8
branch	9	22	40.9
condition	3	5	60.0
subroutine	5	6	83.3
pod	1	1	100.0
total	49	79	62.0

#!perl

use strict;
use warnings;

package Test::NoTty;

use parent qw(Exporter);
use POSIX qw(setsid _exit WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);

our @EXPORT = 'without_tty';
our $VERSION = '0.01';

sub without_tty(&@) {
    my ($code, @args) = @_;
    pipe my $reader, my $writer
        or die "Can't pipe: $!";

    # So, "how to detach from your controlling terminal" is a subset of the "how
    # to start a daemon" dance. In (reverse) you
    #
    # 2) Call setsid when your process is not a process group leader.
    #    This detaches you from any controlling terminal
    # 1) fork, as the child process won't be a process group leader.
    #    (Your parent might be, and certainly will be if run interactively)
    #
    # The fun and games ensues because the code needs to run in the child, but
    # really we'd like to fake it (as much as possible) that the code is running
    # in the parent.

    # I'm not quite sure if how we deal with this correctly. Of if we really
    # can. A child process is really supposed to call `exec` or `_exit`. But
    # there's a chance here that we want to have real output

    STDOUT->flush;
    STDERR->flush;
    my $pid = fork;
    die "Couldn't fork: $!"
        unless defined $pid;

    unless ($pid) {
        # We are in the child

        # We use the pipe to send (and rethrow) any regular exception.
        # By implication, we can't deal with exception objects.
        close $reader;

        eval {
            die "setsid failed: $!"
                unless setsid;

            # Likewise, a limitation is that the only function return value we
            # can easily support is an integer process exit code:
            my $exitcode = $code->(@args);
            STDOUT->flush;
            STDERR->flush;
            _exit($exitcode // 0);
        };

        # If you get here it's an error:
        print $writer $@
            or warn "print to error message handle failed: $!";
        close $writer
            or warn "close error message handle failed: $!";
        STDOUT->flush;
        STDERR->flush;
        kill 'ABRT', $$;
    }
    # We are in the parent

    # Try very hard to relay signals to the child. For example, if it sleeps or
    # churns forever, we want ^C to interrupt it, not take us out but leave it
    # running in the background. This isn't foolproof, but seems better than
    # doing nothing:

    my @sigs = grep { !/^__/ && !/^CH?LD$/ } keys %SIG;
    local @SIG{@sigs};
    for my $sig (@sigs) {
        $SIG{$sig} = sub {
            kill $sig, $pid
                or warn "kill $sig $pid failed: $!";
        };
    }
    close $writer;

    # "Setup" done. Let's see what the child tried to tell us:
    waitpid $pid, 0
        or die "waitpid $pid, 0 failed: $!";
    local $/;
    my $error = <$reader>;
    die $error
        if length $error;

    # This is the common case:
    return WEXITSTATUS(${^CHILD_ERROR_NATIVE})
        if WIFEXITED(${^CHILD_ERROR_NATIVE});

    die "Code called by without_tty() died with signal " . WTERMSIG(${^CHILD_ERROR_NATIVE})
        if WTERMSIG(${^CHILD_ERROR_NATIVE});

    die "Code called by without_tty() exited with unknown status ${^CHILD_ERROR_NATIVE}";
}

1;

__END__