view release on metacpan or  search on metacpan

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

    my ($input) = @_;
    stash($input) if ref($input) eq 'HASH';
    return "__DD_HIDE__";
}

sub void {
    my ($input) = @_;
    stash($input) if defined $input;
    return;
}

sub stop {
    my ($message) = @_;
    die defined $message ? $message : '';
}

sub params {
    return $AJAX_PARAMS;
}

my $file = shift @ARGV;
open my $fh, '<', $file or die "Unable to read $file: $!";
local $/;
my $code = <$fh>;
close $fh;
eval "{ $code }";
die $@ if $@;
PERL
}

# _exec_saved_ajax_command(@command)
# Runs inside the launcher child: establishes POSIX process-group ownership and
# replaces the launcher with the saved-Ajax worker command, preserving its argv
# without shell parsing.
# Input: non-empty command argv list.
# Output: never returns on success; dies when grouping or exec fails.
sub _exec_saved_ajax_command {
    my ( $class, @command ) = @_;
    die "Missing saved ajax command\n" if !@command;
    defined $SETPGID->()
      or die "Unable to isolate saved ajax process $$: $!\n";
    exec { $command[0] } @command;

    # Devel::Cover cannot attribute a statement that follows a failed exec: the
    # count lands on the exec line itself, so this line always reports zero even
    # though the page-runtime coverage tests drive a failing exec through here and
    # assert this message.
    die "Unable to exec saved ajax command $command[0]: $!\n";    # uncoverable statement
}

# _run_saved_ajax_perl_file($path)
# Executes one saved Perl Ajax file through the in-module bootstrap wrapper so
# Windows does not have to carry a multi-line `perl -e` payload through the
# native process command line.
# Input: saved Ajax Perl file path string.
# Output: true value after the wrapped file has been evaluated.
sub _run_saved_ajax_perl_file {
    my ( $class, $path ) = @_;
    die "Missing saved ajax Perl file path\n" if !defined $path || $path eq '';
    my $wrapper = $class->_saved_ajax_perl_wrapper;
    local @ARGV = ($path);
    eval $wrapper;
    die $@ if $@;
    return 1;
}

# _code_header($state)
# Builds the older lexical stash header injected before each CODE block.
# Input: mutable stash hash reference.
# Output: Perl source string.
sub _code_header {
    my ( $self, $state ) = @_;
    $state ||= {};

    my @keys = grep { /^[A-Za-z_][A-Za-z0-9_]*$/ } sort keys %$state;
    return '' if !@keys;

    my $header = sprintf 'my (%s) = @{ $stash }{qw(%s)};' . "\n",
      join( ', ', map { '$' . $_ } @keys ),
      join( ' ', @keys );
    $header .= sprintf 'my (%s) = map { \\$stash->{$_} } qw(%s);' . "\n",
      join( ', ', map { '$' . $_ . '_r' } @keys ),
      join( ' ', @keys );
    return $header;
}

# _new_sandpit(%args)
# Creates one throwaway package used across CODE blocks for a single page run.
# Input: mutable stash hash reference and runtime context hash.
# Output: hash reference containing the generated package name.
sub _new_sandpit {
    my ( $self, %args ) = @_;
    my $package = sprintf 'Developer::Dashboard::Sandpit::%d::%d::%d', $$, time, ++$SANDPIT_SEQ;
    $package =~ s/[^A-Za-z0-9:]/_/g;

    my $compiled = <<"PERL";
package $package;
use strict;
use warnings;
use Developer::Dashboard::DataHelper qw(j je);
use Developer::Dashboard::Zipper qw(Ajax acmdx zip unzip);

our \$stash = {};
our \$runtime = {};
our \@errors = ();

# __add_error(\@messages)
# Records one or more non-empty CODE-block error messages into this sandpit
# package's error list, for __errors to drain afterward.
# Input: candidate error message strings, empty/undef ones are dropped.
# Output: none.
sub __add_error {
    push \@errors, grep { defined \$_ && \$_ ne '' } \@_;
}

# __errors()
# Drains and returns every error recorded since the last drain.
# Input: none.
# Output: list of recorded error message strings; clears the internal list.
sub __errors {
    my \@copy = \@errors;