PAX
view release on metacpan or search on metacpan
lib/PAX/StandaloneRuntime.pm view on Meta::CPAN
};
return ($stdout, $stderr, $exit_code);
}
sub _system_command_missing {
my ($stderr, $exit_code) = @_;
return 1 if !defined $exit_code || $exit_code < 0 || $exit_code == 127;
return 1 if defined $stderr && $stderr =~ /(?:can't exec|not found|no such file or directory)/i;
return 0;
}
sub run {
my ($class, %args) = @_;
my $entrypoint = $args{entrypoint} // shift(@ARGV);
_state();
if (!defined $entrypoint || !_entrypoint_looks_valid($entrypoint)) {
my $fallback = _resolve_entrypoint_from_manifest($entrypoint);
if (defined $fallback) {
_trace("entrypoint fallback from manifest: '" . ($entrypoint // '<undef>') . "' -> '$fallback'");
$entrypoint = $fallback;
}
}
die 'entrypoint required' if !defined $entrypoint;
if (!_entrypoint_looks_valid($entrypoint)) {
die "entrypoint is not a valid executable unit: $entrypoint";
}
my @argv = @{ $args{argv} // \@ARGV };
my $self_path = _standalone_executable_path();
_install_namespace_compat();
_install_require_hook();
_install_pending_wrappers();
local $0 = $self_path if defined $self_path && $self_path ne '';
if (@argv && $argv[0] eq '--pax-standalone-helper') {
shift @argv;
my $helper = shift @argv // die "standalone helper name required\n";
local @ARGV = @argv;
return _run_standalone_managed_helper($helper, @argv);
}
local @ARGV = @argv;
my $rv = _run_entrypoint($entrypoint);
_install_pending_wrappers();
return $rv;
}
sub _entrypoint_looks_valid {
my ($entrypoint) = @_;
return 0 if !defined $entrypoint;
return 0 if $entrypoint =~ /\A-/;
return 0 if $entrypoint =~ /\A\s*\z/;
return 1;
}
sub _resolve_entrypoint_from_manifest {
my ($entrypoint) = @_;
my $state = _state();
my $manifest_entrypoint = $state->{manifest}{entrypoint}{logical_path} // '';
if ($manifest_entrypoint ne '') {
my $candidate = File::Spec->catfile($state->{root}, 'code', split m{/}, $manifest_entrypoint);
return $candidate if -f $candidate;
}
my @unit_candidates = grep {
my $unit = $_;
my $unit_kind = $unit->{unit_kind} // '';
my $packaging = $unit->{packaging} // '';
($unit_kind // '') eq 'entrypoint' || ($packaging // '') =~ /\A(compiled|hybrid|residual)_(?:dispatch|cli_router|script)_pcu_v1\z/;
} @{ $state->{manifest}{code_units} // [] };
for my $unit (@unit_candidates) {
my $logical = $unit->{logical_path} // '';
next if $logical eq '';
my $candidate = File::Spec->catfile($state->{root}, 'code', split m{/}, $logical);
return $candidate if -f $candidate;
}
return;
}
sub _state {
return $STATE if $STATE;
my $manifest_path = $ENV{PAX_STANDALONE_MANIFEST_PATH} or die 'PAX_STANDALONE_MANIFEST_PATH not set';
open my $fh, '<', $manifest_path or die "cannot read $manifest_path: $!";
local $/;
my $manifest = _runtime_json_decode(<$fh>);
my $root = $ENV{PAX_STANDALONE_TMPDIR} or die 'PAX_STANDALONE_TMPDIR not set';
my $app_namespace = _normalize_namespace($manifest->{app}{namespace} // '');
if (!$app_namespace) {
$app_namespace = _normalize_namespace($manifest->{app}{compat}{namespace} // '');
}
my $legacy_namespace = _normalize_namespace($manifest->{app}{compat}{legacy_namespace} // '');
$legacy_namespace = $app_namespace if $legacy_namespace eq '';
my %by_region = map { ($_->{region_name} // '') => $_ } @{ $manifest->{native_dispatch} // [] };
my %compiled_packages;
my %compiled = map {
my $key = $_->{require_path} // '';
length($key) ? ($key => $_) : ()
} grep {
my $packaging = $_->{packaging} // '';
(($packaging eq 'compiled_pcu_v1') || ($packaging eq 'hybrid_compiled_pcu_v1'))
} @{ $manifest->{code_units} // [] };
for my $unit (@{ $manifest->{code_units} // [] }) {
my $package = $unit->{package} // '';
next if !$package || $package eq '';
$compiled_packages{$package} = 1;
}
return $STATE = {
manifest => $manifest,
root => $root,
app_namespace => $app_namespace,
legacy_namespace => $legacy_namespace,
compiled_packages => \%compiled_packages,
app_env_prefix => undef,
native_runner => PAX::NativeRunner->new,
wrapped => {},
namespace_aliases => {},
by_region => \%by_region,
compiled_units => \%compiled,
require_hook_installed => 0,
loading_require => {},
residual_loaded => {},
residual_bootstrap_loaded => {},
};
}
sub _app_env_prefix {
my $state = _state();
return $state->{app_env_prefix} if defined $state->{app_env_prefix};
my $app = $state->{manifest}{app} // {};
my $namespace = $app->{compat}{namespace} // $app->{namespace} // '';
my $name = $namespace || $app->{name} // '';
if (!$name || $name =~ /\A\s*\z/) {
$name = $app->{command} // 'app';
}
lib/PAX/StandaloneRuntime.pm view on Meta::CPAN
SH
}
sub _standalone_internal_cli_class {
my $state = _state();
my $app_namespace = $state->{app_namespace} // '';
if ($app_namespace) {
return $app_namespace . '::InternalCLI';
}
for my $unit (@{ $state->{manifest}{code_units} // [] }) {
next if ref($unit) ne 'HASH';
my $package = $unit->{package} // '';
next if !$package || $package eq '';
return $package if $package =~ /::InternalCLI\z/;
}
return;
}
sub _standalone_internal_cli_asset_path {
my ($name) = @_;
if (my $embedded = _standalone_embedded_asset_path($name)) {
return $embedded;
}
my $class = _standalone_internal_cli_class() or return;
_load_package_by_module_name($class);
my $full = $class . '::_helper_asset_path';
return if !defined &{$full};
no strict 'refs';
return &{$full}($name);
}
sub _standalone_internal_cli_asset_content {
my ($name) = @_;
if (my $path = _standalone_internal_cli_asset_path($name)) {
open my $fh, '<:raw', $path or die "Unable to read $path: $!";
local $/;
my $content = <$fh>;
close $fh or die "Unable to close $path: $!";
return ($content, $path);
}
my $class = _standalone_internal_cli_class() or return;
_load_package_by_module_name($class);
my $full = $class . '::helper_content';
return if !defined &{$full};
local $ENV{PAX_STANDALONE_EXECUTABLE} = '';
no strict 'refs';
my $content = &{$full}($name);
return if !defined $content || $content eq '';
return ($content, $name);
}
sub _standalone_embedded_asset_path {
my ($name) = @_;
return if !defined $name || $name eq '';
my $state = _state();
for my $asset (@{ $state->{manifest}{assets} // [] }) {
next if ref($asset) ne 'HASH';
my $logical = $asset->{logical_path} // '';
next if $logical eq '';
next if $logical ne $name && $logical !~ m{(?:^|/)\Q$name\E\z};
my $path = File::Spec->catfile($state->{root}, 'assets', split m{/}, $logical);
return $path if -f $path;
}
return;
}
sub _share_dist_private_cli_dir {
my ($dist_name) = @_;
return if !defined $dist_name || $dist_name eq '';
my $ok = eval {
require File::ShareDir;
1;
};
return if !$ok;
my $root = eval { File::ShareDir::dist_dir($dist_name) };
return if !$root || !-d $root;
my $candidate = File::Spec->catdir($root, 'private-cli');
return -d $candidate ? $candidate : undef;
}
sub _run_standalone_managed_helper {
my ($helper, @argv) = @_;
my ($helper_source, $helper_path) = _standalone_internal_cli_asset_content($helper);
die "standalone managed helper '$helper' is unavailable\n" if !defined $helper_source || $helper_source eq '';
my $self_path = _standalone_executable_path();
local $ENV{DEVELOPER_DASHBOARD_ENTRYPOINT} = $self_path if defined $self_path && $self_path ne '';
my ($source, $path, @helper_argv);
if ($helper eq '_dashboard-core' || _standalone_helper_delegates_to_dashboard_core($helper_source)) {
my ($core_source, $core_path) = _standalone_internal_cli_asset_content('_dashboard-core');
die "standalone managed helper core is unavailable\n" if !defined $core_source || $core_source eq '';
$source = $core_source;
$path = $core_path;
@helper_argv = @argv;
unshift @helper_argv, $helper if $helper ne '_dashboard-core';
}
else {
$source = $helper_source;
$path = $helper_path;
@helper_argv = @argv;
}
local @ARGV = @helper_argv;
local $0 = $path if defined $path && $path ne '';
my $wrapped = "package main;\n#line 1 \"$path\"\n" . $source;
my $rv = eval $wrapped;
die $@ if $@;
return 0 if !defined $rv;
return $rv;
}
sub _direct_standalone_helper_name_from_path {
my ($path) = @_;
return if !defined $path || $path eq '';
my $name = basename($path);
return if !defined $name || $name eq '';
return $name;
}
sub _standalone_helper_delegates_to_dashboard_core {
my ($source) = @_;
return 0 if !defined $source || $source eq '';
return 1 if $source =~ /_dashboard-core/
&& $source =~ /basename\(\$0\)/
&& $source =~ /exec\s+\{\s*\$\^X\s*\}\s+\$\^X,\s+\$core,\s+\$command,\s+\@ARGV;/s;
return 0;
}
sub _install_pending_wrappers {
my $state = _state();
for my $full (sort keys %{ $state->{by_region} }) {
next if $state->{wrapped}{$full};
next if !$full || ($full !~ /::/);
my $cv = _code_for($full) or next;
my $meta = $state->{by_region}{$full};
next if !$meta->{executable_logical_path};
my $original = $cv;
no strict 'refs';
no warnings 'redefine';
*{$full} = sub {
my @args = @_;
if (_eligible_i64_args(\@args)) {
my $guard = PAX::GuardManager->new(
epochs => $state->{manifest}{runtime_epochs} // {},
)->validate_or_deopt({
region_id => $meta->{region_id},
region_name => $meta->{region_name},
guards => $meta->{guards} // [],
deopt => $meta->{deopt} // {},
}, args => [ @args[0, 1] ], context => 'scalar');
if (($guard->{status} // '') eq 'native_allowed') {
my $probe = File::Spec->catfile($state->{root}, split m{/}, $meta->{executable_logical_path});
chmod 0700, $probe if -f $probe;
my $result = $state->{native_runner}->run_i64_binary(
path => $probe,
left => $args[0],
right => $args[1],
);
if (($result->{status} // '') eq 'ok' && defined $result->{value}) {
_log_native_hit($full);
return $result->{value};
}
}
}
return $original->(@_);
};
$state->{wrapped}{$full} = 1;
}
}
sub _eligible_i64_args {
my ($args) = @_;
return 0 if @$args != 2;
return 0 if !defined $args->[0] || !defined $args->[1];
return ($args->[0] =~ /\A-?\d+\z/ && $args->[1] =~ /\A-?\d+\z/) ? 1 : 0;
}
sub _load_compiled_unit {
my ($unit) = @_;
my $state = _state();
_trace("load unit " . (($unit->{require_path} // $unit->{logical_path} // 'unknown')));
my $path = File::Spec->catfile($state->{root}, 'code', split m{/}, $unit->{logical_path});
open my $fh, '<', $path or die "cannot read compiled unit $path: $!";
local $/;
my $record = _runtime_json_decode(<$fh>);
if (($record->{residual_mode} // '') eq 'module') {
_load_residual_module($unit, $record);
return;
}
for my $init (@{ $record->{initializers} // [] }) {
_apply_initializer($init);
}
for my $sub (@{ $record->{subs} // [] }) {
_install_compiled_sub($record->{package}, $sub);
}
if (@{ $record->{unsupported_subs} // [] }) {
_install_residual_stubs($unit, $record);
}
}
sub _ensure_virtual_source_file {
my ($unit) = @_;
my $state = _state();
my $logical = _virtual_source_logical_path($unit);
my $path = File::Spec->catfile($state->{root}, 'code', split m{/}, $logical);
return $path if -f $path;
my $dir = dirname($path);
make_path($dir) if !-d $dir;
open my $fh, '>', $path or die "cannot write virtual source file $path: $!";
print {$fh} "# PAX compiled unit placeholder for ", ($unit->{require_path} // $unit->{logical_path} // 'unknown'), "\n1;\n";
close $fh;
return $path;
}
sub _virtual_source_logical_path {
my ($unit) = @_;
my $logical = $unit->{logical_path} // '';
if (($unit->{require_path} // '') ne '') {
if ($logical =~ /\.pcu\.json\z/) {
$logical =~ s/\.pcu\.json\z/.pm/;
return $logical;
}
return File::Spec->catfile('virtual', split m{/}, ($unit->{require_path} // 'module.pm'));
}
if ($logical =~ /\.dashboard\.json\z/) {
$logical =~ s/\.dashboard\.json\z/.pl/;
return $logical;
}
if ($logical =~ /\.dispatch\.json\z/) {
$logical =~ s/\.dispatch\.json\z/.pl/;
return $logical;
}
if ($logical =~ /\.script\.json\z/) {
$logical =~ s/\.script\.json\z/.pl/;
return $logical;
}
return File::Spec->catfile('virtual', 'entrypoint.pl');
}
sub _run_entrypoint {
my ($entrypoint) = @_;
if ($entrypoint =~ /\.service\.json\z/) {
return _run_service_dispatch_unit($entrypoint);
}
if ($entrypoint =~ /\.cli-router\.json\z/) {
return _run_cli_router_unit($entrypoint);
}
if ($entrypoint =~ /\.dispatch\.json\z/) {
return _run_dispatch_script_unit($entrypoint);
}
if ($entrypoint =~ /\.script\.json\z/) {
return _run_script_unit($entrypoint);
}
my $rv = do $entrypoint;
die $@ if $@;
die "failed to load $entrypoint: $!" if !defined($rv) && $!;
return $rv;
}
sub _run_service_dispatch_unit {
my ($entrypoint) = @_;
open my $fh, '<', $entrypoint or die "cannot read service dispatch unit $entrypoint: $!";
local $/;
my $record = _runtime_json_decode(<$fh>);
my $cmd = shift(@ARGV);
$cmd = 'version' if !defined($cmd) || $cmd eq '';
if ($cmd eq 'version') {
print(($record->{version} // '0.0.0') . "\n");
exit 0;
}
if ($cmd eq 'serve') {
(my $app_module_path = ($record->{app_module} // '')) =~ s{::}{/}g;
$app_module_path .= '.pm' if $app_module_path ne '';
(my $server_module_path = ($record->{server_module} // '')) =~ s{::}{/}g;
$server_module_path .= '.pm' if $server_module_path ne '';
_load_compiled_require($app_module_path) || require $app_module_path;
require $server_module_path;
my $host = '127.0.0.1';
my $port = 5000;
while (@ARGV) {
lib/PAX/StandaloneRuntime.pm view on Meta::CPAN
print STDERR $suggest_class->new()->unknown_command_message($cmd);
}
main::pod2usage(
-exitval => 1,
-verbose => 99,
-sections => [qw(NAME SYNOPSIS)],
);
}
sub _run_dispatch_script_unit {
my ($entrypoint) = @_;
open my $fh, '<', $entrypoint or die "cannot read dispatch script unit $entrypoint: $!";
local $/;
my $record = _runtime_json_decode(<$fh>);
my $path = _virtual_entrypoint_path($entrypoint);
my $bootstrap = $record->{bootstrap_source};
if (defined $bootstrap && $bootstrap ne '') {
my $wrapped = "package main;\n#line 1 \"$path\"\n" . $bootstrap;
my $rv = eval $wrapped;
die $@ if $@;
}
my $cmd = shift(@ARGV);
if (($record->{command_default_mode} // '') eq 'defined_or') {
$cmd = $record->{command_default} if !defined $cmd;
} else {
$cmd = $record->{command_default} if !defined($cmd) || $cmd eq '';
}
for my $entry (@{ $record->{actions} // [] }) {
next if ($entry->{command} // '') ne (defined $cmd ? $cmd : '');
return _run_dispatch_action($entry->{action}, $cmd);
}
if (my $unknown = $record->{unknown_action}) {
return _run_dispatch_action($unknown, $cmd);
}
die "no dispatch action for command " . (defined $cmd ? $cmd : '(undef)');
}
sub _run_dispatch_action {
my ($action, $cmd) = @_;
my $op = $action->{op} // die 'dispatch action op missing';
if ($op eq 'print_call') {
my $cv = _code_for($action->{target}) or die "missing dispatch target $action->{target}";
my $value = $cv->(@{ $action->{args} // [] });
print $value;
print "\n" if $action->{newline};
exit($action->{exit_code} // 0);
}
if ($op eq 'print_required_global') {
my $module = $action->{require_module} // die 'dispatch require module missing';
_load_package_by_module_name($module);
no strict 'refs';
my $value = ${ $action->{symbol} };
print $value;
print "\n" if $action->{newline};
exit($action->{exit_code} // 0);
}
if ($op eq 'print_embedded_asset') {
my $root = $ENV{PAX_EMBEDDED_ASSET_ROOT} // '';
my $logical = $action->{logical_path} // die 'dispatch asset logical path missing';
my $path = $root ? File::Spec->catfile($root, split m{/}, $logical) : '';
if (!$path || !-f $path) {
print STDERR "missing asset\n";
exit 3;
}
open my $fh, '<', $path or die $!;
local $/;
my $content = <$fh>;
close $fh;
print $content;
exit 0;
}
if ($op eq 'stderr_interpolate_cmd') {
print STDERR ($action->{prefix} // '') . (defined $cmd ? $cmd : '') . ($action->{suffix} // '');
exit($action->{exit_code} // 0);
}
die "unsupported dispatch action op: $op";
}
sub _run_script_unit {
my ($entrypoint) = @_;
open my $fh, '<', $entrypoint or die "cannot read script unit $entrypoint: $!";
local $/;
my $record = _runtime_json_decode(<$fh>);
my $source = $record->{script_source} // _script_source_from_code_units($entrypoint)
// _source_path_to_script_source($entrypoint)
// _script_source_from_residual_payload($entrypoint);
die "script source missing for $entrypoint" if !defined $source;
die "script source is empty for $entrypoint" if $source eq '';
$source = _apply_compiled_script_subs($source, $record->{compiled_subs} // []);
my $path = _virtual_entrypoint_path($entrypoint);
my $wrapped = "package main;\n#line 1 \"$path\"\n" . $source;
my $rv = eval $wrapped;
die $@ if $@;
return 0 if !defined($rv);
if (my $invocation = $record->{entry_invocation}) {
my $op = $invocation->{op} // '';
if ($op eq 'call_main_argv_and_exit') {
my $cv = _code_for('main::main') or die "script unit $path missing main";
exit(($cv->(@ARGV) // 0));
}
die "unsupported script entry invocation op: $op";
}
return $rv;
}
sub _script_source_from_code_units {
my ($entrypoint) = @_;
my $state = _state();
my $unit = _find_code_unit_for_entrypoint($entrypoint);
return if !$unit;
return $unit->{script_source} if defined $unit->{script_source};
my $bytes = $unit->{bytes};
return if !defined $bytes;
my $decoded = eval { _runtime_json_decode($bytes) };
return $decoded->{script_source} if ref($decoded) eq 'HASH' && defined $decoded->{script_source};
return $bytes;
}
sub _runtime_json_decoder {
return $RUNTIME_JSON_DECODER if $RUNTIME_JSON_DECODER;
if (eval { require JSON::XS; 1 }) {
$RUNTIME_JSON_DECODER = JSON::XS->new->utf8(1);
$RUNTIME_JSON_DECODER_KIND = 'JSON::XS';
return $RUNTIME_JSON_DECODER;
}
$RUNTIME_JSON_DECODER = JSON::PP->new->utf8(1);
$RUNTIME_JSON_DECODER_KIND = 'JSON::PP';
return $RUNTIME_JSON_DECODER;
}
sub _runtime_json_decode {
my ($json) = @_;
return _runtime_json_decoder()->decode($json);
}
sub _source_path_to_script_source {
my ($entrypoint) = @_;
my $state = _state();
my $unit = _find_code_unit_for_entrypoint($entrypoint);
return if !$unit;
my $source_path = $unit->{source_path} // '';
return if !$source_path;
my $root = $state->{manifest}{entrypoint}{source_path} // '';
my $abs_root = File::Spec->rel2abs($source_path);
$source_path = $abs_root;
if (open my $source_fh, '<:raw', $source_path) {
local $/;
return <$source_fh>;
}
return;
}
sub _script_source_from_residual_payload {
my ($entrypoint) = @_;
my $manifest_entry = _find_code_unit_for_entrypoint($entrypoint);
return if !$manifest_entry;
my $payload = $manifest_entry->{residual_payload} // $manifest_entry->{payload} // '';
return if !$payload;
return $payload;
}
sub _find_code_unit_for_entrypoint {
my ($entrypoint) = @_;
my $state = _state();
my $entrypoint_name = $entrypoint;
for my $unit (@{ $state->{manifest}{code_units} // [] }) {
next unless $unit && ref($unit) eq 'HASH';
my $logical = $unit->{logical_path} // '';
my $packed = File::Spec->catfile($state->{root}, 'code', split m{/}, $logical);
return $unit if $unit->{logical_path} eq $entrypoint || $packed eq $entrypoint_name;
my $source_path = $unit->{source_path} // '';
next if $source_path eq '';
return $unit if File::Spec->rel2abs($source_path) eq File::Spec->rel2abs($entrypoint_name);
}
return;
}
sub _apply_initializer {
my ($init) = @_;
my $op = $init->{op} // '';
_trace("initializer $op " . ($init->{module} // $init->{symbol} // ''));
if ($op eq 'require_module') {
my $module = $init->{module} // die 'initializer module missing';
my $path = $module;
$path =~ s{::}{/}g;
$path .= '.pm';
_load_compiled_require($path) || require $path;
return;
}
if ($op eq 'use_module') {
my $module = $init->{module} // die 'initializer module missing';
my $path = $module;
$path =~ s{::}{/}g;
$path .= '.pm';
_load_compiled_require($path) || require $path;
my @args = @{ $init->{args} // [] };
my $target_package = $init->{package} || 'main';
my $arg_list = join(', ', map { _perl_literal($_) } @args);
my $code = "package $target_package; ${module}->import(" . $arg_list . "); 1;";
_trace("initializer import start $module into $target_package");
my $ok = eval $code;
die $@ if !$ok;
_trace("initializer import done $module into $target_package");
return;
}
if ($op eq 'set_scalar_literal') {
my $symbol = $init->{symbol} // die 'initializer symbol missing';
my $value = $init->{value};
no strict 'refs';
${$symbol} = $value;
return;
}
if ($op eq 'set_array_literal') {
my $symbol = $init->{symbol} // die 'initializer symbol missing';
my $values = $init->{values} // [];
no strict 'refs';
@{$symbol} = @$values;
return;
}
if ($op eq 'increment_scalar_default_zero') {
my $symbol = $init->{symbol} // die 'initializer symbol missing';
my $by = $init->{by} // 0;
no strict 'refs';
${$symbol} = (${ $symbol } // 0) + $by;
return;
}
die "unsupported compiled initializer op: $op";
}
lib/PAX/StandaloneRuntime.pm view on Meta::CPAN
week => 'weeks',
weeks => 'weeks',
month => 'months',
months => 'months',
);
for my $key (sort keys %{$rotation}) {
my $canonical = $aliases{$key}
or die "collector rotation key $key for $collector_name is not supported\n";
my $value = $rotation->{$key};
die "collector rotation $canonical for $collector_name must be a non-negative integer\n"
if !defined $value || $value !~ /\A\d+\z/;
$normalized{$canonical} = $value + 0;
}
return \%normalized;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'collector_rotation_retention_seconds') {
$impl = sub {
my ($self, $rotation) = @_;
my %seconds_per_unit = (
minutes => 60,
hours => 60 * 60,
days => 60 * 60 * 24,
weeks => 60 * 60 * 24 * 7,
months => 60 * 60 * 24 * 30,
);
my $seconds;
for my $unit (keys %seconds_per_unit) {
next if !exists $rotation->{$unit};
$seconds ||= 0;
$seconds += $rotation->{$unit} * $seconds_per_unit{$unit};
}
return $seconds;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'collector_split_log_entries') {
$impl = sub {
my ($self, $text) = @_;
return () if !defined $text || $text eq '';
return grep { defined && $_ ne '' } split /(?=^=== collector )/m, $text;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'collector_entry_timestamp_epoch') {
my $to_epoch_method = $sub->{to_epoch_method} // die 'compiled sub to-epoch method missing';
$impl = sub {
my ($self, $collector_name, $entry) = @_;
my ($timestamp) = $entry =~ /\A=== collector [^\n]* \| \@ ([0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}(?:Z|[+-][0-9]{4}|[+-][0-9]{2}:[0-9]{2}))(?: \| [^\n]*)* ===\n/;
die "Unable to parse collector log timestamp for $collector_name\n" if !defined $timestamp;
return _code_for($to_epoch_method)->($self, $timestamp);
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'collector_trim_log_by_age') {
my $split_method = $sub->{split_method} // die 'compiled sub split method missing';
my $entry_epoch_method = $sub->{entry_epoch_method} // die 'compiled sub entry-epoch method missing';
$impl = sub {
my ($self, $collector_name, $text, $retention_seconds, %args) = @_;
return $text if !defined $retention_seconds;
return $text if $text eq '';
my $now_epoch = defined $args{now_epoch} ? $args{now_epoch} : time;
my $cutoff = $now_epoch - $retention_seconds;
my @kept;
for my $entry (_code_for($split_method)->($self, $text)) {
my $entry_epoch = _code_for($entry_epoch_method)->($self, $collector_name, $entry);
push @kept, $entry if $entry_epoch >= $cutoff;
}
return join '', @kept;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'collector_trim_log_by_lines') {
$impl = sub {
my ($self, $text, $lines) = @_;
return $text if $text eq '';
my $has_trailing_newline = $text =~ /\n\z/ ? 1 : 0;
my @parts = split /\n/, $text, -1;
pop @parts if $has_trailing_newline && @parts && $parts[-1] eq '';
return $text if @parts <= $lines;
@parts = @parts[@parts - $lines .. $#parts];
return join("\n", @parts) . ($has_trailing_newline ? "\n" : '');
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'collector_apply_log_rotation') {
my $retention_method = $sub->{retention_method} // die 'compiled sub retention method missing';
my $trim_age_method = $sub->{trim_age_method} // die 'compiled sub trim-age method missing';
my $trim_lines_method = $sub->{trim_lines_method} // die 'compiled sub trim-lines method missing';
$impl = sub {
my ($self, $collector_name, $text, $rotation, %args) = @_;
my $rotated = $text;
my $retention_seconds = _code_for($retention_method)->($self, $rotation);
if (defined $retention_seconds) {
$rotated = _code_for($trim_age_method)->(
$self,
$collector_name,
$rotated,
$retention_seconds,
now_epoch => $args{now_epoch},
);
}
if (exists $rotation->{lines}) {
$rotated = _code_for($trim_lines_method)->($self, $rotated, $rotation->{lines});
}
return $rotated;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'collector_rotate_log') {
my $normalize_method = $sub->{normalize_method} // die 'compiled sub normalize method missing';
my $collector_paths_method = $sub->{collector_paths_method} // die 'compiled sub collector-paths method missing';
my $slurp_method = $sub->{slurp_method} // die 'compiled sub slurp method missing';
lib/PAX/StandaloneRuntime.pm view on Meta::CPAN
$impl = sub {
my ($self, $skill_name, %args) = @_;
return () if !$skill_name;
my $paths = $self->{manager}{paths};
return $paths->skill_layers($skill_name, %args) if $paths->can('skill_layers');
my $skill_path = $self->{manager}->get_skill_path($skill_name, %args) or return ();
return ($skill_path);
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_skill_lookup_roots') {
my $skill_layers_method = $sub->{skill_layers_method} // die 'compiled sub skill-layers method missing';
$impl = sub {
my ($self, $skill_name, %args) = @_;
return reverse _code_for($skill_layers_method)->($self, $skill_name, %args);
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_command_root_specs') {
$impl = sub {
my ($self, $segments) = @_;
my @segments = @{ $segments || [] };
return () if !@segments;
my @specs = ({
nested_segments => [],
command_name => join('.', @segments),
});
for my $split_index (1 .. $#segments) {
push @specs, {
nested_segments => [ @segments[0 .. $split_index - 1] ],
command_name => join('.', @segments[$split_index .. $#segments]),
};
}
return @specs;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_nested_skill_path') {
$impl = sub {
my ($self, $skill_path, $nested_segments) = @_;
my @segments = @{ $nested_segments || [] };
return $skill_path if !@segments;
my @parts = ($skill_path);
for my $segment (@segments) {
push @parts, 'skills', $segment;
}
return File::Spec->catdir(@parts);
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_page_location') {
my $skill_lookup_roots_method = $sub->{skill_lookup_roots_method} // die 'compiled sub skill-lookup-roots method missing';
$impl = sub {
my ($self, $skill_name, $route_id) = @_;
return if !$skill_name || !$route_id;
for my $skill_path (_code_for($skill_lookup_roots_method)->($self, $skill_name)) {
my $file = File::Spec->catfile($skill_path, 'dashboards', split m{/+}, $route_id);
return ($file, $skill_path) if -f $file;
}
return;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_skill_bookmark_entries') {
my $skill_lookup_roots_method = $sub->{skill_lookup_roots_method} // die 'compiled sub skill-lookup-roots method missing';
$impl = sub {
my ($self, $skill_name) = @_;
return () if !$skill_name;
my %entries;
for my $skill_path (_code_for($skill_lookup_roots_method)->($self, $skill_name)) {
my $dashboards_root = File::Spec->catdir($skill_path, 'dashboards');
next if !-d $dashboards_root;
opendir(my $dh, $dashboards_root) or die "Unable to read $dashboards_root: $!";
for my $entry (
grep {
$_ ne '.' && $_ ne '..' && $_ ne 'nav' && -f File::Spec->catfile($dashboards_root, $_)
} readdir($dh)
) {
$entries{$entry} ||= 1;
}
closedir($dh);
}
return sort keys %entries;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_skill_nav_route_ids') {
my $skill_lookup_roots_method = $sub->{skill_lookup_roots_method} // die 'compiled sub skill-lookup-roots method missing';
$impl = sub {
my ($self, $skill_name) = @_;
return () if !$skill_name;
my %routes;
for my $skill_path (_code_for($skill_lookup_roots_method)->($self, $skill_name)) {
my $nav_root = File::Spec->catdir($skill_path, 'dashboards', 'nav');
next if !-d $nav_root;
opendir my $dh, $nav_root or die "Unable to read $nav_root: $!";
for my $entry (
grep { $_ ne '.' && $_ ne '..' && -f File::Spec->catfile($nav_root, $_) } readdir $dh
) {
$routes{$entry} ||= 'nav/' . $entry;
}
closedir $dh;
}
return %routes;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_merge_skill_hashes') {
my $merge_array_items_method = $sub->{merge_array_items_method} // die 'compiled sub merge-array-items method missing';
$impl = sub {
my ($self, $left, $right) = @_;
$left ||= {};
$right ||= {};
my %merged = (%{$left});
lib/PAX/StandaloneRuntime.pm view on Meta::CPAN
$selector->remove($fh);
close $fh;
next;
}
if (fileno($fh) == $stdout_fd) {
print STDOUT $buffer;
$stdout_text .= $buffer;
next;
}
if (fileno($fh) == $stderr_fd) {
print STDERR $buffer;
$stderr_text .= $buffer;
next;
}
}
}
waitpid($pid, 0);
return { stdout => $stdout_text, stderr => $stderr_text, exit_code => $? >> 8 };
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_exec_resolved_command') {
my $arrayref_or_empty_method = $sub->{arrayref_or_empty_method} // die 'compiled sub arrayref-or-empty method missing';
my $exec_replacement_method = $sub->{exec_replacement_method} // die 'compiled sub exec-replacement method missing';
$impl = sub {
my ($self, $cmd_path, $command, $args) = @_;
my @command = @{ _code_for($arrayref_or_empty_method)->($self, $command) };
my @args = @{ _code_for($arrayref_or_empty_method)->($self, $args) };
my $error = _code_for($exec_replacement_method)->($self, \@command, \@args);
if (defined $error && $error ne '') {
return { error => "Unable to exec $cmd_path: $error" };
}
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_exec_replacement') {
$impl = sub {
my ($self, $command, $args) = @_;
my @command = @{ ref($command) eq 'ARRAY' ? $command : [] };
my @args = @{ ref($args) eq 'ARRAY' ? $args : [] };
if (!exec @command, @args) {
my $error = "$!";
return $error;
}
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_route_response') {
my $skill_layers_method = $sub->{skill_layers_method} // die 'compiled sub skill-layers method missing';
my $bookmark_entries_method = $sub->{bookmark_entries_method} // die 'compiled sub bookmark entries method missing';
my $page_response_method = $sub->{page_response_method} // die 'compiled sub page response method missing';
$impl = sub {
my ($self, %args) = @_;
my $skill_name = $args{skill_name} || '';
my $route = defined $args{route} ? $args{route} : '';
my @skill_layers = _code_for($skill_layers_method)->($self, $skill_name);
return [404, 'text/plain; charset=utf-8', "Skill '$skill_name' not found\n"] if !@skill_layers;
my @parts = grep { defined && $_ ne '' } split m{/+}, $route;
my @dashboards_roots = map { File::Spec->catdir($_, 'dashboards') } @skill_layers;
return [404, 'text/plain; charset=utf-8', "Skill '$skill_name' does not provide dashboards\n"]
if !grep { -d $_ } @dashboards_roots;
if (@parts && $parts[0] eq 'bookmarks') {
if (@parts == 1) {
my @items = _code_for($bookmark_entries_method)->($self, $skill_name);
return [404, 'text/plain; charset=utf-8', "Skill '$skill_name' does not provide dashboards\n"] if !@items;
return [200, 'application/json; charset=utf-8', JSON::XS::encode_json({ skill => $skill_name, bookmarks => \@items })];
}
my $legacy_id = join '/', @parts[1 .. $#parts];
return _code_for($page_response_method)->(%args, skill_name => $skill_name, route_id => $legacy_id);
}
my $route_id = @parts ? join('/', @parts) : 'index';
return _code_for($page_response_method)->(%args, skill_name => $skill_name, route_id => $route_id);
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_skill_nav_pages') {
my $route_ids_method = $sub->{route_ids_method} // die 'compiled sub route ids method missing';
my $load_skill_page_method = $sub->{load_skill_page_method} // die 'compiled sub load skill page method missing';
$impl = sub {
my ($self, $skill_name) = @_;
return [] if !$skill_name;
my %route_ids = _code_for($route_ids_method)->($self, $skill_name);
return [] if !%route_ids;
my @pages;
for my $entry (sort keys %route_ids) {
push @pages, _code_for($load_skill_page_method)->($self, skill_name => $skill_name, route_id => $route_ids{$entry});
}
return \@pages;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_all_skill_nav_pages') {
my $skill_nav_pages_method = $sub->{skill_nav_pages_method} // die 'compiled sub skill-nav-pages method missing';
$impl = sub {
my ($self) = @_;
my @pages;
for my $skill_root ($self->{manager}{paths}->installed_skill_roots) {
my ($skill_name) = $skill_root =~ m{/([^/]+)\z};
next if !defined $skill_name || $skill_name eq '';
push @pages, @{ _code_for($skill_nav_pages_method)->($self, $skill_name) || [] };
}
return \@pages;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'skill_dispatcher_skill_page_response') {
my $load_skill_page_method = $sub->{load_skill_page_method} // die 'compiled sub load skill page method missing';
$impl = sub {
my ($self, %args) = @_;
my $page = eval {
_code_for($load_skill_page_method)->($self, skill_name => $args{skill_name}, route_id => $args{route_id});
};
return [404, 'text/plain; charset=utf-8', "Skill bookmark '$args{route_id}' not found\n"] if !$page || $@;
return [200, 'text/plain; charset=utf-8', $page->{meta}{raw_instruction} || $page->canonical_instruction]
if !$args{app};
lib/PAX/StandaloneRuntime.pm view on Meta::CPAN
}
return;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_select_matches') {
my $unique_method = $sub->{unique_method} // die 'compiled sub unique method missing';
my $selection_method = $sub->{selection_method} // die 'compiled sub selection method missing';
$impl = sub {
my (%args) = @_;
my $matches = $args{matches} || [];
my @matches = _code_for($unique_method)->(@{$matches});
return if !@matches;
return @matches if @matches == 1;
for my $index (0 .. $#matches) {
print($index + 1, ": $matches[$index]\n");
}
print '> ';
my $selection = <STDIN>;
return @matches if !defined $selection;
chomp $selection;
my @chosen = _code_for($selection_method)->(
choices => $selection,
matches => \@matches,
);
return @chosen if @chosen;
return @matches if $selection eq '';
die "Invalid file selection '$selection'\n";
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_compile_regex') {
$impl = sub {
my ($pattern) = @_;
return if !defined $pattern || $pattern eq '';
my $regex = eval { qr/$pattern/i };
die "Invalid regex '$pattern': $@\n" if !$regex;
return $regex;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_scope_match_rank') {
my $compile_regex_method = $sub->{compile_regex_method} // die 'compiled sub compile-regex method missing';
$impl = sub {
my (%args) = @_;
my $file = $args{file} || '';
my $match_path = $args{match_path} || $file;
my @patterns = @{ $args{patterns} || [] };
my ($basename) = $match_path =~ m{([^/\\]+)$};
$basename ||= $match_path;
my $stem = $basename;
$stem =~ s{\.[^.]+$}{};
my $rank = 0;
for my $pattern (@patterns) {
next if !defined $pattern || $pattern eq '';
my $regex = _code_for($compile_regex_method)->($pattern);
my $score = 50;
my @components = grep { defined && $_ ne '' } split m{[\\/]+}, $match_path;
if ($basename =~ /\A(?:$pattern)\z/i) {
$score = 0;
} elsif ($stem =~ /\A(?:$pattern)\z/i) {
$score = 1;
} elsif ($basename =~ /\A(?:$pattern)/i) {
$score = 2;
} elsif ($basename =~ $regex) {
$score = 3;
} elsif (grep { $_ =~ /\A(?:$pattern)\z/i } @components) {
$score = 4;
} elsif ($match_path =~ $regex) {
$score = 5;
}
$rank += $score;
}
return $rank;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_ordered_scope_matches') {
my $rank_method = $sub->{rank_method} // die 'compiled sub rank method missing';
my $unique_method = $sub->{unique_method} // die 'compiled sub unique method missing';
$impl = sub {
my (%args) = @_;
my @patterns = @{ $args{patterns} || [] };
my @entries = @{ $args{entries} || [] };
@entries = map { { file => $_, match_path => $_ } } _code_for($unique_method)->(@{ $args{files} || [] }) if !@entries;
my @ranked;
for my $index (0 .. $#entries) {
push @ranked, {
file => $entries[$index]{file},
rank => _code_for($rank_method)->(
file => $entries[$index]{file},
match_path => $entries[$index]{match_path},
patterns => \@patterns,
),
index => $index,
};
}
return map { $_->{file} }
sort { $a->{rank} <=> $b->{rank} || $a->{index} <=> $b->{index} } @ranked;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_roots') {
$impl = sub {
my (%args) = @_;
my $paths = $args{paths} || die 'Missing path registry';
my @roots = (
Cwd::cwd(),
scalar($paths->current_project_root || ()),
$paths->workspace_roots,
$paths->project_roots,
@INC,
);
my %seen;
return grep { defined && $_ ne '' && -d $_ && !$seen{$_}++ } @roots;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_existing_named_files') {
$impl = sub {
my (%args) = @_;
my $roots = $args{roots} || [];
my $relative = $args{relative} || return;
my $prefixes = $args{prefixes} || [''];
my @found;
my %seen;
for my $root (@{$roots}) {
for my $prefix (@{$prefixes}) {
my $file = $prefix eq ''
? File::Spec->catfile($root, $relative)
: File::Spec->catfile($root, $prefix, $relative);
next if !-f $file || $seen{$file}++;
push @found, $file;
}
}
return sort @found;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_matching_archive_entries') {
$impl = sub {
my (%args) = @_;
my $zip = $args{zip} || return;
my $relative = $args{relative} || return;
my $suffix = $relative;
$suffix =~ s{\\}{/}g;
my @entries;
for my $member ($zip->members) {
my $entry_name = $member->fileName || next;
next if $entry_name !~ /(?:\A|\/)\Q$suffix\E\z/;
push @entries, $entry_name;
}
return @entries;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_cached_archive_source_path') {
$impl = sub {
my (%args) = @_;
my $paths = $args{paths} || die 'Missing path registry';
my $archive = $args{archive} || die 'Missing archive path';
my $entry = $args{entry} || die 'Missing archive entry';
my $digest = Digest::MD5::md5_hex(join "\0", $archive, $entry);
my @parts = grep { defined && $_ ne '' } split m{/+}, $entry;
return File::Spec->catfile(
$paths->cache_root,
'open-file',
'java-sources',
$digest,
@parts,
);
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_java_archive_roots') {
$impl = sub {
my (%args) = @_;
my $paths = $args{paths} || die 'Missing path registry';
my $roots = $args{roots} || [];
my @candidates = (
@{$roots},
File::Spec->catdir($paths->home, '.m2', 'repository'),
File::Spec->catdir($paths->home, '.gradle', 'caches'),
grep { defined && $_ ne '' } ($ENV{JAVA_HOME}, $ENV{JDK_HOME}),
);
my %seen;
return grep { defined && $_ ne '' && -d $_ && !$seen{$_}++ } @candidates;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_candidate_archives') {
my $archive_roots_method = $sub->{archive_roots_method} // die 'compiled sub archive roots method missing';
$impl = sub {
my (%args) = @_;
my $paths = $args{paths} || die 'Missing path registry';
my $roots = $args{roots} || [];
my @archives;
my %seen;
for my $root (_code_for($archive_roots_method)->(paths => $paths, roots => $roots)) {
File::Find::find(
{
no_chdir => 1,
wanted => sub {
return if !-f $_;
my $path = $File::Find::name;
return if $path !~ /(?:-sources\.jar|-src\.jar|src\.zip|source\.zip|\.war|\.jar)\z/i;
return if $seen{$path}++;
push @archives, $path;
},
},
$root,
);
}
return @archives;
};
return _install_sub_impl($package, $name, $sub->{prototype}, $impl);
}
if (($sub->{op} // '') eq 'open_file_extract_archive_sources') {
my $matching_archive_entries_method = $sub->{matching_archive_entries_method} // die 'compiled sub matching entries method missing';
my $cached_archive_source_path_method = $sub->{cached_archive_source_path_method} // die 'compiled sub cached path method missing';
$impl = sub {
lib/PAX/StandaloneRuntime.pm view on Meta::CPAN
my $proto = defined $prototype ? $prototype : '';
my $args = '$PAX_ARG0';
$args .= ', $PAX_ARG1' if scalar(@{ $shape->{args} // [] }) > 1;
return sprintf(
"sub %s%s {\n my (%s) = \@_;\n return PAX::StandaloneRuntime::_run_native_shape_sub(%s, %s, \@_);\n}\n",
$short,
$proto || '',
$args,
_perl_literal($full),
_perl_literal(JSON::PP->new->canonical(1)->encode($shape)),
);
}
# Extract the original subroutine source from the packaged script so runtime
# rewriting has an exact source range to replace.
sub _extract_sub_source_runtime {
my ($source, $sub_name) = @_;
return if $source !~ /\bsub\s+\Q$sub_name\E\b[^\{]*\{/g;
my $start = $-[0];
my $brace = index($source, '{', $+[0] - 1);
return if $brace < 0;
my $depth = 1;
my $i = $brace + 1;
while ($i < length($source)) {
my $char = substr($source, $i, 1);
$depth++ if $char eq '{';
$depth-- if $char eq '}';
if ($depth == 0) {
my $end = $i + 1;
while ($end < length($source) && substr($source, $end, 1) =~ /[ \t]/) {
$end++;
}
$end++ if $end < length($source) && substr($source, $end, 1) eq ';';
return substr($source, $start, $end - $start);
}
$i++;
}
return;
}
# Execute a compiled script sub through the packaged native-dispatch entry when
# the runtime emitted a matching native artifact.
sub _run_native_shape_sub {
my ($full, $shape_json, @args) = @_;
my $shape = ref($shape_json) eq 'HASH' ? $shape_json : _runtime_json_decode($shape_json);
my $expected = scalar @{ $shape->{args} // [] };
if ($expected && @args == $expected && _native_shape_args_are_i64(\@args)) {
my $result = _invoke_native_shape_runtime($full, $shape, \@args);
return $result->{value} if $result->{status} eq 'ok' && exists $result->{value};
}
return _interpret_native_shape($shape, \@args);
}
# Dispatch supported native-shape script subs through the runtime dispatcher and
# fall back to interpretation when no packaged artifact is available.
sub _invoke_native_shape_runtime {
my ($full, $shape, $args) = @_;
my $state = _state();
my $meta = $state->{by_region}{$full} || {};
return { status => 'fallback', reason => 'native region missing' } if !($meta->{executable_logical_path} // '');
my $probe = File::Spec->catfile($state->{root}, split m{/}, $meta->{executable_logical_path});
chmod 0700, $probe if -f $probe;
my $left = $args->[0];
my $right = @$args > 1 ? $args->[1] : 0;
return $state->{native_runner}->run_i64_binary(
path => $probe,
left => $left,
right => $right,
);
}
# Confirm that the current call arguments fit the narrow integer ABI used by
# packaged native script helpers.
sub _native_shape_args_are_i64 {
my ($args) = @_;
for my $arg (@$args) {
return 0 if !defined $arg || $arg !~ /\A-?\d+\z/;
}
return 1;
}
# Mirror the supported native shapes in Perl so deopt or unsupported dispatch
# can still run script-native candidates correctly.
sub _interpret_native_shape {
my ($shape, $args) = @_;
my $kind = $shape->{kind} // '';
if ($kind eq 'i64_binary_leaf') {
my ($left, $right) = @$args;
my $op = $shape->{op} // '';
return $left + $right if $op eq 'add';
return $left - $right if $op eq 'subtract';
return $left * $right if $op eq 'multiply';
return $left > $right ? 1 : 0 if $op eq 'greater_than';
}
if ($kind eq 'i64_sum_loop') {
my ($limit) = @$args;
return 0 if !defined $limit || $limit <= 0;
my $sum = 0;
for (my $i = 1; $i <= $limit; $i++) {
$sum += $i;
}
return $sum;
}
if ($kind eq 'i64_masked_mix_accum_loop') {
my ($limit) = @$args;
return 0 if !defined $limit || $limit <= 0;
my $acc = 0;
for (my $i = 0; $i < $limit; $i++) {
$acc += (($i * 13) ^ ($i >> 3)) & 0xFFFF;
}
return $acc;
}
die "unsupported native shape kind: $kind";
}
sub _install_sub_impl {
my ($package, $name, $prototype, $impl) = @_;
my $full = $package . '::' . $name;
no strict 'refs';
no warnings 'redefine';
if (defined $prototype && $prototype ne '') {
( run in 0.505 second using v1.01-cache-2.11-cpan-71847e10f99 )