view release on metacpan or  search on metacpan

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

            class => ref($op),
            name => eval { $op->name } || undef,
            desc => eval { $op->desc } || undef,
        };
        $op = eval { $op->next };
    }
    return \@ops;
}

sub _pad_layout {
    my ($cv) = @_;
    my $padlist = eval { $cv->PADLIST };
    return [] if !$padlist;
    my @pads;
    my @pad_entries = eval { $padlist->ARRAY };
    return [] if $@;
    for my $pad (@pad_entries) {
        my @items = eval { $pad->ARRAY };
        next if $@;
        push @pads, [
            map +{
                class => ref($_),
                name => eval { $_->can('PV') ? $_->PV : undef } || undef,
            }, @items
        ];
    }
    return \@pads;
}

sub _closure_descriptor {
    my ($cv) = @_;
    return {
        class => ref($cv),
        has_padlist => eval { $cv->PADLIST ? JSON::PP::true() : JSON::PP::false() } || JSON::PP::false(),
        file => eval { $cv->FILE } || undef,
        stash => eval { $cv->STASH->NAME } || undef,
    };
}

sub _subs {
    no strict 'refs';
    my @subs;
    for my $pkg (sort keys %{ _package_shapes() }) {
        my $stash = \%{$pkg . '::'};
        for my $sym (sort keys %$stash) {
            my $full = $pkg . '::' . $sym;
            my $code = *{$full}{CODE};
            next unless $code;
            my $summary = eval { _sub_optree_summary($full, $code) };
            push @subs, $summary || {
                name => $full,
                available => JSON::PP::false(),
                reason => "$@",
            };
        }
    }
    return \@subs;
}

my $ok = eval {
    local @ARGV = ();
    require File::Spec;
    open my $null_out, '>', File::Spec->devnull() or die "cannot open devnull: $!";
    open my $null_err, '>', File::Spec->devnull() or die "cannot open devnull: $!";
    local *STDOUT = $null_out;
    local *STDERR = $null_err;
    do $entrypoint;
    die $@ if $@;
    1;
};

if (!$ok) {
    push @diagnostics, {
        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) {