view release on metacpan or  search on metacpan

t/08-disconnect-invalidates.t  view on Meta::CPAN

use strict;
use warnings;
use lib 't/lib';
use Test::More;
use TestSSHD;
use Net::LibSSH;
use POSIX ();

# ssh_disconnect() walks session->channels and frees every one of them inside
# libssh. disconnect() used to hand that straight through, so after it every
# live Net::LibSSH::Channel held a dangling ssh_channel and every
# Net::LibSSH::SFTP an sftp_session whose channel was gone.
#
# nlss_channel_check_open() could not catch it: self->channel is non-NULL, it
# just points at freed memory. The three measured crashes were
#
#   $ssh->disconnect; $ch->exec(...)      -> SIGSEGV
#   $ssh->disconnect; undef $ch           -> SIGSEGV  (svt_free -> send_eof)
#   $ssh->disconnect; $sftp->stat(...)    -> SIGSEGV
#
# The second is the worse one: it crashes over the GC path without the caller
# ever touching the channel again, so a program that disconnects and then
# simply ends segfaults while cleaning up.
#
# The session now carries a generation counter that disconnect() bumps and
# that every channel and sftp session copies at construction. A mismatch means
# libssh has already freed the C object underneath: methods croak naming the
# session, and svt_free skips the C teardown while still releasing the session
# reference and the struct.
#
# Every scenario runs in a forked child, so a regression is a failing test
# instead of `prove` going down with a SIGSEGV.

my $srv = TestSSHD->start;
plan skip_all => 'sshd or ssh-keygen not available' unless $srv;

sub connect_session {
    my $ssh = Net::LibSSH->new;
    $ssh->option(host       => $srv->host);
    $ssh->option(port       => $srv->port);
    $ssh->option(user       => scalar getpwuid($<));
    $ssh->option(knownhosts => '/dev/null');
    $ssh->connect
        or die 'connect: ' . ($ssh->error // '') . "\n";
    $ssh->auth_publickey($srv->client_key)
        or die 'auth: ' . ($ssh->error // '') . "\n";
    return $ssh;
}

# Run $code in a forked child and check the one line it writes back against
# $expect (a string compared for equality, or a Regexp matched against it).
#
# With global_destruct => 1 the child leaves through a normal exit() so Perl's
# global destruction runs -- that is the "program calls disconnect() and then
# ends" case. Everywhere else the child uses POSIX::_exit to skip it, because
# $srv was inherited across fork() and shares the parent's sshd pid.
sub run_in_child {
    my ($name, $code, $expect, %opt) = @_;
    pipe(my $rd, my $wr) or die "pipe: $!";
    my $pid = fork();
    die "fork: $!" unless defined $pid;

    if ($pid == 0) {
        close $rd;
        my $ok = eval { print {$wr} $code->() . "\n"; 1 };
        print {$wr} 'ERROR|' . _oneline($@) . "\n" unless $ok;
        close $wr;
        if ($opt{global_destruct}) {
            # Let global destruction run, but keep this child from taking the
            # parent's sshd down with it and from emitting a second TAP plan.
            $srv->{pid} = undef;
            Test::Builder->new->no_ending(1);
            exit($ok ? 0 : 1);
        }
        POSIX::_exit($ok ? 0 : 1);
    }

    close $wr;
    my $line = <$rd>;
    close $rd;
    waitpid($pid, 0);
    my $status = $?;
    my $signal = $status & 127;

    if ($signal) {
        my $signame = $signal == 11 ? 'SIGSEGV'
                    : $signal == 6  ? 'SIGABRT'
                    :                 "signal $signal";
        fail($name);
        diag("child was killed by $signame -- disconnect() left a dangling "
            . "libssh object behind and it was used or freed afterwards.");
        return;
    }

    my $got = defined $line ? do { my $l = $line; chomp $l; $l }
                            : '(undef -- child produced no output on the pipe)';

    if (ref $expect eq 'Regexp') {
        like $got, $expect, $name;
    }
    else {