view release on metacpan or  search on metacpan

t/IO-Die.t  view on Meta::CPAN

    return;
}

sub test_kill : Tests(8) {
    my ($self) = @_;

    my $dummy = $self->_dummy_user();

  SKIP: {
        skip 'Need to identify a “dummy” user for this test', $self->num_tests() if !$dummy;

        my $nobody_uid = ( getpwnam $dummy )[2];
        my $nobody_gid = ( getgrnam $dummy )[2];

        skip 'Need *nix OS for tests', $self->num_tests() if !$nobody_uid;
        skip 'Must be root!',          $self->num_tests() if $>;

        my $pid = fork || do { sleep 999 };

        local ( $!, $^E );

        $!  = 5;
        $^E = 5;

        my $ret = IO::Die->kill( 'TERM', $pid );

        is( $ret,    1, 'kill() returned as it should' );
        is( 0 + $!,  5, '...and it didn’t affect $!' );
        is( 0 + $^E, 5, '...and it didn’t affect $^E' );

        my $parent_pid = $$;

        pipe my $rdr, my $wtr;

        #DragonflyBSD allows an unprivileged (?) subprocess
        #to send SIGTERM to a root-owned parent process. (?!?!?)
        my $got_SIGTERM;
        local $SIG{'TERM'} = sub { $got_SIGTERM++ };

        my $parasite_pid = fork || do {
            my $at_end = t::IO::Die::Finally->new( sub { exit } );

            eval {
                close $rdr;

                $> = $nobody_uid;
                $) = $nobody_gid;
                $< = $nobody_uid;

                $!  = 5;
                $^E = 5;

                IO::Die->kill( 'TERM', $parent_pid );
            };
            if ($@) {
                print {$wtr} join( $/, 0 + $!, 0 + $^E, $@ );
            }
        };

        close $wtr;
        my @res = split m<$/>, do { local $/; <$rdr> };
        close $rdr;

        do { local $?; waitpid $parasite_pid, 0 };

        if ($got_SIGTERM) {
            skip "$^O: Unprivileged child process can SIGTERM a root-owned parent process?!?", 5;
        }

        is( $res[0], 5, 'kill() doesn’t affect $! on failure' );
        is( $res[1], 5, 'kill() doesn’t affect $^E on failure' );

        like( $res[2], qr<Kill>,        'kill() as user on a root-owned process' );
        like( $res[2], qr<TERM>,        'the signal is in the error' );
        like( $res[2], qr<$parent_pid>, 'the PID is in the error' );
    }

    return;
}

sub test_binmode : Tests(9) {
    my ($self) = @_;

    ( my $path, my $fh ) = $self->tempfile();

    open my $rfh, '<', $path;

    open my $rfh2, '<', $path;
    close $rfh2;

    my $err;

    local ( $!, $^E );

    $!  = 5;
    $^E = 5;

    ok(
        IO::Die->binmode($rfh),
        'binmode() returns true on success',
    );

    is( 0 + $!,  5, 'binmode() success left $! alone' );
    is( 0 + $^E, 5, 'binmode() success left $^E alone' );

    local $@;
    eval {
        local $SIG{'__WARN__'} = sub { };
        IO::Die->binmode($rfh2);
    };
    $err = $@;

    like( $err, qr<Binmode>, 'error type in error' );
    like( $err, qr<:raw>,    'default layer is in error' );
    like( $err, qr<layer>,   '...and it’s called “layer”' );

    my $errstr = do { local $! = Errno::EBADF(); "$!" };
    like( $err, qr<$errstr>, '...and the error is as expected' );

    is( 0 + $!,  5, 'binmode() failure left $! alone' );
    is( 0 + $^E, 5, 'binmode() failure left $^E alone' );