view release on metacpan or  search on metacpan

lib/Developer/Dashboard/PageRuntime.pm  view on Meta::CPAN

    Developer::Dashboard::Folder->configure(
        paths   => $self->{paths},
        aliases => $self->{aliases},
    );
    $sandpit ||= $self->_new_sandpit(
        state           => $state,
        runtime_context => $runtime,
    );

    my $package = $sandpit->{package} || die 'Missing sandpit package';
    my $wrapped_code = $self->_code_header($state) . $code;
    my @returns;
    local $Developer::Dashboard::Zipper::AJAX_CONTEXT = {
        allow_transient_urls => (
            defined $ENV{DEVELOPER_DASHBOARD_ALLOW_TRANSIENT_URLS}
              && $ENV{DEVELOPER_DASHBOARD_ALLOW_TRANSIENT_URLS} =~ /\A(?:1|true|yes|on)\z/i
        ) ? 1 : 0,
        page_id      => $args{page} && ref( $args{page} ) ? ( $args{page}->as_hash->{id} || '' ) : '',
        runtime_root => (
              $args{source}
           && $args{source} eq 'skill'
           && $args{page}
           && ref( $args{page} ) eq 'Developer::Dashboard::PageDocument'
           && ref( $args{page}->as_hash->{meta} ) eq 'HASH'
           && ( $args{page}->as_hash->{meta}{skill_path} || '' ) ne ''
        )
        ? ( $args{page}->as_hash->{meta}{skill_path} || '' )
        : ( $self->{paths} ? $self->{paths}->runtime_root : '' ),
        skill_name => (
              $args{source}
           && $args{source} eq 'skill'
           && $args{page}
           && ref( $args{page} ) eq 'Developer::Dashboard::PageDocument'
           && ref( $args{page}->as_hash->{meta} ) eq 'HASH'
        ) ? ( $args{page}->as_hash->{meta}{skill_name} || '' ) : '',
        paths         => $self->{paths},
        source       => $args{source} || '',
    };
    my ( $stdout, $stderr, $exit_code ) = capture {
        @returns = $package->__run_code($wrapped_code);
        return $?;
    };
    my @errors = $package->__errors();
    if (@errors) {
        my $error = join '', grep { defined $_ && $_ ne '' } @errors;
        $self->_destroy_sandpit($sandpit) if $destroy_sandpit;
        die $error if $error ne '';
    }

    $self->_destroy_sandpit($sandpit) if $destroy_sandpit;

    return {
        stdout  => $stdout,
        stderr  => $stderr,
        returns => \@returns,
        merge   => $state,
    };
}

# stream_code_block(%args)
# Executes one CODE block and streams stdout/stderr chunks through callbacks.
# Input: Perl code string, mutable stash hash, runtime context hash, page/source metadata, and writer callbacks.
# Output: hash reference with streamed return values, merged stash, and trailing error text.
sub stream_code_block {
    my ( $self, %args ) = @_;
    my $code            = $args{code} // '';
    my $state           = $args{state} || {};
    my $runtime         = $args{runtime_context} || {};
    my $sandpit         = $args{sandpit};
    my $destroy_sandpit = !$sandpit ? 1 : 0;
    my $stdout_writer   = $args{stdout_writer} || \&_noop_writer;
    my $stderr_writer   = $args{stderr_writer} || \&_noop_writer;

    Developer::Dashboard::Folder->configure(
        paths   => $self->{paths},
        aliases => $self->{aliases},
    );
    $sandpit ||= $self->_new_sandpit(
        state           => $state,
        runtime_context => $runtime,
    );

    my $package = $sandpit->{package} || die 'Missing sandpit package';
    my $wrapped_code = $self->_code_header($state) . $code;
    my @returns;
    local $Developer::Dashboard::Zipper::AJAX_CONTEXT = {
        allow_transient_urls => (
            defined $ENV{DEVELOPER_DASHBOARD_ALLOW_TRANSIENT_URLS}
              && $ENV{DEVELOPER_DASHBOARD_ALLOW_TRANSIENT_URLS} =~ /\A(?:1|true|yes|on)\z/i
        ) ? 1 : 0,
        page_id      => $args{page} && ref( $args{page} ) ? ( $args{page}->as_hash->{id} || '' ) : '',
        runtime_root => $self->{paths} ? $self->{paths}->runtime_root : '',
        paths        => $self->{paths},
        source       => $args{source} || '',
    };

    tie *STDOUT, 'Developer::Dashboard::PageRuntime::StreamHandle', writer => $stdout_writer;
    tie *STDERR, 'Developer::Dashboard::PageRuntime::StreamHandle', writer => $stderr_writer;
    local $| = 1;
    my $old_stderr = select STDERR;
    $| = 1;
    select $old_stderr;
    @returns = $package->__run_code($wrapped_code);
    untie *STDOUT;
    untie *STDERR;

    my @errors = $package->__errors();
    my $error = join '', grep { defined $_ && $_ ne '' } @errors;

    if ( ref( $args{return_writer} ) eq 'CODE' ) {
        for my $value (@returns) {
            next if ref($value) ne 'HASH' && ref($value) ne 'ARRAY';
            $args{return_writer}->( $self->_runtime_value_text($value) );
        }
    }

    $self->_destroy_sandpit($sandpit) if $destroy_sandpit;

    return {
        returns => \@returns,
        merge   => $state,
        error   => $error,
    };
}

# stream_saved_ajax_file(%args)
# Executes one saved Ajax file as a real process and streams stdout/stderr chunks through callbacks.
# Input: saved file path, request params hash, optional singleton name, page/source metadata, and writer callbacks.
# Output: hash reference with exit_code and process status word.
sub stream_saved_ajax_file {
    my ( $self, %args ) = @_;
    my $path          = $args{path} || die 'Missing saved ajax file path';
    my $params        = $args{params} || {};
    my $stdout_writer = $args{stdout_writer} || \&_noop_writer;
    my $stderr_writer = $args{stderr_writer} || \&_noop_writer;
    my $singleton     = $self->_normalize_saved_ajax_singleton( $params->{singleton} );
    $self->_kill_saved_ajax_singleton($singleton) if $singleton ne '';
    my @command       = $self->_saved_ajax_command( path => $path );
    my %env           = $self->_saved_ajax_env(
        path      => $path,
        page      => $args{page} || '',
        type      => $args{type} || '',
        params    => $params,
        singleton => $singleton,
    );
    my @temp_files = grep { defined $_ && $_ ne '' }
      @env{qw(DEVELOPER_DASHBOARD_AJAX_PARAMS_FILE DEVELOPER_DASHBOARD_AJAX_QUERY_STRING_FILE)};

    my $stdout = gensym;
    my $stderr = gensym;
    my $stdin  = gensym;
    my $pid = eval {
        local %ENV = ( %ENV, %env );
        open3( $stdin, $stdout, $stderr, @command );
    };
    if ($@) {
        $self->_cleanup_saved_ajax_temp_files(@temp_files);
        die $@;
    }
    close $stdin;

    my $select = IO::Select->new( $stdout, $stderr );
    my $stream_error = '';
    my $disconnected = 0;
    my $saved_status;
    eval {
        while (1) {
            my @ready = $select->can_read(0.25);
            if ( !@ready ) {
                last if !$select->count;
                my ( $child_exited, $status ) = $self->_saved_ajax_child_exited($pid);
                if ($child_exited) {
                    $saved_status = $status;
                    my $continued = $self->_drain_saved_ajax_post_exit_handles(
                        path          => $path,
                        select        => $select,
                        stdout        => $stdout,
                        stdout_writer => $stdout_writer,
                        stderr_writer => $stderr_writer,
                    );
                    if ( !$continued ) {
                        $disconnected = 1;
                        die "__DD_AJAX_STREAM_DISCONNECTED__\n";
                    }
                    last;
                }
                next;
            }
            for my $fh (@ready) {
                my $continued = $self->_drain_saved_ajax_ready_handle(
                    fh            => $fh,
                    path          => $path,
                    select        => $select,
                    stdout        => $stdout,
                    stdout_writer => $stdout_writer,
                    stderr_writer => $stderr_writer,
                );
                if ( !$continued ) {
                    $disconnected = 1;
                    die "__DD_AJAX_STREAM_DISCONNECTED__\n";
                }
            }
        }
        1;
    } or do {
        $stream_error = $@ || "Saved ajax stream failed\n";
    };

    $self->_close_saved_ajax_streams( $select, $stdout, $stderr );
    my $fatal_error = '';
    if ($disconnected) {
        $self->_terminate_saved_ajax_process($pid);
    }
    elsif ( $stream_error ne '' ) {
        $self->_terminate_saved_ajax_process($pid);
        $fatal_error = $stream_error if !$self->_looks_like_stream_disconnect_error($stream_error);
    }
    my $status;
    if ( defined $saved_status ) {
        $status = $saved_status;
    }
    else {
        waitpid( $pid, 0 );
        $status = $?;
    }
    $self->_cleanup_saved_ajax_temp_files(@temp_files);
    die $fatal_error if $fatal_error ne '';
    return {
        disconnected => $disconnected ? 1 : 0,
        exit_code => $status >> 8,
        status    => $status,
    };
}

# _drain_saved_ajax_post_exit_handles(%args)
# Drains any remaining saved-Ajax stdout/stderr chunks after the child has
# already exited so Windows does not lose the final response body when
# IO::Select stops reporting the pipe handles as readable.
# Input: saved file path, select set, stdout fh, and writer callbacks.
# Output: true when all remaining handles were drained, otherwise false when a
# caller-visible writer disconnect stops the stream.
sub _drain_saved_ajax_post_exit_handles {
    my ( $self, %args ) = @_;
    my $select = $args{select} || die 'Missing select set';
    my @handles = $select->can('handles') ? $select->handles : ();
    for my $fh (@handles) {
        while ( defined $fh && defined fileno($fh) ) {
            my $continued = $self->_drain_saved_ajax_ready_handle(%args, fh => $fh);
            return 0 if !$continued;
        }
    }
    return 1;
}

# _saved_ajax_child_exited($pid)
# Detects whether one saved-Ajax worker process has already exited during an
# idle stream poll so Windows pipe EOF quirks do not stall the parent stream
# loop forever after the child is gone.
# Input: child process id integer.
# Output: list of boolean child-exited flag and optional wait status word.
sub _saved_ajax_child_exited {
    my ( $self, $pid ) = @_;
    return ( 1, 0 ) if !defined $pid || $pid !~ /^\d+$/ || $pid < 1;
    my $waited = waitpid( $pid, WNOHANG );
    return $waited == $pid ? ( 1, $? ) : ( 0, undef );
}

# _noop_writer(@parts)
# Accepts streamed output chunks when the caller does not need them.
# Input: zero or more ignored chunk parts.
# Output: empty string.
sub _noop_writer { return '' }

# _drain_saved_ajax_ready_handle(%args)
# Reads one ready saved-Ajax process pipe handle and forwards the chunk or error to the right writer.
# Input: ready fh, active select set, stdout fh, saved file path, and writer callbacks.
# Output: true value when streaming should continue, otherwise false when the client disconnected.
sub _drain_saved_ajax_ready_handle {
    my ( $self, %args ) = @_;
    my $fh            = $args{fh}            || die 'Missing ready handle';
    my $path          = $args{path}          || '';
    my $select        = $args{select}        || die 'Missing select set';
    my $stdout        = $args{stdout}        || die 'Missing stdout handle';
    my $stdout_writer = $args{stdout_writer} || \&_noop_writer;
    my $stderr_writer = $args{stderr_writer} || \&_noop_writer;
    my $chunk = '';
    my $bytes = $self->_stream_sysread( $fh, \$chunk );
    if ( !defined $bytes ) {
        return 1 if $!{EINTR};
        $stderr_writer->("Unable to read ajax stream for $path: $!\n");
        $select->remove($fh);
        close $fh;
        return 1;
    }
    if ( $bytes == 0 ) {
        $select->remove($fh);
        close $fh;
        return 1;
    }
    my $ready_fileno  = fileno($fh);
    my $stdout_fileno = fileno($stdout);
    if ( defined $ready_fileno && defined $stdout_fileno && $ready_fileno == $stdout_fileno ) {
        my $continued = $stdout_writer->($chunk);
        return defined $continued ? $continued : 1;
    }
    my $continued = $stderr_writer->($chunk);
    return defined $continued ? $continued : 1;
}

# _close_saved_ajax_streams($select, @handles)
# Closes the saved-Ajax select set and any remaining pipe handles after streaming stops.
# Input: IO::Select object plus zero or more pipe handles.
# Output: true value.
sub _close_saved_ajax_streams {
    my ( $self, $select, @handles ) = @_;
    if ( $select && eval { $select->can('handles') } ) {
        for my $fh ( $select->handles ) {
            next if !defined fileno($fh);
            $select->remove($fh);
            close $fh;
        }
    }
    for my $fh (@handles) {
        next if !defined $fh;
        next if !defined fileno($fh);
        close $fh;
    }
    return 1;
}

# _terminate_saved_ajax_process($pid)
# Stops one saved-Ajax worker process after stream cancellation or writer failure.
# Input: child process id integer.
# Output: true value.
sub _terminate_saved_ajax_process {
    my ( $self, $pid ) = @_;