package PAX::Capture;

our $VERSION = '0.018';

use strict;
use warnings;
use Cwd qw(abs_path);
use File::Spec;
use IPC::Open3;
use Symbol qw(gensym);

sub new {
    my ($class, %args) = @_;
    return bless {
        mode => $args{mode} // 'live',
    }, $class;
}

sub capture {
    my ($self, $entrypoint) = @_;
    my $abs = abs_path($entrypoint);
    if (!defined $abs || !-f $abs) {
        return {
            status => 'error',
            mode => $self->{mode},
            source_entrypoint => $entrypoint,
            diagnostics => [{
                level => 'error',
                code => 'entrypoint_not_found',
                message => "entrypoint not found: $entrypoint",
            }],
        };
    }

    my $probe = _probe_source();
    my ($out, $err, $exit) = _run_perl_probe($probe, $abs, $self->{mode});
    my $data = _decode_probe_output($out);
    my $features = _scan_source_features($abs);
    my @diagnostics;

    push @diagnostics, @{ $data->{diagnostics} // [] } if ref $data eq 'HASH';
    if ($err ne '') {
        push @diagnostics, {
            level => $exit == 0 ? 'warning' : 'error',
            code => 'perl_stderr',
            message => $err,
        };
    }
    if ($exit != 0) {
        push @diagnostics, {
            level => 'error',
            code => 'capture_failed',
            message => "reference Perl exited with status $exit",
        };
    }

    $data = {} if ref $data ne 'HASH';
    $data->{status} = $exit == 0 ? 'ok' : 'error';
    $data->{mode} = $self->{mode};
    $data->{source_entrypoint} = $abs;
    $data->{source_features} = $features;
    $data->{diagnostics} = \@diagnostics;
    return $data;
}

sub _scan_source_features {
    my ($path) = @_;
    open my $fh, '<', $path or return {};
    local $/;
    my $source = <$fh> // '';
    return {
        string_eval => $source =~ /\beval\s+["']/ ? 1 : 0,
        autoload => $source =~ /\bAUTOLOAD\b/ ? 1 : 0,
        tie => $source =~ /\btie\s*[\(\s]/ ? 1 : 0,
        overload => $source =~ /\buse\s+overload\b/ ? 1 : 0,
        typeglob => $source =~ /\*[A-Za-z_][A-Za-z0-9_:]*/ ? 1 : 0,
        xs_loader => $source =~ /\b(?:XSLoader|DynaLoader)\b/ ? 1 : 0,
        local_dynamic => $source =~ /\blocal\s+[$@%*]/ ? 1 : 0,
    };
}

sub _run_perl_probe {
    my ($probe, $entrypoint, $mode) = @_;
    my $err = gensym;
    my $pid = open3(my $in, my $out, $err, $^X, '-', $entrypoint, $mode);
    print {$in} $probe;
    close $in;

    local $/;
    my $stdout = <$out> // '';
    my $stderr = <$err> // '';
    waitpid($pid, 0);
    my $exit = $? >> 8;
    return ($stdout, $stderr, $exit);
}

sub _decode_probe_output {
    my ($out) = @_;
    require JSON::PP;
    my $decoded = eval { JSON::PP::decode_json($out) };
    if ($@) {
        return {
            diagnostics => [{
                level => 'error',
                code => 'probe_json_decode_failed',
                message => "$@",
            }],
            raw_probe_output => $out,
        };
    }
    return $decoded;
}

sub _probe_source {
    return <<'PERL';
use strict;
use warnings;
use JSON::PP ();
use Config;
use B qw(svref_2object);

my ($entrypoint, $mode) = @ARGV;
my @events;
my @diagnostics;
my %before_inc = %INC;
my %SOURCE_CACHE;

BEGIN { }

sub _config_hash {
    my @keys = qw(version archname useithreads usemultiplicity use64bitint use64bitall
                  ivsize nvsize ptrsize uselongdouble d_setlocale d_strtod useshrplib
                  libperl cc ccflags optimize);
    my %selected = map { $_ => (defined $Config{$_} ? "$Config{$_}" : undef) } @keys;
    return \%selected;
}

sub _package_shapes {
    no strict 'refs';
    my %packages;
    my %seen;
    _walk_stash('', \%::, \%packages, \%seen);
    return \%packages;
}

sub _walk_stash {
    my ($prefix, $stash, $packages, $seen) = @_;
    no strict 'refs';
    my $stash_id = "$stash";
    return if $seen->{$stash_id}++;
    for my $name (sort keys %$stash) {
        next unless $name =~ /::$/;
        my $pkg = $prefix . substr($name, 0, -2);
        my $full = $pkg . '::';
        my $glob = *{$full}{HASH};
        next if !defined $glob;
        my $child = $glob;
        my $child_id = "$child";
        $packages->{$pkg} = {
            symbol_count => scalar(keys %$child),
            symbols => [sort keys %$child],
        };
        _walk_stash($full, $child, $packages, $seen) if !$seen->{$child_id};
    }
}

sub _sub_optree_summary {
    my ($name, $code) = @_;
    my $obj = eval { svref_2object($code) };
    if ($@ || !$obj) {
        return {
            name => $name,
            available => JSON::PP::false(),
            reason => "$@",
        };
    }
    my $root = eval { $obj->ROOT };
    my $start = eval { $obj->START };
    return {
        name => $name,
        available => JSON::PP::true(),
        root_class => $root ? ref($root) : undef,
        start_class => $start ? ref($start) : undef,
        optree_ops => _walk_ops($start),
        pad_layout => _pad_layout($obj),
        closure_descriptor => _closure_descriptor($obj),
        native_shape => _native_shape_for_sub($name, eval { $obj->FILE }),
    };
}

sub _walk_ops {
    my ($start) = @_;
    my @ops;
    my %seen;
    my $op = $start;
    while ($op && @ops < 256) {
        my $id = eval { 0 + $$op };
        $id = ref($op) . ':' . scalar(@ops) if !defined $id;
        last if $seen{$id}++;
        push @ops, {
            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) {
        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);
}

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',
        op => $op->[0],
        args => [$left, $right],
        rust_expr => $op->[1],
        smoke_left => 2,
        smoke_right => 3,
        smoke_expected => $op->[2],
        source => 'capture_optree_unit',
    };
}

sub _lower_i64_sum_loop {
    my ($body) = @_;
    return if $body !~ /my\s*\(\s*\$([A-Za-z_]\w*)\s*\)\s*=\s*\@_\s*;/s;
    my $limit = $1;
    return if $body !~ /my\s+\$([A-Za-z_]\w*)\s*=\s*0\s*;/s;
    my $sum = $1;
    my $limit_ref = quotemeta('$' . $limit);
    my $sum_ref = quotemeta('$' . $sum);
    return if $body !~ /for\s*\(\s*my\s+\$([A-Za-z_]\w*)\s*=\s*1\s*;\s*\$\1\s*<=\s*$limit_ref\s*;\s*\$\1\+\+\s*\)\s*\{\s*$sum_ref\s*\+=\s*\$\1\s*;\s*\}/s;
    my $induction = $1;
    return if $body !~ /return\s+$sum_ref\s*;/s;
    return {
        kind => 'i64_sum_loop',
        op => 'sum_to_n',
        args => [$limit],
        accumulator => $sum,
        induction => $induction,
        smoke_left => 10,
        smoke_right => 0,
        smoke_expected => 55,
        rust_body => <<'RUST_BODY',
    if left <= 0 {
        return 0;
    }
    let mut sum: i64 = 0;
    let mut i: i64 = 1;
    while i <= left {
        sum += i;
        i += 1;
    }
    sum
RUST_BODY
        source => 'capture_optree_unit',
    };
}

sub _slurp {
    my ($path) = @_;
    return '' if !defined $path || $path eq '';
    return $SOURCE_CACHE{$path} if exists $SOURCE_CACHE{$path};
    open my $fh, '<', $path or return '';
    local $/;
    return $SOURCE_CACHE{$path} = (<$fh> // '');
}
PERL
}

1;
