IPC-Manager

 view release on metacpan or  search on metacpan

lib/IPC/Manager/Test.pm  view on Meta::CPAN

            }
        },

        on_general_message => sub {
            my ($self, $msg) = @_;
            my $c = $msg->content;
            return unless ref($c) eq 'HASH';
            if ($c->{action} && $c->{action} eq 'crash') {
                die "general_message boom\n";
            }
        },

        on_peer_delta => sub {
            my ($self, $delta) = @_;
            # Always throw — service should survive
            die "peer_delta boom\n";
        },

        handle_request => sub {
            my ($self, $req, $msg) = @_;
            die "request boom\n" if $req->{request} eq 'crash';
            return "ok";
        },
    );

    # 1) on_interval: first call throws, second should still fire
    my $waited = 0;
    until (-e $interval_survived || $waited > 5) {
        Time::HiRes::sleep(0.1);
        $waited += 0.1;
    }
    ok(-e $interval_survived, "on_interval survived exception and kept firing");

    # 2) on_peer_delta: connect a peer — triggers an exception, but service
    #    should keep running.  The follow-up sync_request below is FIFO-
    #    serialised behind the peer-delta dispatch, so by the time the
    #    response arrives the peer_delta callback has already fired (and
    #    been intercepted).
    my $extra = ipcm_connect('ie_extra' => $handle->ipcm_info);
    $extra->disconnect;

    my $resp = $handle->sync_request(ie_svc => 'ping');
    is($resp->{response}, 'ok', "Service survived on_peer_delta exception");

    # 3) on_general_message: send a plain message that throws.  Same FIFO
    # ordering argument: by the time the next sync_request returns, the
    # general_message callback has already fired (and been intercepted).
    $handle->client->send_message(ie_svc => {action => 'crash'});

    my $resp2 = $handle->sync_request(ie_svc => 'ping');
    is($resp2->{response}, 'ok', "Service survived on_general_message exception");

    # 4) handle_request: send a request that throws — should get an error response
    my $err_resp = $handle->sync_request(ie_svc => 'crash');
    ok($err_resp->{ipcm_error}, "Got error response from crashing request");
    like($err_resp->{ipcm_error}, qr/request boom/, "Error response contains exception details");
    ok(!defined $err_resp->{response}, "Response is undef on error");

    # 5) Service still works after all the exceptions
    my $resp3 = $handle->sync_request(ie_svc => 'ping');
    is($resp3->{response}, 'ok', "Service still alive after all intercepted errors");

    $handle = undef;
}

sub test_watch_pids {
    # Verifies that a service terminates when a watched PID exits.
    # Uses watch_pids => [$$] by watching the parent.  The parent forks a
    # temporary child to own the IPC bus while the service runs; the parent
    # then exits that scope so the service sees the pid die.

    my $marker_dir = File::Temp::tempdir(CLEANUP => 1);
    my $cleanup_file = File::Spec->catfile($marker_dir, 'wp_cleanup');
    my $ready_file   = File::Spec->catfile($marker_dir, 'wp_ready');

    # Fork a child that acts as the watched process.  It starts the service
    # with watch_pids pointing at itself, verifies the service works, then
    # exits — causing the service to detect the pid death.
    my $child = fork // die "fork: $!";
    if ($child == 0) {
        my $handle = ipcm_service(
            'wp_svc',
            class      => 'IPC::Manager::Service',
            watch_pids => [$$],

            on_cleanup => sub {
                my $self = shift;
                open my $fh, '>', $cleanup_file or die "open: $!";
                print $fh "$$\n";
                close $fh;
            },

            handle_request => sub {
                my ($self, $req, $msg) = @_;
                return "ok";
            },
        );

        my $resp = $handle->sync_request(wp_svc => 'ping');
        # Signal parent we are ready
        open my $fh, '>', $ready_file or die "open: $!";
        print $fh "$resp->{response}\n";
        close $fh;

        # Exit — the service watches our pid and should terminate
        exit(0);
    }

    # Wait for child to signal readiness
    my $waited = 0;
    until (-e $ready_file || $waited > 10) {
        Time::HiRes::sleep(0.1);
        $waited += 0.1;
    }
    ok(-e $ready_file, "Child started service and sent request");

    if (-e $ready_file) {
        open my $fh, '<', $ready_file or die "open: $!";
        chomp(my $resp = <$fh>);
        close $fh;
        is($resp, 'ok', "Service responded before watched pid died");

lib/IPC/Manager/Test.pm  view on Meta::CPAN

        $waited += 0.1;
    }
    ok(-e $sig_file, "Service received signal from Spawn::terminate");
}

sub test_cleave {
    my $guard = ipcm_spawn(guard => 0);
    my $info  = "$guard";

    my $original_pid = $guard->pid;
    is($original_pid, $$, "Spawn pid is ours before cleave");

    my $cleave_result = $guard->cleave;

    if ($cleave_result) {
        # Parent — cleave_result is the new owner PID
        ok($cleave_result != $$, "Cleave returned new PID to parent");
        isnt($guard->pid, $$, "Spawn ownership transferred");

        # Connect, send a message, verify the bus still works
        my $con = ipcm_connect('cleave_test' => $info);
        ok($con, "Can connect to bus after cleave");
        $con->disconnect;

        # Kill the cleaved process and clean up
        kill('TERM', $cleave_result);
        waitpid($cleave_result, 0);

        $guard->unspawn;
    }
    else {
        # Child (new owner) — just exit.  Don't unspawn; the parent
        # still needs the route to verify the bus works.
        exit(0);
    }
}

sub test_request_error_generic {
    my $handle = ipcm_service(
        'err_generic_svc',
        class          => 'IPC::Manager::Service',
        handle_request => sub {
            my ($self, $req, $msg) = @_;
            die "secret internal failure\n" if $req->{request} eq 'crash';
            return "ok";
        },
    );

    # Normal request works
    my $resp = $handle->sync_request(err_generic_svc => 'hello');
    is($resp->{response}, 'ok', "Normal request succeeds");
    ok(!$resp->{ipcm_error}, "No error on normal request");

    # Crashing request returns a generic error (default: expose_error_details off)
    my $err_resp = $handle->sync_request(err_generic_svc => 'crash');
    ok($err_resp->{ipcm_error}, "Error response has ipcm_error flag");
    is($err_resp->{ipcm_error}, 'Internal service error', "Error message is generic");
    unlike($err_resp->{ipcm_error}, qr/secret/, "Internal details not exposed");
    ok(!defined $err_resp->{response}, "Response is undef on error");

    # Service is still alive after the error
    my $resp2 = $handle->sync_request(err_generic_svc => 'hello');
    is($resp2->{response}, 'ok', "Service still works after error");

    $handle = undef;
}

sub test_request_error_detailed {
    my $handle = ipcm_service(
        'err_detail_svc',
        class                => 'IPC::Manager::Service',
        expose_error_details => 1,
        handle_request       => sub {
            my ($self, $req, $msg) = @_;
            die "detailed failure info\n" if $req->{request} eq 'crash';
            return "ok";
        },
    );

    # Crashing request returns the actual exception text
    my $err_resp = $handle->sync_request(err_detail_svc => 'crash');
    ok($err_resp->{ipcm_error}, "Error response has ipcm_error flag");
    like($err_resp->{ipcm_error}, qr/detailed failure info/, "Error exposes exception details");
    ok(!defined $err_resp->{response}, "Response is undef on error");

    # Service is still alive
    my $resp = $handle->sync_request(err_detail_svc => 'hello');
    is($resp->{response}, 'ok', "Service still works after detailed error");

    $handle = undef;
}

sub test_post_fork_hook {
    # Verifies that the post_fork_hook allows a double-fork pattern where the
    # middle process goes off to do its own work and the grandchild becomes
    # the service.

    my $marker_dir   = File::Temp::tempdir(CLEANUP => 1);
    my $middle_file  = File::Spec->catfile($marker_dir, 'middle_pid');
    my $service_file = File::Spec->catfile($marker_dir, 'service_pid');

    my $handle = ipcm_service(
        'pfh_svc',
        class => 'IPC::Manager::Service',

        post_fork => sub {
            my $self = shift;

            my $pid = fork // die "Could not fork in post_fork: $!";

            if ($pid) {
                # Middle process: write our PID and exit
                open my $fh, '>', $middle_file or die "open: $!";
                print $fh "$$\n";
                close $fh;
                POSIX::_exit(0);
            }

            # Grandchild: return to become the service
        },

        on_start => sub {
            my $self = shift;
            open my $fh, '>', $service_file or die "open: $!";
            print $fh "$$\n";
            close $fh;
        },

        handle_request => sub {
            my ($self, $req, $msg) = @_;
            return "pfh_$$";
        },
    );

    # Wait for the middle process marker
    my $waited = 0;
    until (-e $middle_file || $waited > 10) {
        Time::HiRes::sleep(0.1);
        $waited += 0.1;
    }
    ok(-e $middle_file, "Middle process ran and wrote marker");

    # The service should be functional
    my $resp = $handle->sync_request(pfh_svc => 'ping');
    ok($resp->{response}, "Service responded");

    # Wait for service on_start marker
    $waited = 0;
    until (-e $service_file || $waited > 10) {
        Time::HiRes::sleep(0.1);
        $waited += 0.1;
    }
    ok(-e $service_file, "Service on_start ran");

    # Read the PIDs
    open my $mfh, '<', $middle_file or die "open: $!";
    chomp(my $middle_pid = <$mfh>);
    close $mfh;

    open my $sfh, '<', $service_file or die "open: $!";
    chomp(my $svc_pid = <$sfh>);
    close $sfh;

    my $handle_svc_pid = $handle->service_pid;

    # The service PID should be the grandchild, not the middle process
    isnt($svc_pid, $middle_pid, "Service PID ($svc_pid) differs from middle process PID ($middle_pid)");
    is($handle_svc_pid, $svc_pid, "Handle reports correct service PID");

    # Verify the response came from the grandchild
    like($resp->{response}, qr/^pfh_\d+$/, "Response includes a PID");
    is($resp->{response}, "pfh_$svc_pid", "Response came from the grandchild service process");

    # Reap the middle process so it doesn't linger as a zombie
    waitpid($middle_pid, 0) if $middle_pid;

    # child_pid on the handle is the first-fork pid from ipcm_service.
    # In this daemonize case that is the middle process, which has now
    # exited - so it is no longer alive.
    my $cpid = $handle->child_pid;
    ok($cpid, "Handle carries a child_pid");
    is($cpid, $middle_pid, "child_pid == first-fork (middle) pid");
    ok(!kill(0, $cpid), "First-fork pid no longer alive after daemonize");

    $handle = undef;
}

sub test_child_pid {
    # Basic accessor: handle returned by ipcm_service carries the
    # first-fork pid, and it is alive while the service is up.

    my $handle = ipcm_service(
        'child_pid_svc',
        class          => 'IPC::Manager::Service',
        handle_request => sub { return "ok" },
    );

    my $cpid = $handle->child_pid;
    ok($cpid, "Handle has child_pid");
    like($cpid, qr/^\d+$/, "child_pid is a positive integer");
    ok(kill(0, $cpid), "child_pid is alive while service is up");

    # No post_fork_hook: first-fork pid == service pid
    is($handle->service_pid, $cpid, "child_pid == service_pid (no post_fork_hook)");

    $handle = undef;
}

sub test_child_pid_nested {
    # Nested ipcm_service from inside a running service should also
    # stamp child_pid onto the peer it returns.

    my $outer = ipcm_service(
        'cp_outer',
        class    => 'IPC::Manager::Service',
        on_start => sub {
            my $self = shift;

            my $peer = ipcm_service(
                'cp_inner',
                class          => 'IPC::Manager::Service',
                handle_request => sub { return "inner_ok" },
            );

            $self->{_inner_cpid} = $peer->child_pid;
        },

        handle_request => sub {
            my ($self, $req, $msg) = @_;
            return $self->{_inner_cpid};
        },
    );

    my $resp = $outer->sync_request(cp_outer => 'cpid?');
    my $inner_cpid = $resp->{response};
    ok($inner_cpid, "Inner peer has child_pid");
    like($inner_cpid, qr/^\d+$/, "Inner child_pid is a positive integer");

    $outer = undef;
}

sub test_child_pid_unset {
    # Handles/peers constructed outside ipcm_service's spawn path have
    # child_pid undef.

    require IPC::Manager::Service::Handle;
    my $h = IPC::Manager::Service::Handle->new(
        service_name => 'nope',
        ipcm_info    => 'fake',
    );
    is($h->child_pid, undef, "Bare handle has undef child_pid");
}

sub test_child_pid_interpose {
    # post_fork_hook interpose pattern: first-fork pid stays alive as
    # the long-lived "wrapper", and a deeper fork runs the service loop.
    # child_pid should equal the wrapper (first-fork) pid, and that pid
    # should stay alive as long as the service is up.

    my $marker_dir   = File::Temp::tempdir(CLEANUP => 1);
    my $wrapper_file = File::Spec->catfile($marker_dir, 'wrapper_pid');
    my $service_file = File::Spec->catfile($marker_dir, 'service_pid');

    my $handle = ipcm_service(
        'cp_interpose_svc',
        class => 'IPC::Manager::Service',

        post_fork => sub {
            my $self = shift;

            my $pid = fork // die "Could not fork in post_fork: $!";

            if ($pid) {
                # Wrapper: record our pid, stay alive, wait for service to exit.
                open my $fh, '>', $wrapper_file or die "open: $!";
                print $fh "$$\n";
                close $fh;
                waitpid($pid, 0);
                POSIX::_exit(0);
            }

            # Deeper child: return to become the service
        },

        on_start => sub {
            open my $fh, '>', $service_file or die "open: $!";
            print $fh "$$\n";
            close $fh;
        },

        handle_request => sub { return "ok" },
    );

    my $waited = 0;
    until (-e $wrapper_file || $waited > 10) {
        Time::HiRes::sleep(0.1);
        $waited += 0.1;
    }
    ok(-e $wrapper_file, "Wrapper process ran and wrote marker");

    # Drive one request so service is definitely up
    my $resp = $handle->sync_request(cp_interpose_svc => 'ping');
    is($resp->{response}, 'ok', "Service responded");

    $waited = 0;
    until (-e $service_file || $waited > 10) {
        Time::HiRes::sleep(0.1);
        $waited += 0.1;
    }
    ok(-e $service_file, "Service on_start ran");

    open my $wfh, '<', $wrapper_file or die "open: $!";
    chomp(my $wrapper_pid = <$wfh>);
    close $wfh;

    open my $sfh, '<', $service_file or die "open: $!";
    chomp(my $svc_pid = <$sfh>);
    close $sfh;

    my $cpid = $handle->child_pid;
    is($cpid, $wrapper_pid, "child_pid == wrapper (first-fork) pid");
    isnt($cpid, $svc_pid, "Wrapper pid differs from service pid");
    ok(kill(0, $cpid), "Wrapper pid alive while service is up");

    $handle = undef;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

IPC::Manager::Test - Reusable protocol-agnostic test suite for IPC::Manager

=head1 DESCRIPTION

This module provides a set of standard tests that verify the correctness of
an L<IPC::Manager> protocol implementation.  Each test is an ordinary method
whose name begins with C<test_>; they are discovered automatically by
C<tests()> and executed by C<run_all()>.

Protocol test files typically look like:

    use Test2::V1 -ipP;
    use Test2::IPC;
    use IPC::Manager::Test;
    IPC::Manager::Test->run_all(protocol => 'AtomicPipe');
    done_testing;

=head1 METHODS

=over 4

=item IPC::Manager::Test->run_all(protocol => $PROTOCOL)

Run every C<test_*> method as an isolated subtest.  Each test is forked into
its own process so that failures and resource leaks cannot affect sibling
tests.  C<protocol> is required and is set as the default protocol via
C<ipcm_default_protocol> before any test runs.

=item @names = IPC::Manager::Test->tests

Returns a sorted list of all C<test_*> method names defined on the class (or
a subclass).  Used internally by C<run_all>.

=item IPC::Manager::Test->test_generic

Tests the low-level IPC bus: spawning a store, connecting multiple clients,
sending point-to-point and broadcast messages, verifying message contents and
ordering, and checking that per-client statistics are accurate on disconnect.

=item IPC::Manager::Test->test_simple_service

Tests C<ipcm_service> at the single-service level: starts a named service,
sends a request to it from the parent process, verifies the service echoes a
response back with the correct content, and confirms that both sides observed
the exchange.

lib/IPC/Manager/Test.pm  view on Meta::CPAN

the service detected the death and ran its cleanup callback.

=item IPC::Manager::Test->test_spawn_terminate_with_signal

Tests that C<< Spawn::terminate >> sends a signal to service processes when
the spawn has a signal configured.  Verifies the service's C<on_sig> handler
fires for the delivered signal.

=item IPC::Manager::Test->test_cleave

Tests C<< Spawn::cleave >> by double-forking ownership of the IPC bus away
from the current process.  Verifies the parent receives the new owner's PID,
spawn ownership transfers, and the bus remains functional.

=back

=item IPC::Manager::Test->test_request_error_generic

Tests that an exception in C<handle_request> sends an error response with
C<ipcm_error> set to a generic message (C<"Internal service error">) and
C<response> set to undef.  Verifies the service continues operating after
the error.  This is the default behaviour (C<expose_error_details> off).

=item IPC::Manager::Test->test_request_error_detailed

Tests that with C<< expose_error_details => 1 >> an exception in
C<handle_request> sends an error response whose C<ipcm_error> contains the
actual exception text.  Verifies the service continues operating.

=item IPC::Manager::Test->test_post_fork_hook

Tests the C<post_fork> callback (which drives C<post_fork_hook>).  The callback
performs a double-fork: the middle process writes a marker file and exits, while
the grandchild returns and becomes the service.  The test verifies that the
middle process ran, the service is functional (responds to requests), and the
PID reported by the handle matches the grandchild rather than the middle
process.  Also verifies C<< $handle->child_pid >> equals the first-fork
(middle) pid, which has exited after daemonization.

=item IPC::Manager::Test->test_child_pid

Tests that C<< $handle->child_pid >> is set to a live pid after
C<ipcm_service> spawns a simple service, and that first-fork pid equals
service pid when no C<post_fork_hook> is in play.

=item IPC::Manager::Test->test_child_pid_nested

Tests that the peer returned by a nested C<ipcm_service> call (from inside a
running service) also carries C<child_pid>.

=item IPC::Manager::Test->test_child_pid_unset

Tests that C<child_pid> is C<undef> on a handle constructed outside the
C<ipcm_service> spawn path.

=item IPC::Manager::Test->test_child_pid_interpose

Tests the interpose C<post_fork_hook> pattern: the parent becomes a
long-lived wrapper and the deeper child runs the service loop.  Verifies
C<child_pid> equals the wrapper pid, differs from the service pid, and that
the wrapper pid stays alive for as long as the service is up.

=back

=head1 SOURCE

The source code repository for IPC::Manager can be found at
L<https://github.com/exodist/IPC-Manager>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright Chad Granum E<lt>exodist7@gmail.comE<gt>.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L<https://dev.perl.org/licenses/>

=cut