view release on metacpan or  search on metacpan

lib/PAX/StandaloneImage.pm  view on Meta::CPAN

        lib_dirs => $lib_dirs,
        source_roots => $source_roots,
        assets => [
            map { $_->{source_path} }
                grep { defined($_->{source_path}) && $_->{source_path} ne '' && -f $_->{source_path} }
                @{ $manifest->{assets} // [] }
        ],
        asset_dirs => (($manifest->{asset_count} // 0) > 0 ? [ File::Spec->catdir($extract_root, 'assets') ] : []),
        cpanfiles => [],
        runtime_mode => $manifest->{runtime}{mode},
        app_name => $manifest->{app}{name},
        app_namespace => $manifest->{app}{namespace},
        app_legacy_namespace => $manifest->{app}{compat}{legacy_namespace},
        app_entrypoint_env => $manifest->{app}{entrypoint_env},
        app_entrypoint_fallback => $manifest->{app}{entrypoint_fallback},
        app_command => $manifest->{app}{command},
    };
}

# Detect executable Perl scripts that should be compiled as scripts rather than
# treated as already-built standalone binaries.
sub _looks_like_plain_script_entrypoint {
    my ($entrypoint) = @_;
    open my $fh, '<:raw', $entrypoint or return 0;
    read($fh, my $prefix, 128);
    close $fh;
    return $prefix =~ /\A#!/ ? 1 : 0;
}

sub _standalone_inspect_json {
    my ($entrypoint) = @_;
    my $pid = open my $fh, '-|';
    return '' if !defined $pid;
    if (!$pid) {
        open STDERR, '>', File::Spec->devnull or die "cannot open devnull: $!";
        exec {$entrypoint} $entrypoint, '--pax-standalone-inspect';
        exit 127;
    }
    local $/;
    my $json = <$fh> // '';
    close $fh;
    return ($? >> 8) == 0 ? $json : '';
}

sub _standalone_extract_quietly {
    my ($entrypoint, $extract_root) = @_;
    my $pid = fork();
    return 0 if !defined $pid;
    if (!$pid) {
        open STDOUT, '>', File::Spec->devnull or die "cannot open devnull: $!";
        open STDERR, '>', File::Spec->devnull or die "cannot open devnull: $!";
        exec {$entrypoint} $entrypoint, '--pax-standalone-extract', $extract_root;
        exit 127;
    }
    waitpid($pid, 0);
    return ($? >> 8) == 0 ? 1 : 0;
}

sub _extract_payload_path {
    my ($root, $prefix, $logical_path) = @_;
    my @parts = grep { defined && $_ ne '' } split m{/+}, ($logical_path // '');
    return File::Spec->catfile($root, $prefix, @parts);
}

sub _extracted_manifest_path {
    my ($root, $prefix, $logical_path) = @_;
    my $path = _extract_payload_path($root, $prefix, $logical_path);
    return '' if !defined $path || $path eq '' || !-f $path;
    return $path;
}

sub _materialize_entrypoint_source {
    my ($extract_root, $entrypoint) = @_;
    my $bytes = $entrypoint->{source_bytes} // '';
    return '' if $bytes eq '';

    my $name = _logical_name($entrypoint->{source_path} || $entrypoint->{logical_path} || 'entrypoint.pl');
    $name =~ s/\.(?:script|dispatch|cli-router|service)\.json\z/.pl/;
    $name .= '.pl' if $name !~ /\.[A-Za-z0-9]+\z/;

    my $dir = File::Spec->catdir($extract_root, 'source-entrypoint');
    mkdir $dir if !-d $dir;
    my $path = File::Spec->catfile($dir, $name);
    open my $fh, '>:raw', $path or return '';
    print {$fh} $bytes;
    close $fh or return '';
    return $path;
}

sub _materialize_manifest_source_tree {
    my ($extract_root, $manifest) = @_;
    my @source_items = grep {
        my $kind = $_->{unit_kind} // '';
        my $bytes = $_->{source_bytes} // '';
        ($kind eq 'lib' || $kind eq 'source' || $kind eq 'entrypoint')
            && $bytes ne ''
            && ($_->{source_path} // '') ne '';
    } @{ $manifest->{code_units} // [] };
    my $entry = $manifest->{entrypoint} // {};
    push @source_items, {
        unit_kind => 'entrypoint',
        source_path => $entry->{source_path},
        source_bytes => $entry->{source_bytes},
    } if ($entry->{source_path} // '') ne '' && ($entry->{source_bytes} // '') ne '';
    return {} if !@source_items;

    my $root = _common_source_parent(map { $_->{source_path} } @source_items);
    return {} if $root eq '';

    my $rebuild_root = File::Spec->catdir($extract_root, 'rebuild-source');
    make_path($rebuild_root) if !-d $rebuild_root;

    my %written;
    my $materialized_entrypoint = '';
    for my $item (@source_items) {
        my $source_path = $item->{source_path} // next;
        my $bytes = $item->{source_bytes} // '';
        next if $bytes eq '';
        my $rel = File::Spec->abs2rel($source_path, $root);
        next if !defined $rel || $rel eq '' || $rel =~ /^\.\.(?:\/|\\|$)/;
        my $dest = File::Spec->catfile($rebuild_root, split m{/+|\\+}, $rel);
        next if $written{$dest}++;
        my ($vol, $dirs) = File::Spec->splitpath($dest);
        make_path($dirs) if $dirs ne '' && !-d $dirs;
        open my $fh, '>:raw', $dest or return {};
        print {$fh} $bytes;
        close $fh or return {};
        if (($item->{unit_kind} // '') eq 'entrypoint') {
            $materialized_entrypoint = $dest;
        }
    }
    return {} if $materialized_entrypoint eq '' || !-f $materialized_entrypoint;

    return {
        entrypoint => $materialized_entrypoint,
        lib_dirs => _materialized_manifest_roots($manifest, 'lib_dirs', 'lib', $root, $rebuild_root),
        source_roots => _materialized_manifest_roots($manifest, 'source_roots', 'source', $root, $rebuild_root),
    };
}

sub _materialized_manifest_roots {
    my ($manifest, $field, $unit_kind, $source_root, $rebuild_root) = @_;
    my @roots;
    my %seen;
    for my $logical_root (@{ $manifest->{$field} // [] }) {
        next if !defined $logical_root || $logical_root eq '';
        my $original_root = _manifest_source_root_for_logical($manifest, $logical_root, $unit_kind);
        next if !defined $original_root || $original_root eq '';
        my $rel = File::Spec->abs2rel($original_root, $source_root);
        next if !defined $rel || $rel eq '' || $rel =~ /^\.\.(?:\/|\\|$)/;
        my $materialized = File::Spec->catdir($rebuild_root, split m{/+|\\+}, $rel);
        next if !-d $materialized || $seen{$materialized}++;
        push @roots, $materialized;
    }
    return \@roots;
}

sub _common_source_parent {
    my @paths = grep { defined && $_ ne '' } @_;
    return '' if !@paths;
    my @common = File::Spec->splitdir(dirname(shift @paths));
    for my $path (@paths) {
        my @parts = File::Spec->splitdir(dirname($path));
        my $limit = @common < @parts ? scalar(@common) : scalar(@parts);
        my $i = 0;
        $i++ while $i < $limit && $common[$i] eq $parts[$i];
        splice @common, $i;
        last if !@common;
    }
    return File::Spec->catdir(@common);
}

sub _extracted_manifest_roots {
    my ($root, $prefix, $logical_roots) = @_;
    my @roots;
    my %seen;
    for my $logical_root (@{ $logical_roots // [] }) {
        next if !defined $logical_root || $logical_root eq '';
        my @parts = grep { defined && $_ ne '' } split m{/+}, $logical_root;
        my $path = File::Spec->catdir($root, $prefix, @parts);
        next if !-d $path || $seen{$path}++;
        push @roots, $path;
    }
    return \@roots;
}

sub _original_manifest_roots {
    my ($manifest, $field, $unit_kind) = @_;
    my @roots;
    my %seen;
    for my $logical_root (@{ $manifest->{$field} // [] }) {
        next if !defined $logical_root || $logical_root eq '';
        my $root = _original_source_root_for_logical($manifest, $logical_root, $unit_kind);
        next if !defined $root || $root eq '' || !-d $root || $seen{$root}++;
        push @roots, $root;
    }
    return \@roots;
}

sub _original_source_root_for_logical {
    my ($manifest, $logical_root, $unit_kind) = @_;
    my $root = _manifest_source_root_for_logical($manifest, $logical_root, $unit_kind);
    return if !defined $root || $root eq '' || !-d $root;
    return $root;
}

sub _manifest_source_root_for_logical {
    my ($manifest, $logical_root, $unit_kind) = @_;
    for my $unit (@{ $manifest->{code_units} // [] }) {
        my $logical_path = $unit->{logical_path} // '';
        my $source_path = $unit->{source_path} // '';
        my $kind = $unit->{unit_kind} // '';
        next if $logical_path eq '' || $source_path eq '';
        next if defined $unit_kind && $unit_kind ne '' && $kind ne $unit_kind;
        next if index($logical_path, $logical_root . '/') != 0;
        my $rel = substr($logical_path, length($logical_root) + 1);
        next if $rel eq '';
        my @rel_parts = split m{/+}, $rel;
        my @source_parts = File::Spec->splitdir(dirname($source_path));
        splice @source_parts, -(@rel_parts - 1) if @rel_parts > 1;
        my $root = File::Spec->catdir(@source_parts);
        return $root if $root ne '';
    }
    return;
}

sub load {
    my ($self, %args) = @_;
    my $name = $args{name} // die 'name required';
    my $path = File::Spec->catfile($self->{root}, $name, 'manifest.json');
    open my $fh, '<', $path or die "cannot read standalone image $path: $!";
    local $/;
    return JSON::PP::decode_json(<$fh>);
}

sub path_for {
    my ($self, $name) = @_;
    return File::Spec->catfile($self->{root}, $name, 'manifest.json');
}

sub _default_name {
    my ($entrypoint) = @_;
    my ($vol, $dir, $file) = File::Spec->splitpath($entrypoint);
    $file =~ s/\.[^.]+\z//;
    $file =~ s/[^A-Za-z0-9_.-]+/-/g;
    return $file || 'pax-standalone';
}

sub _app_metadata {
    my (%args) = @_;
    my $entrypoint = $args{entrypoint} // '';
    my $image_name = $args{image_name} // 'pax-standalone';
    my $app_name = $args{app_name} // $image_name;
    my $command_fallback = _entrypoint_default_command($entrypoint);
    my $command = $args{app_command} // $command_fallback;
    my $entrypoint_env = $args{app_entrypoint_env};
    my $entrypoint_fallback = $args{app_entrypoint_fallback} // $command_fallback;
    my $legacy_namespace = _normalize_namespace($args{app_legacy_namespace});
    my $compat_namespace = _normalize_namespace($args{app_namespace});
    $legacy_namespace = $compat_namespace if $legacy_namespace eq '';

    return {
        name => $app_name,
        namespace => $compat_namespace,
        compat => {
            namespace => $compat_namespace,
            legacy_namespace => $legacy_namespace,
        },
        command => $command,
        entrypoint_env => $entrypoint_env // '',
        entrypoint_fallback => $entrypoint_fallback,
        entrypoint_command => $command,
    };
}

sub _safe_dir_abs {
    my ($path) = @_;
    return '' if !defined $path || $path eq '';

lib/PAX/StandaloneImage.pm  view on Meta::CPAN

    return @roots;
}

sub _pax_runtime_helper_modules {
    my @helpers = qw(
        PAX/StandaloneRuntime.pm
        PAX/NativeRunner.pm
        PAX/GuardManager.pm
        PAX/DeoptEngine.pm
    );
    my @roots = _pax_runtime_helper_lib_roots();
    return () if !@roots;
    my %seen;
    my @modules;
    for my $rel (@helpers) {
        my $path = _helper_module_path($rel, \@roots);
        next if !-f $path;
        my $source = _slurp_bytes($path);
        while ($source =~ /^\s*use\s+([A-Za-z_][A-Za-z0-9_:]*)\b/gm) {
            my $module = $1;
            next if $module =~ /^PAX::/;
            push @modules, $module if !$seen{$module}++;
        }
        while ($source =~ /^\s*require\s+([A-Za-z_][A-Za-z0-9_:]*)\b/gm) {
            my $module = $1;
            next if $module =~ /^PAX::/;
            push @modules, $module if !$seen{$module}++;
        }
    }
    for my $module (qw(XSLoader)) {
        push @modules, $module if !$seen{$module}++;
    }
    return @modules;
}

sub _pax_runtime_helper_module_files {
    my @roots = _pax_runtime_helper_lib_roots();
    my @modules = _pax_runtime_helper_modules();
    my @files;
    my %seen;
    for my $rel (_pax_runtime_helper_relative_paths()) {
        my $path = _helper_module_path($rel, \@roots);
        next if !$path;
        push @files, $path if !$seen{$path}++;
    }
    for my $module (@modules) {
        my $path = _locate_module_runtime_file($module) or next;
        push @files, $path if !$seen{$path}++;
    }
    for my $path (_probe_loaded_runtime_files(modules => \@modules, lib_dirs => [])) {
        push @files, $path if !$seen{$path}++;
    }
    return @files;
}

sub _helper_module_path {
    my ($rel, $roots) = @_;
    return if !$rel;
    for my $root (@{ $roots // [] }) {
        next if !defined $root || $root eq '';
        my $path = File::Spec->catfile($root, split m{/}, $rel);
        return $path if -f $path;
    }
    return;
}

sub _probe_loaded_runtime_files {
    my (%args) = @_;
    my @modules = @{ $args{modules} // [] };
    return () if !@modules;

    my ($fh, $path) = tempfile(
        'pax-runtime-probe-XXXXXX',
        SUFFIX => '.pl',
        TMPDIR => 1,
        UNLINK => 1,
    );
    print {$fh} <<'PL';
use strict;
use warnings;
use JSON::PP qw(encode_json decode_json);

my $payload = decode_json($ENV{PAX_RUNTIME_PROBE_PAYLOAD} // '{}');
unshift @INC, @{ $payload->{lib_dirs} // [] };
my %before = map { $_ => 1 } keys %INC;

for my $module (@{ $payload->{modules} // [] }) {
    (my $require_path = $module) =~ s{::}{/}g;
    $require_path .= '.pm';
    eval { require $require_path; 1 } or next;
}

my @files;
for my $key (sort keys %INC) {
    next if $before{$key};
    my $value = $INC{$key};
    next if !defined $value || ref $value;
    push @files, $value if $value ne '';
}

print encode_json(\@files);
PL
    close $fh;

    my $payload = JSON::PP->new->ascii(1)->canonical(1)->encode({
        modules => \@modules,
        lib_dirs => [ map { abs_path($_) || $_ } @{ $args{lib_dirs} // [] } ],
    });
    local $ENV{PAX_RUNTIME_PROBE_PAYLOAD} = $payload;
    my $output = qx{$^X $path};
    my $exit = $? >> 8;
    return () if $exit != 0 || !defined $output || $output eq '';
    my $decoded = eval { JSON::PP::decode_json($output) };
    return () if $@ || ref($decoded) ne 'ARRAY';
    my %seen;
    return grep { defined $_ && -f $_ && !$seen{$_}++ } @$decoded;
}

sub _related_xs_files {
    my ($module, $source, $inc_dirs) = @_;
    my @parts = split /::/, $module;