view release on metacpan or  search on metacpan

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

        push @actions, {
            command => $command,
            action => $action,
        };
    }
    my $rest = substr($tail, pos($tail) || 0);
    return if !@actions;
    my $unknown_action = _compile_dispatch_unknown_action($rest);
    return {
        bootstrap_source => $bootstrap_source,
        command_default => _unescape_literal($default),
        command_default_mode => $mode eq '||' ? 'or' : 'defined_or',
        actions => \@actions,
        unknown_action => $unknown_action,
    };
}

sub _extract_braced_region {
    my ($source, $start) = @_;
    my $depth = 1;
    my $i = $start;
    while ($i < length($source)) {
        my $char = substr($source, $i, 1);
        $depth++ if $char eq '{';
        $depth-- if $char eq '}';
        return substr($source, $start, $i - $start) if $depth == 0;
        $i++;
    }
    return;
}

sub _compile_dispatch_action {
    my ($body) = @_;
    if ($body =~ /\A\s*print\s+([A-Za-z_][A-Za-z0-9_:]*)::([A-Za-z_][A-Za-z0-9_]*)\(\)\s*,\s*"\\n"\s*;\s*exit\s+(\d+)\s*;\s*\z/s) {
        return {
            op => 'print_call',
            target => $1 . '::' . $2,
            args => [],
            newline => 1,
            exit_code => 0 + $3,
        };
    }
    if ($body =~ /\A\s*print\s+([A-Za-z_][A-Za-z0-9_:]*)::([A-Za-z_][A-Za-z0-9_]*)\(\s*'([^'\\]*(?:\\.[^'\\]*)*)'\s*\)\s*,\s*"\\n"\s*;\s*exit\s+(\d+)\s*;\s*\z/s) {
        return {
            op => 'print_call',
            target => $1 . '::' . $2,
            args => [ _unescape_literal($3) ],
            newline => 1,
            exit_code => 0 + $4,
        };
    }
    if ($body =~ /\A\s*require\s+([A-Za-z_][A-Za-z0-9_:]*)\s*;\s*print\s+\$([A-Za-z_][A-Za-z0-9_:]*)::([A-Za-z_][A-Za-z0-9_]*)\s*,\s*"\\n"\s*;\s*exit\s+(\d+)\s*;\s*\z/s) {
        return {
            op => 'print_required_global',
            require_module => $1,
            symbol => $2 . '::' . $3,
            newline => 1,
            exit_code => 0 + $4,
        };
    }
    if ($body =~ /\APAX_EMBEDDED_ASSET_ROOT/ || $body =~ /\$ENV\{PAX_EMBEDDED_ASSET_ROOT\}/) {
        return {
            op => 'print_embedded_asset',
            logical_path => 'banner.txt',
        } if $body =~ /banner\.txt/;
    }
    return;
}

sub _compile_dispatch_unknown_action {
    my ($body) = @_;
    return if !defined $body || $body !~ /\S/;
    if ($body =~ /\A\s*print\s+STDERR\s+"([^"\\]*(?:\\.[^"\\]*)*)\$cmd([^"\\]*(?:\\.[^"\\]*)*)"\s*;\s*exit\s+(\d+)\s*;\s*\z/s) {
        return {
            op => 'stderr_interpolate_cmd',
            prefix => _unescape_literal($1),
            suffix => _unescape_literal($2),
            exit_code => 0 + $3,
        };
    }
    return;
}

sub _unescape_literal {
    my ($value) = @_;
    $value //= '';
    $value =~ s/\\"/"/g;
    $value =~ s/\\'/'/g;
    $value =~ s/\\\\/\\/g;
    $value =~ s/\\n/\n/g;
    $value =~ s/\\t/\t/g;
    return $value;
}

sub _hybrid_compiled_unit {
    my ($path, $kind, $logical_path, $package, $initializers, $subs, $unsupported_subs, $source) = @_;
    my $bootstrap_source = _bootstrap_source($source);
    my %residual_sub_sources;
    for my $full (@$unsupported_subs) {
        my ($short) = $full =~ /::([^:]+)\z/;
        next if !$short;
        my $sub_source = _extract_sub_source($source, $short) or next;
        $residual_sub_sources{$full} = $sub_source;
    }
    my $residual_mode = 'per_sub';
    if (_bootstrap_has_shared_lexicals($bootstrap_source)) {
        %residual_sub_sources = ();
        $residual_mode = 'module';
    }
    if (@$unsupported_subs != scalar(keys %residual_sub_sources)) {
        %residual_sub_sources = ();
        $residual_mode = 'module';
    }
    my $record = {
        format => 'pcu_v1',
        package => $package,
        source_kind => $kind,
        require_path => _require_path_for($path, $package),
        initializers => $initializers,
        subs => $subs,
        unsupported_subs => $unsupported_subs,