#!/bin/sh
set -eu

status=0

check_controller_forbidden_persistence() {
    file="$1"

    if grep -nE -- '->resultset[[:space:]]*\(|DBIx::Class|GPForum::Schema' "$file"; then
        echo "architecture-check: controller persistence boundary violation in $file" >&2
        status=1
    fi
}

check_os_specific_logic() {
    if grep -RInE -- '\$\^O|OSNAME' lib t script bin \
        | grep -vE '^lib/GPForum/OS([.]pm|/[^:]*[.]pm):' \
        | grep -vE '^script/architecture-check:'; then
        echo "architecture-check: OS-specific logic must live behind lib/GPForum/OS*.pm" >&2
        status=1
    fi
}

check_query_topology_gate() {
    if ! script/query-plan-check >/dev/null; then
        echo "architecture-check: query topology/static hot-path gate failed" >&2
        status=1
    fi
}

check_template_business_logic() {
    if [ ! -d templates ]; then
        return
    fi

    if grep -RInE -- 'resultset|DBIx::Class|GPForum::Schema|->search[[:space:]]*\(|->create[[:space:]]*\(|->update[[:space:]]*\(|->delete[[:space:]]*\(|gp_[[:alnum:]_]+' templates; then
        echo "architecture-check: templates must render prepared view models only" >&2
        status=1
    fi
}

check_authority_language() {
    if grep -RInE -- 'cache[^[:cntrl:]]*authoritative|authoritative[^[:cntrl:]]*cache|projection[^[:cntrl:]]*authoritative|authoritative[^[:cntrl:]]*projection' lib templates script bin \
        | grep -vE '^script/architecture-check:'; then
        echo "architecture-check: cache/projection authority language is forbidden in runtime code" >&2
        status=1
    fi
}

# Entrypoint layout rule; see docs/ENTRYPOINTS.md.
#
# bin/    Perl application entrypoints (deployed; load GPForum::* at runtime).
# script/ repository tooling for developers and CI (not deployed).
#
# script/ holds no wrapper of a bin/ entrypoint (bin/gpforum VERB runs it),
# so no basename may appear in both directories, and the allowlist below
# stays empty.
ENTRYPOINT_COLLISION_ALLOWLIST=''

is_allowed_entrypoint_collision() {
    candidate="$1"

    for allowed in $ENTRYPOINT_COLLISION_ALLOWLIST; do
        if [ "$candidate" = "$allowed" ]; then
            return 0
        fi
    done

    return 1
}

check_entrypoint_layout() {
    for file in bin/*; do
        [ -f "$file" ] || continue
        name=${file#bin/}

        if ! head -n 1 "$file" | grep -q -- 'perl'; then
            echo "architecture-check: bin/ takes Perl entrypoints only: $file" >&2
            status=1
        fi

        if [ ! -x "$file" ]; then
            echo "architecture-check: $file must be executable" >&2
            status=1
        fi

        if [ -e "script/$name" ] && ! is_allowed_entrypoint_collision "$name"; then
            echo "architecture-check: $name exists in both bin/ and script/; see docs/ENTRYPOINTS.md" >&2
            status=1
        fi
    done

    for file in script/*; do
        [ -f "$file" ] || continue

        if [ ! -x "$file" ]; then
            echo "architecture-check: $file must be executable" >&2
            status=1
        fi

        targets=$(grep -o -- 'bin/gpforum[a-z0-9-]*' "$file" | sort -u || true)
        for target in $targets; do
            if [ ! -f "$target" ]; then
                echo "architecture-check: $file wraps a missing entrypoint: $target" >&2
                status=1
            fi
        done
    done
}

check_internal_dependency_cycles() {
    if ! perl -MFile::Find -e '
        my %file_for;
        find(
            {
                no_chdir => 1,
                wanted => sub {
                    return if !/[.]pm\z/;
                    my $path = $File::Find::name;
                    ( my $module = $path ) =~ s{\Alib/|[.]pm\z}{}g;
                    $module =~ s{/}{::}g;
                    $file_for{$module} = $path;
                },
            },
            q{lib}
        );

        my %edges;
        for my $module ( keys %file_for ) {
            open my $handle, q{<}, $file_for{$module}
              or die qq{cannot read $file_for{$module}: $!};
            my $in_pod = 0;
            while ( my $line = <$handle> ) {
                last if $line =~ /\A__ (?: END | DATA ) __/msx;
                if ( $line =~ /\A=cut\b/msx ) { $in_pod = 0; next; }
                if ( $line =~ /\A=\w+/msx )   { $in_pod = 1; next; }
                next if $in_pod;
                next if $line =~ /\A\s*[#]/msx;
                while ( $line =~ /\buse\s+(GPForum(?:::\w+)+)/gmsx ) {
                    push @{ $edges{$module} }, $1 if exists $file_for{$1};
                }
            }
            close $handle or die qq{cannot close $file_for{$module}: $!};
        }

        my ( @stack, %seen, %active, @cycles );
        sub walk {
            my ($module) = @_;
            $seen{$module}   = 1;
            $active{$module} = 1;
            push @stack, $module;

            for my $next ( @{ $edges{$module} || [] } ) {
                if ( !$seen{$next} ) {
                    walk($next);
                }
                elsif ( $active{$next} ) {
                    my @cycle = @stack;
                    shift @cycle while @cycle && $cycle[0] ne $next;
                    push @cycles, [ @cycle, $next ];
                }
            }

            pop @stack;
            delete $active{$module};
            return;
        }

        for my $module ( keys %file_for ) {
            walk($module) if !$seen{$module};
        }

        if (@cycles) {
            print join qq{\n}, map { join q{ -> }, @{$_} } @cycles;
            print qq{\n};
            exit 1;
        }

        exit 0;
    '; then
        echo "architecture-check: internal GPForum dependency cycle detected" >&2
        status=1
    fi
}

# Every script/ and bin/ path invoked from a CI workflow, the Makefile or
# another entrypoint must exist. A rename that updates the tree but not its callers leaves the release
# and platform gates permanently red while the badges still look plausible,
# because a workflow that cannot find its entrypoint only fails at run time.
#
# Only repository-relative paths count: an absolute /usr/bin/perl, a glob such
# as 'script/staging-*' in a paths: filter, and a runner-installed ~/bin tool
# are not this repository's entrypoints.
check_entrypoint_references() {
    for source in .github/workflows/*.yml Makefile script/* bin/*; do
        [ -f "$source" ] || continue

        references=$(perl -ne '
            while ( m{ (?<! [/\w.~-] ) ( (?:script|bin) / [\w-]+ (?: [.] [\w-]+ )* ) }gx ) {
                my $path = $1;
                next if $path =~ m{[*?]};
                next if $path =~ m{-\z};
                print "$path\n";
            }
        ' "$source" | sort -u)

        for reference in $references; do
            [ -e "$reference" ] && continue
            echo "architecture-check: $source references missing entrypoint $reference" >&2
            status=1
        done
    done
}

# A PostgreSQL unique violation aborts the whole transaction: every statement
# after it fails with SQLSTATE 25P02 until a ROLLBACK or a ROLLBACK TO
# SAVEPOINT. So an error captured by a bare `eval` inside an open txn_do can
# never be used to recover — the recovery branch is unreachable code, and the
# in-memory test doubles cannot show it because they have no storage layer.
#
# GPForum::Infrastructure::UniqueConflict->attempt is the primitive that gets
# this right: it wraps the attempt in a savepoint and returns ($value, $error).
# The invariant is therefore not "no eval" — defensive evals are fine — but
# that $EVAL_ERROR and $@ must never reach conflict recovery.
check_unique_conflict_recovery() {
    offenders=$(grep -rnE \
        '(_after_conflict|_after_unique|UniqueConflict->(rethrow|is_conflict(_on)?))[[:space:]]*\(.*\$(EVAL_ERROR|@)' \
        lib --include='*.pm' || true)

    if [ -n "$offenders" ]; then
        echo "$offenders" | while IFS= read -r offender; do
            echo "architecture-check: hand-caught error feeds conflict recovery;" \
                "use UniqueConflict->attempt: $offender" >&2
        done
        status=1
    fi
}

check_universal_can_override() {
    # A `sub can` in a class overrides UNIVERSAL::can for every caller, so
    # $object->can('some_method') stops reporting whether the method exists.
    # Two authorization classes did this, and it bit for real when
    # search_condition was added: the capability probe called the authorization
    # method instead. Authorization methods are named `permits`.
    offenders=$(grep -rnE '^sub can[[:space:]]*[({]' lib t --include='*.pm' \
        2>/dev/null || true)

    if [ -n "$offenders" ]; then
        echo "$offenders" | while IFS= read -r offender; do
            echo "architecture-check: sub can overrides UNIVERSAL::can;" \
                "name it permits: $offender" >&2
        done
        status=1
    fi
}

check_column_reader_empty_list() {
    # A column reader that ends in a bare `return;` yields the empty LIST in
    # list context, and these are called from inside hash literals: a missing
    # row then shifts every following key by one, with nothing but "Odd number
    # of elements" to show for it. Readers delegate to
    # GPForum::Infrastructure::Row, which returns undef.
    offenders=$(find lib -name '*.pm' -exec awk '
        /^sub _?column(_[a-z_]+)? ?\(/ { inside = 1; name = $0; line = FNR; last_return = "" }
        inside && /^[[:space:]]*return[[:space:]]*;[[:space:]]*$/ { last_return = FNR }
        inside && /^\}/ {
            if (last_return != "") {
                printf "%s:%d: %s\n", FILENAME, last_return, name
            }
            inside = 0
        }
    ' {} + 2>/dev/null || true)

    if [ -n "$offenders" ]; then
        echo "$offenders" | while IFS= read -r offender; do
            echo "architecture-check: column reader returns the empty list;" \
                "delegate to GPForum::Infrastructure::Row: $offender" >&2
        done
        status=1
    fi
}

check_subroutine_prototypes() {
    # Perl::Critic lost ProhibitSubroutinePrototypes when this tree adopted
    # signatures: PPI 1.291 tokenizes `sub f ($self, $x)` as a prototype and
    # the policy cannot tell the two apart. The check is replaced rather than
    # dropped, and it can be exact -- a real prototype holds only sigils and
    # punctuation, while every signature here names at least one variable.
    # Under `use v5.40` (ADR 0117) a prototype can only be written as the
    # :prototype(...) attribute, which no policy reads, so that spelling is
    # refused too. It reads every Perl file the other gates read, script/'s
    # programs without a .pl extension included.
    offenders=$(perl_files | xargs grep -nHE \
        '^sub [A-Za-z_][A-Za-z0-9_]*[[:space:]]*\([$@%;*&\\[:space:]]*\)[[:space:]]*\{|(^|[^[:alnum:]_])sub([[:space:]][^{;#]*)?:[[:space:]]*prototype[[:space:]]*\(' \
        2>/dev/null || true)

    if [ -n "$offenders" ]; then
        echo "$offenders" | while IFS= read -r offender; do
            echo "architecture-check: subroutine prototype; use a signature:" \
                "$offender" >&2
        done
        status=1
    fi
}

# The Perl files the gates read, as script/perlcritic and script/perltidy-check
# select them: bin/, every .pm, .pl and .t under lib/ and t/, and the programs
# in script/ whose first line names perl.
perl_files() {
    find lib t bin script -type f \( -path 'bin/*' -o -name '*.pm' -o -name '*.pl' -o -name '*.t' \) 2>/dev/null
    for candidate in script/*; do
        if [ -f "$candidate" ] && head -n 1 "$candidate" | grep -q perl; then
            echo "$candidate"
        fi
    done
}

# A Perl file as the gates below read its code: one entry per line, with POD,
# heredoc bodies and everything from __END__ or __DATA__ on left empty. A
# heredoc's lines start at column 0 whatever block they sit in, so read as
# code one would close a catch block it is written in. Text that only looks
# like a heredoc -- "<<TEXT" inside a string -- would leave every line after
# it unread, so a heredoc that no line ends stops the gate: perl itself
# refuses a real one, and such text has to be written so it does not look
# like one.
CODE_LINES_PERL='
sub code_lines {
    my ($file) = @_;
    open my $handle, q{<}, $file or die qq{cannot read $file: $!};
    my @lines = <$handle>;
    close $handle or die qq{cannot close $file: $!};
    chomp @lines;

    my ( $in_pod, $ended, $number, @pending ) = ( 0, 0, 0 );
    for my $line (@lines) {
        $number++;
        if ($ended) { $line = q{}; next; }
        if (@pending) {
            my ( $indented, $terminator ) = @{ $pending[0] };
            my $last = $indented
              ? $line =~ /\A \s* \Q$terminator\E \z/msx
              : $line eq $terminator;
            shift @pending if $last;
            $line = q{};
            next;
        }
        if ( $line =~ /\A__ (?: END | DATA ) __\s*\z/msx ) {
            $ended = 1;
            $line  = q{};
            next;
        }
        if ( $line =~ /\A=cut\b/msx ) { $in_pod = 0; $line = q{}; next; }
        if ( $line =~ /\A=[[:alpha:]]/msx ) { $in_pod = 1; }
        if ($in_pod) { $line = q{}; next; }
        next if $line =~ /\A \s* [#]/msx;
        # A quoted terminator may follow the << after spaces; a bare one may
        # not.
        while ( $line =~ /<< (~?) (?: \s* "([[:alpha:]_]\w*)" | \s* \x27([[:alpha:]_]\w*)\x27 | ([[:alpha:]_]\w*) )/gmsx ) {
            push @pending, [ $1, $2 // $3 // $4, $number ];
        }
    }
    if (@pending) {
        my ( undef, $terminator, $opened ) = @{ $pending[0] };
        die qq{$file:$opened: no line ends the heredoc <<$terminator begun here;}
          . qq{ text that only looks like one has to be written so it does not\n};
    }

    return @lines;
}

# The index of the line that closes the block opened on line $index:
# perltidy keeps a closing brace at the indentation of the line that opened
# its block, so it is the first later line indented no deeper.
sub closing_line {
    my ( $lines, $index ) = @_;
    $lines->[$index] =~ /\A ([ ]*)/msx;
    my $indent = length $1;
    for my $next ( $index + 1 .. $#{$lines} ) {
        next if $lines->[$next] !~ /\S/msx;
        $lines->[$next] =~ /\A ([ ]*)/msx;
        return $next if length $1 <= $indent;
    }

    return undef;
}

# A catch opening its line, or right after the brace that closes its try
# block; the catch variable when it names one.
sub catch_opening {
    my ($line) = @_;
    return undef
      if $line !~ /\A [ ]* (?: (?: try \b [^#]* )? [}] \s* )? catch \b \s* (?: [(] | [{] )/msx;
    my ($variable) = $line =~ /catch \s* [(] \s* \$ (\w+) \s* [)]/msx;

    return $variable // q{};
}
'

# ADR 0117: every native try/catch ends with "};". PPI, which Perl::Critic
# reads the code through, takes a catch block that ends in a bare "}" as an
# unfinished statement and swallows the statement after it into the same
# one: RequireFinalReturn then misfires on a sub that ends in try/catch, and
# every policy reads the next statement wrongly.
check_try_catch_closed() {
    if ! perl_files | xargs perl -e "$CODE_LINES_PERL"'
        my $failed = 0;
        for my $file (@ARGV) {
            my @lines = code_lines($file);
            for my $index ( 0 .. $#lines ) {
                my $line = $lines[$index];
                next if !defined catch_opening($line);

                my $where = $file . q{:} . ( $index + 1 );
                # A catch block on one line ends on that line.
                ( my $code = $line ) =~ s/\s* [#] [^"]* \z//msx;
                if ( $code !~ /[{] \s* \z/msx ) {
                    next if $code =~ /[}] ; \s* \z/msx;
                    print qq[$where: catch block does not end with "};"\n];
                    $failed = 1;
                    next;
                }

                my $closing = closing_line( \@lines, $index );
                if ( !defined $closing ) {
                    print qq[$where: catch block has no closing brace\n];
                    $failed = 1;
                    next;
                }
                if ( $lines[$closing] !~ /\A [ ]* [}] ; \s* (?: [#] .* )? \z/msx ) {
                    print $file . q{:} . ( $closing + 1 )
                      . qq[: catch block does not end with "};"\n];
                    $failed = 1;
                }
            }
        }
        exit $failed;
    ' >&2; then
        echo "architecture-check: a try/catch does not end with \"};\", or a file could not be read" >&2
        status=1
    fi
}

# ADR 0117 and ADR 0118, applied across lib/ by the subtraction sweep: code
# catches with native try/catch, asks GPForum::X::Conflict which constraint
# collided, takes a handle from Infrastructure::Storage, and declares what a
# class cannot work without. These rules keep the idioms that were replaced
# from coming back, in code. POD, heredocs and whole-line comments are not
# read; a comment after code is, which can refuse a line but never hide one:
#
#   eval         an `eval {` block                  use try/catch
#   eval_error   $EVAL_ERROR or $@                  use the catch variable
#   index_error  index($error, ...), with or        ask X::Conflict->on
#                without the parentheses
#   schema_dbh   a private _schema_dbh              Infrastructure::Storage
#   undeclared   `has NAME => undef;` (or a list    GPForum::Base requires,
#                of names) without a
#                `# optional` comment               or say why it is optional
#   recovery     a catch variable handed to         UniqueConflict->attempt
#                conflict recovery                  (see the check above)
#
# The allowlist holds only files the sweep was not allowed to edit, each with
# its reason. An entry that no longer fires fails the check, so the list can
# only shrink.
#
# - lib/GPForum/ViewModel/Forum/Page.pm: frontend code, which the owner
#   edits and the sweep may not touch. Its engagement lookup still
#   catches with eval and $EVAL_ERROR; it is converted with the owner's next
#   change there.
RETIRED_IDIOM_ALLOWLIST='lib/GPForum/ViewModel/Forum/Page.pm:eval lib/GPForum/ViewModel/Forum/Page.pm:eval_error'

check_retired_idioms() {
    # One perl reads every file, so an allowlist entry is judged against all
    # of lib/, never against one batch of it.
    if ! ALLOWLIST="$RETIRED_IDIOM_ALLOWLIST" perl -MFile::Find -e "$CODE_LINES_PERL"'
        my %allowed = map { $_ => 0 } split q{ }, $ENV{ALLOWLIST};
        my @files;
        find( { no_chdir => 1, wanted => sub { push @files, $_ if /[.]pm\z/msx } }, q{lib} )
          if -d q{lib};
        my %rules = (
            eval        => qr/(?<![\w\$]) eval \s* [{]/msx,
            eval_error  => qr/\$EVAL_ERROR \b | \$@/msx,
            index_error => qr/(?<![\w\$]) index \s* (?: [(] \s* )? "? \$ \w* err/imsx,
            schema_dbh  => qr/\b _schema_dbh \b/msx,
        );
        my $recovery = qr/(?: UniqueConflict->is_conflict(?:_on)? | X::Conflict->from_error | _after_(?:conflict|unique) ) \s* [(]/msx;
        my @found;
        for my $file ( sort @files ) {
            my @lines = code_lines($file);
            my @hits;
            for my $index ( 0 .. $#lines ) {
                my $line = $lines[$index];
                next if $line =~ /\A \s* (?: [#] | \z )/msx;
                for my $rule ( sort keys %rules ) {
                    push @hits, [ $rule, $index ] if $line =~ $rules{$rule};
                }
                # The declaration, read over two lines only when perltidy
                # wrapped it: a "# optional" on the next declaration does
                # not cover this one.
                my $next    = $lines[ $index + 1 ] // q{};
                my $wrapped = $line =~ /\A \s* has \s+ (?: [[] [^]]* []] | \S+ ) \s* => \s* \z/msx
                  && $next =~ /\A \s* undef \s* ;/msx;
                if ( $wrapped
                    || $line =~ /\A \s* has \s+ (?: [[] [^]]* []] | \S+ ) \s* => \s* undef \s* ;/msx )
                {
                    my $declaration = $wrapped ? "$line $next" : $line;
                    push @hits, [ undeclared => $index ]
                      if $declaration !~ /[#] \s* optional/msx;
                }
                my $variable = catch_opening($line);
                if ( defined $variable && length $variable ) {
                    # The whole statement, which perltidy may wrap.
                    my $closing = closing_line( \@lines, $index ) // $#lines;
                    my $block   = join qq{\n}, @lines[ $index .. $closing ];
                    while ( $block =~ /$recovery [^;]*? \$\Q$variable\E \b/gmsx ) {
                        my $before = substr $block, 0, $-[0];
                        push @hits, [ recovery => $index + ( $before =~ tr/\n// ) ];
                    }
                }
            }
            for my $hit (@hits) {
                my ( $rule, $index ) = @{$hit};
                if ( exists $allowed{"$file:$rule"} ) {
                    $allowed{"$file:$rule"}++;
                    next;
                }
                push @found, "$file:" . ( $index + 1 ) . ": $rule: $lines[$index]";
            }
        }
        for my $entry ( sort keys %allowed ) {
            push @found, "$entry: allowlisted, but no longer found; remove it"
              if !$allowed{$entry};
        }
        print map { "$_\n" } @found;
        exit( @found ? 1 : 0 );
    ' >&2; then
        echo "architecture-check: a retired idiom is back in lib/, or a file could not be read; see the rules above check_retired_idioms" >&2
        status=1
    fi
}

# ADR 0107: a module depends only on its own layer and the layers below it,
# as GPForum::Application::LayerMap declares them. The rule and the scan live
# in t/192-layering.t, which the suite also runs; it needs the project's
# dependency tree, so it goes through script/gpforum-carton.
check_layering() {
    if ! script/gpforum-carton exec perl t/192-layering.t >/dev/null 2>&1; then
        script/gpforum-carton exec perl t/192-layering.t 2>&1 | grep -E '^# ' >&2
        echo "architecture-check: a module depends on a layer above its own" >&2
        status=1
    fi
}

check_controller_persistence() {
    for file in lib/GPForum/Controller/*.pm; do
        [ -f "$file" ] || continue
        check_controller_forbidden_persistence "$file"
    done
}

ALL_CHECKS='check_controller_persistence check_os_specific_logic
check_entrypoint_layout check_query_topology_gate check_template_business_logic
check_authority_language check_internal_dependency_cycles
check_entrypoint_references check_unique_conflict_recovery
check_subroutine_prototypes check_column_reader_empty_list
check_universal_can_override check_try_catch_closed check_retired_idioms
check_layering'

# With arguments, only the named checks run: t/341 runs each gate against a
# scratch tree that breaks it.
if [ "$#" -gt 0 ]; then
    for check in "$@"; do
        case " $(echo $ALL_CHECKS) " in
            *" $check "*) "$check" ;;
            *)
                echo "architecture-check: no check named $check" >&2
                exit 2
                ;;
        esac
    done
    exit "$status"
fi

for check in $ALL_CHECKS; do
    "$check"
done

exit "$status"