view release on metacpan or  search on metacpan

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

        level => 'error',
        code => 'entrypoint_execution_failed',
        message => "$@",
    };
}

my @loaded = sort grep { !exists $before_inc{$_} } keys %INC;
my $source = _slurp($entrypoint);
my $result = {
    runtime => {
        perl_version => "$^V",
        config_version => "$Config{version}",
        archname => "$Config{archname}",
        executable => $^X,
        config => _config_hash(),
    },
    capture => {
        mode => $mode,
        loaded_files => \@loaded,
        package_shapes => _package_shapes(),
        sub_optrees => _subs(),
        method_resolution => _method_resolution(),
        regex_metadata => _regex_metadata($source),
        compile_phase_events => _compile_phase_events($source),
    },
    diagnostics => \@diagnostics,
};

print JSON::PP->new->ascii(1)->canonical(1)->encode($result);
exit($ok ? 0 : 1);

sub _method_resolution {
    no strict 'refs';
    my %methods;
    for my $pkg (sort keys %{ _package_shapes() }) {
        my $stash = \%{$pkg . '::'};
        $methods{$pkg} = {
            mro => eval { require mro; [mro::get_linear_isa($pkg)] } || [$pkg],
            methods => [sort grep { *{$pkg . '::' . $_}{CODE} } keys %$stash],
        };
    }
    return \%methods;
}

sub _regex_metadata {
    my ($source) = @_;
    my @patterns;
    while ($source =~ m{(?:m|qr)?/((?:\\/|[^/])*)/[a-z]*}g) {
        push @patterns, {
            pattern => $1,
            locale_sensitive => $source =~ /\buse\s+locale\b/ ? JSON::PP::true() : JSON::PP::false(),
            unicode_sensitive => $source =~ /\buse\s+utf8\b/ ? JSON::PP::true() : JSON::PP::false(),
        };
    }
    return \@patterns;
}

sub _compile_phase_events {
    my ($source) = @_;
    my @events;
    for my $hook (qw(BEGIN UNITCHECK CHECK INIT END)) {
        while ($source =~ /\b\Q$hook\E\s*\{/g) {
            push @events, {
                hook => $hook,
                offset => pos($source) - length($hook) - 1,
                source => 'static_scan',
            };
        }
    }
    while ($source =~ /\buse\s+([A-Za-z_][A-Za-z0-9_:]*)/g) {
        push @events, { hook => 'use', module => $1, source => 'static_scan' };
    }
    while ($source =~ /\brequire\s+([A-Za-z_][A-Za-z0-9_:]*|["'][^"']+["'])/g) {
        push @events, { hook => 'require', target => $1, source => 'static_scan' };
    }
    return \@events;
}

sub _native_shape_for_sub {
    my ($name, $file) = @_;
    return undef if $name !~ /::(\w+)$/;
    my $sub_name = $1;
    my $source = _slurp($file || $entrypoint);
    my $body = _extract_sub_body($source, $sub_name);
    return undef if !defined $body;
    return _lower_i64_binary_leaf($body)
        || _lower_i64_sum_loop($body)
        || _lower_i64_masked_mix_accum_loop($body);
}

sub _extract_sub_body {
    my ($source, $sub_name) = @_;
    return if $source !~ /sub\s+\Q$sub_name\E\s*\{/g;
    my $start = pos($source);
    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 _lower_i64_binary_leaf {
    my ($body) = @_;
    return if $body !~ /my\s*\(\s*\$([A-Za-z_]\w*)\s*,\s*\$([A-Za-z_]\w*)\s*\)\s*=\s*\@_\s*;/s;
    my ($left, $right) = ($1, $2);
    return if $body !~ /return\s+\$([A-Za-z_]\w*)\s*([+\-*]|>)\s*\$([A-Za-z_]\w*)\s*;/s;
    return if $1 ne $left || $3 ne $right;
    my %ops = (
        '+' => ['add', 'left + right', 5],
        '-' => ['subtract', 'left - right', -1],
        '*' => ['multiply', 'left * right', 6],
        '>' => ['greater_than', 'if left > right { 1 } else { 0 }', 0],
    );
    my $op = $ops{$2} or return;
    return {
        kind => 'i64_binary_leaf',