package IPC::Manager::Service::State;
use strict;
use warnings;

use Carp qw/croak/;
use IPC::Manager::Util qw/require_mod clone_io/;
use IPC::Manager::Serializer::JSON();
use Long::Jump qw/setjump longjump havejump/;

use POSIX();

my $base_0 = $0;
my $service_inst;

my $_post_exec_run = sub { 255 };

sub import {
    my $class = shift;

    my $json = shift @ARGV;

    my $params = IPC::Manager::Serializer::JSON->deserialize($json);
    my $exec = delete $params->{exec} // {};

    $params->{orig_io} = {
        stderr => clone_io('>&', \*STDERR),
        stdout => clone_io('>&', \*STDOUT),
        stdin  => clone_io('<&', \*STDIN),
    };

    my $svc_class = require_mod($params->{class} // 'IPC::Manager::Service');
    my $new_inst = $svc_class->new(%$params);

    my $exit;
    my $code = sub { _ipcm_service(%$params, new_inst => $new_inst); $exit = 0 };

    if ($exec->{stay_in_begin}) {
        $exit = 255;
        $_post_exec_run = sub { $exit };
        $code->();
    }
    else {
        $_post_exec_run = $code;
    }
}

sub ipcm_worker {
    my ($name, $cb) = @_;

    croak "ipcm_service_worker() can only be called from inside a service"
        unless $service_inst && ref($service_inst) ne 'CODE';

    my $pid = fork // die "Could not fork: $!";
    if ($pid) {
        $service_inst->register_worker($name => $pid);
        return $pid;
    }

    $0 = "$0 $name";

    $service_inst = $cb;
    croak "ipcm_worker: no IPCM_SERVICE jump point on the stack (worker invoked outside a running service?)"
        unless havejump 'IPCM_SERVICE';
    longjump IPCM_SERVICE => ();
    die "This should not be reachable";
}

sub ipcm_service {
    my ($name, @args) = @_;

    my $return_handle = defined(wantarray) ? 1 : 0;

    my %params;
    if (@args == 1 && ref($args[0]) eq 'CODE') {
        $params{class}  = 'IPC::Manager::Service';
        $params{on_all} = $args[0];
    }
    elsif (@args == 2 && ref($args[0]) eq 'HASH' && ref($args[1]) eq 'CODE') {
        %params         = %{$args[0]};
        $params{class}  = 'IPC::Manager::Service';
        $params{on_all} = $args[1];
    }
    else {
        %params = @args;
    }

    my $skip_role_checks = delete $params{skip_role_checks};

    my $exec = delete $params{exec};

    $params{name} = $name;

    $params{orig_io} //= $service_inst ? $service_inst->orig_io : {
        stderr => clone_io('>&', \*STDERR),
        stdout => clone_io('>&', \*STDOUT),
        stdin  => clone_io('<&', \*STDIN),
    } unless $exec;

    if ($service_inst && !$params{redirect}) {
        if (my $redir = $service_inst->redirect) {
            $params{redirect} = $redir unless defined($redir->{inherit}) && !$redir->{inherit};
        }
    }

    my $new_ipcm = delete $params{new_ipcm};

    my $handle_params = delete $params{handle_params} // {};
    if ($params{ipcm_info}) {
        croak "'new_ipcm' and 'ipcm_info' may not be combined" if $new_ipcm;
    }
    else {
        if ($service_inst && !$new_ipcm) {
            $handle_params->{_peer} = 1;
            $params{ipcm_info} = $service_inst->ipcm_info;
        }
        elsif ($return_handle) {
            require IPC::Manager;
            $handle_params->{spawn} = IPC::Manager::ipcm_spawn();
            $params{ipcm_info}      = $handle_params->{spawn}->info;
            $params{watch_pids}     = [$$];
        }
        else {
            croak "Cannot be called in void context without providing 'ipcm_info'";
        }
    }

    my $class = require_mod($params{class} // 'IPC::Manager::Service');

    croak "'$class' does not implement the 'IPC::Manager::Role::Service' role"
        unless $skip_role_checks || Role::Tiny::does_role($class, 'IPC::Manager::Role::Service');

    my $new_inst = $class->new(%params);

    $new_inst->pre_fork_hook();

    # Forward the stay_in_begin flag (only) into the child's params.
    # The 'exec' key is otherwise stripped on the parent side and the
    # child needs to know whether import() should call _ipcm_service
    # synchronously at BEGIN time (stay_in_begin = 1) or stash the
    # closure for the -e snippet to fire at runtime.
    $exec->{json} = IPC::Manager::Serializer::JSON->serialize({
        %params,
        exec => { stay_in_begin => $exec->{stay_in_begin} ? 1 : 0 },
    }) if $exec;

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

    # In parent
    if ($pid) {
        return unless $return_handle || $exec;

        my $out;

        if (delete $handle_params->{_peer}) {
            $out = $service_inst->peer($params{name}, %$handle_params);
        }
        else {
            $out = $new_inst->handle(%$handle_params, name => "service_parent_$$");
        }

        my $timeout = $params{timeout} || 10;

        croak "Timeout waiting for service to come up after ${timeout}s"
            unless $out->ready($timeout);

        $out->_set_child_pid($pid);

        return $out;
    }

    $new_inst->post_fork_hook();

    if ($exec) {
        my $cmd = $exec->{cmd} // [];
        my $json = $exec->{json};

        exec(
            $^X,
            @{$cmd},
            "-M${ \__PACKAGE__ }",
            "-e" => "exit(${ \__PACKAGE__ }\::_post_exec_run())",
            $json,
        );
    }

    @_ = (%params, new_inst => $new_inst);
    goto \&_ipcm_service;
}

sub _post_exec_run { $_post_exec_run->() }

sub _ipcm_service {
    my %params = @_;

    my $name = $params{name};

    my $new_inst = delete $params{new_inst};
    $new_inst->set_pid($$);

    $0 = delete($params{rebase_0}) ? "$base_0 $name" : "$0 $name";

    # Figure out if we already had a service
    my $prev_service = $service_inst ? 1 : 0;

    # Set the new instance as the current one
    $service_inst = $new_inst;

    # If a service is already running on the stack, unwind back to its
    # setjump so the new $service_inst replaces it rather than nesting
    # another run loop on top.
    if ($prev_service) {
        croak "ipcm_service: previous service detected but no IPCM_SERVICE jump point on the stack"
            unless havejump 'IPCM_SERVICE';
        longjump IPCM_SERVICE => ();
        die "This should not be reachable";
    }

    # Top-level service: enter the setjump loop.  ipcm_worker and nested
    # ipcm_service() calls from inside the running service both unwind
    # back here via `longjump IPCM_SERVICE`, after which the loop re-runs
    # setjump() with $service_inst pointing at the replacement.
    #
    # If the running service consumes Role::Service with
    # run_returns_to_caller() true, run() returning normally stores the
    # exit code in $returning_exit and lets _ipcm_service return it to
    # its caller (used by the exec.stay_in_begin = 1 BEGIN-return path).
    my $returning_exit;
    while (1) {
        my $jumped = setjump IPCM_SERVICE => sub {
            # Snapshot: $service_inst can be replaced before this block exits.
            my $using_service = $service_inst;

            my $is_code       = ref($using_service) eq 'CODE';
            my $do_posix_exit = !$is_code && $using_service->use_posix_exit;

            my $exit;
            my $ok = eval {
                if ($is_code) {
                    $exit = $using_service->();
                }
                else {
                    $exit = $using_service->run() // 0;
                }
                1;
            };
            warn $@ unless $ok;

            if (   $ok
                && !$is_code
                && $using_service->can('run_returns_to_caller')
                && $using_service->run_returns_to_caller)
            {
                $returning_exit = \$exit;
                return;
            }

            my $code = $ok ? $exit : 255;
            if ($is_code) {
                exit($code);
            }
            else {
                $do_posix_exit ? POSIX::_exit($code) : exit($code);
            }
        };

        # setjump returns undef if the sub returned normally.  Two
        # cases reach here: (a) the run-returns-to-caller opt-in
        # stored an exit in $returning_exit -- break and let
        # _ipcm_service return it; (b) the (unexpected) scope-leak
        # path -- fall through to the warn + _exit(255) below.  Any
        # other value means longjump was called and we re-run setjump
        # with the updated $service_inst.
        last unless $jumped;
    }

    return $$returning_exit if $returning_exit;

    # This should not be reachable....
    eval { warn "Scope leak in service '$name' process $$" };
    POSIX::_exit(255);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

IPC::Manager::Service::State - Internal implementation of ipcm_service and ipcm_worker

=head1 DESCRIPTION

This module is the implementation backing the C<ipcm_service> and
C<ipcm_worker> exports provided by L<IPC::Manager>.  It also acts as its
own C<-M> boot module when a service is started via C<exec>: in that case
Perl loads this module with C<-MIPC::Manager::Service::State>, which reads
the serialised service parameters from C<@ARGV> and arranges for the service
to start running once the Perl runtime exits C<BEGIN>.

Callers should interact with this module only through the exports of
L<IPC::Manager>; direct use is not part of the public API.

=head1 EXPORTS

These functions are re-exported through L<IPC::Manager>; see that module for
the primary documentation.

=over 4

=item $handle = ipcm_service($name, \&on_all_callback)

=item $handle = ipcm_service($name, \%params, \&on_all_callback)

=item $handle = ipcm_service($name, %params)

Fork a new service process.  The return value depends on calling context and
where the call is made:

=over 4

=item *

When called outside a service, returns an
L<IPC::Manager::Service::Handle> connected to a newly spawned IPC bus.
C<ipcm_service> blocks until the service signals that it is ready.

=item *

When called from B<inside> a running service (from a service callback), the
new service shares the existing IPC bus.  Returns an
L<IPC::Manager::Service::Peer> that the calling service can use to send
requests to the nested service.  C<ipcm_service> blocks until the nested
service is ready.

=item *

When called in B<void context> from inside a service, the nested service is
started but C<ipcm_service> returns immediately without waiting for the
service to be ready.  The caller is responsible for waiting before sending
messages; see L<IPC::Manager/ipcm_service> for details.

=back

=item $pid = ipcm_worker($name, \&callback)

Fork a worker process from inside a running service.  The worker runs
C<\&callback> in place of a normal service loop and is registered with the
parent service so that it is reaped when the service exits.  Dies if called
outside a service.

Returns the PID of the newly forked worker to the parent; in the worker
process the callback is invoked and the function never returns.

=back

=head1 EXEC AND STAY-IN-BEGIN MODE

When C<ipcm_service> is invoked with an C<exec> parameter, the freshly-forked
child does not re-enter the in-process service loop directly; instead it
C<exec>s a new perl with C<-MIPC::Manager::Service::State> and a serialised
parameter blob on C<@ARGV>.  Perl loads this module at boot, which means
C<import> runs at C<BEGIN> time of the C<-e> snippet that follows on the
command line.

By default C<import> stashes a closure on the module so that the service
starts only once the Perl runtime exits C<BEGIN> and runs the C<-e> snippet,
which calls C<_post_exec_run>.  This is the right shape for normal services:
the interpreter is fully past BEGIN by the time the service event loop spins
up, so anything the loop does happens in a "running program" context.

The C<exec =E<gt> { stay_in_begin =E<gt> 1 }> variant flips that: C<import>
calls C<_ipcm_service> synchronously, while the C<-M> hook is still on the
stack and Perl has not yet finished parsing the C<-e> entry script.  This
mode exists for services that need to keep the interpreter in
"parsing the entry script" state while the service loop runs -- typically so
they can, on some incoming request, hand the entry script's source off to a
source filter like L<goto::file> and let the test (or other target) compile
in C<main> with a shallow stack.

For that hand-off to be usable, C<_ipcm_service> must eventually return all
the way back through C<import> and out of BEGIN, instead of calling C<exit>
once C<run()> finishes.  Services that want this behaviour B<must> consume
L<IPC::Manager::Role::Service> and override C<run_returns_to_caller> to
return true.  The combination -- C<exec.stay_in_begin = 1> on the launching
side, C<run_returns_to_caller> true on the consuming class -- is the
supported pattern for "preload services that hand off to a forked,
freshly-C<goto::file>'d test grandchild".  The Test2-Harness preload service
is the canonical example consumer.

For every other service the default (C<run_returns_to_caller> returning C<0>)
keeps the existing "always exit after C<run()> returns" behaviour.

=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
