script/architecture-check
Rama main · réplica de lectura del repositorio original.
#!/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"