view release on metacpan or  search on metacpan

t/25_job_lifetime.t  view on Meta::CPAN

# Job -> client back-pointer lifetime. A stashed async job must keep
# the connection's control block allocated (as an inert tombstone) so
# that job methods after client destruction croak "client destroyed"
# instead of reading freed memory; and a forged job hashref must croak
# "stale job" instead of dereferencing a forged pointer.
#
# T-D1-1's pre-fix failure is a use-after-free that usually croaks
# "correctly" by luck (the stale bytes are not the magic word) — the
# deterministic pre-fix proof is the ASan demonstration referenced in
# the commit; this test locks the user-visible semantics.
use strict;
use warnings;
use Test::More;
use IO::Socket::INET;
use EV;
use EV::Gearman;

my $host = $ENV{TEST_GEARMAN_HOST} || '127.0.0.1';
my $port = $ENV{TEST_GEARMAN_PORT} || 4730;
my $probe = IO::Socket::INET->new(
    PeerAddr => $host, PeerPort => $port, Proto => 'tcp', Timeout => 1,
);
plan skip_all => "no gearmand at $host:$port" unless $probe;
close $probe;

my $func = "lifetime_$$";

# T-D1-1: async worker stashes the job, the client object is destroyed
# from inside the callback, and a later job method must croak
# "client destroyed" — with the memory kept alive by the job's
# tombstone reference, not read from freed heap.
{
    my $w = EV::Gearman->new(host => $host, port => $port);
    my $c = EV::Gearman->new(host => $host, port => $port);
    my $job;
    $w->register_function($func => { async => 1 }, sub {
        $job = $_[0];
        undef $w;               # DESTROY with a job outstanding
        EV::break;
    });
    $w->work;
    $c->on_connect(sub { $c->submit_job_bg($func, "x") });
    my $g = EV::timer 5, 0, sub { EV::break };
    EV::run;

    ok $job, 'T-D1-1: job was dispatched and stashed';
    eval { $job->complete("late") };
    like $@, qr/client destroyed/, 'T-D1-1: job method croaks after client destroy';
    undef $job;                 # releases the tombstone reference
    pass 'T-D1-1: tombstone released without crash';
    undef $c;
}

# T-D1-2: forged job hashrefs. Fork-guarded: pre-fix the _client_ptr
# variant segfaults the child (proven); post-fix all variants croak
# cleanly. No gearmand involved.
{
    my @cases = (
        ['forged with _client_ptr', sub {
            my $j = bless { handle => 'H:1', _client_ptr => 12345 },
                          'EV::Gearman::Job';
            $j->complete('x');
        }],
        ['bare forged hash', sub {
            my $j = bless { handle => 'H:1' }, 'EV::Gearman::Job';
            $j->complete('x');
        }],
        ['blessed arrayref', sub {
            my $j = bless [], 'EV::Gearman::Job';
            $j->complete('x');
        }],
    );
    for my $case (@cases) {
        my ($name, $code) = @$case;
        pipe(my $rd, my $wr) or die "pipe: $!";
        my $pid = fork();
        die "fork: $!" unless defined $pid;
        if ($pid == 0) {    # child
            close $rd;
            my $err = do {
                local $@;
                eval { $code->(); 1 } ? 'NOERROR' : $@;
            };
            print $wr ($err =~ /stale job|invalid job/ ? "OK" : "BAD:$err");
            close $wr;
            exit 0;
        }
        close $wr;
        local $/;
        my $out = <$rd> // '';