diff --git a/.gitattributes b/.gitattributes index e1e41a1..5bc994f 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,3 +1,4 @@ .gitignore export-ignore .gitattributes export-ignore pg-travis-test.sh export-ignore +bin/test export-ignore diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 9e0d9a2..6b9a295 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -394,6 +394,18 @@ jobs: steps: - name: Check out the repo uses: actions/checkout@v7 + - name: Test the update linter + # First, so a broken instrument reports as a broken instrument rather + # than as a clean (or noisy) SQL diff. + run: make update-lint-test + - name: Check update-script coverage + # Static check that sql/cat_tools----.sql.in + # accounts for every object the install scripts differ on. The step + # above already ran this same check on this same pair + # (bin/test/03-real-pairs.t), so this step buys attribution in the CI + # log -- a failure here names the SQL, not the linter -- rather than + # coverage the tests do not already have. + run: make update-lint - name: Lint SQL # CRITICAL: call `make lint` directly, not some other path (a script, a # different target, etc). lint.mk's vendored include is guarded on diff --git a/CLAUDE.md b/CLAUDE.md index bbe9480..9ce0c5f 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -67,6 +67,16 @@ byte-for-byte copy of `cat_tools.sql.in`, regenerated on every `make`), so unlike a real release it's ignored too rather than tracked. See `sql/.gitignore`'s comments and RELEASE.md step 4 for the full detail. +Run `make update-lint` whenever changing the extension's SQL: `bin/update_lint` +statically checks that the update script into the current version accounts +for every object added or removed since the last release — the automated +half of RELEASE.md's "Ongoing development" rule to keep +`sql/cat_tools----stable.sql.in` current. It compares object +identity, not definition, so `bin/structural_diff` remains the authority on +whether a fresh install and an updated one are actually equivalent. +`make update-lint-test` runs the linter's own test suite; both run in the CI +`lint` job. + ## CI: PostgreSQL version support See [`../ai/CLAUDE.md`](../ai/CLAUDE.md) for the general PostgreSQL-version- diff --git a/Makefile b/Makefile index 4c200bc..98d5b0b 100644 --- a/Makefile +++ b/Makefile @@ -105,3 +105,26 @@ clean_old_version: # `.vendor/linter/sql/bin/sql-lint sql/cat_tools--0.3.0.sql.in`. LINT_TARGETS = sql/cat_tools.sql.in test/ include lint.mk + +# Static check that the update script into the current version accounts for +# every object the install scripts on either side of it disagree about. Needs +# no database, so it runs in the same cheap CI job as the style linter above; +# see bin/update_lint's header for what it does and does not prove. Like +# LINT_TARGETS, its default scope excludes released pairs, whose files are +# frozen and whose findings could therefore never be fixed. +# +# CRITICAL: this must stay unwired from `lint` in both directions. `lint` only +# exists when lint.mk's vendored include fires, which is guarded on +# $(wildcard .git) -- in a released tarball there is no `lint` target at all +# and `make lint` fails loudly with "No rule to make target". Naming `lint` as +# a prerequisite here (or the reverse) would define it as a real target with no +# recipe, quietly turning that failure into a pass. +.PHONY: update-lint +update-lint: + bin/update_lint + +# Unlike update-lint, this needs a checkout: bin/test is export-ignore'd, so it +# is absent from a released tarball. +.PHONY: update-lint-test +update-lint-test: + prove bin/test/ diff --git a/bin/test/00-cli.t b/bin/test/00-cli.t new file mode 100644 index 0000000..4fd5222 --- /dev/null +++ b/bin/test/00-cli.t @@ -0,0 +1,79 @@ +#!/usr/bin/env perl +# +# Argument handling and exit codes for bin/update_lint. +# +# The exit codes carry the meaning here, so they are what is asserted; message +# wording is deliberately not, apart from the one substring a caller would grep +# for. 2 (usage) versus 0 matters most: an unreadable file that parsed as "zero +# objects" would turn a typo into a green run. + +use strict; +use warnings; +use Test::More; +use lib do { require File::Basename; File::Basename::dirname(__FILE__) }; +use TestLint; + +# -- Help and malformed invocations ------------------------------------------- + +{ + my ($rc, $out, $err) = run('--help'); + is($rc, 2, '--help exits 2'); + like($err, qr/usage:/, '--help prints usage to stderr'); + is($out, '', '--help prints nothing to stdout'); +} + +usage_exit('unknown option', '--bogus'); +usage_exit('two positionals (not three)', 'a', 'b'); +usage_exit('four positionals', 'a', 'b', 'c', 'd'); +usage_exit('--versions with one version', '--versions', '0.2.0'); +usage_exit('--versions combined with positionals', + '--versions', '0.2.0', '0.2.1', 'x', 'y', 'z'); +usage_exit('--list-objects combined with positionals', + '--list-objects', '/dev/null', 'x', 'y', 'z'); +usage_exit('--list-objects combined with --versions', + '--list-objects', '/dev/null', '--versions', '0.2.0', '0.2.1'); +usage_exit('--sql-dir with no value', '--sql-dir'); + +# -- Unreadable input is a usage error, never a silent empty parse ------------ + +usage_exit('--list-objects on a missing file', '--list-objects', '/nonexistent/nope.sql'); +usage_exit('missing OLD_INSTALL', '/nonexistent/old.sql', '/dev/null', '/dev/null'); +usage_exit('missing UPDATE_SCRIPT', '/dev/null', '/dev/null', '/nonexistent/upd.sql'); +usage_exit('--versions naming a nonexistent version', + '--versions', '0.0.0', '0.0.1', '--sql-dir', sql_dir()); + +# A directory opens and reads as the empty string, which is the same shape as +# an unreadable file: nothing parsed, everything clean. +usage_exit('a directory as UPDATE_SCRIPT', '/dev/null', '/dev/null', sql_dir()); +usage_exit('--list-objects on a directory', '--list-objects', sql_dir()); + +# -- Degenerate but legal input ---------------------------------------------- + +{ + my ($rc, $out) = run('--list-objects', '/dev/null'); + is($rc, 0, '--list-objects /dev/null exits 0'); + is($out, '', '--list-objects /dev/null prints nothing'); +} + +{ + my ($rc, $out) = run('/dev/null', '/dev/null', '/dev/null'); + is($rc, 0, 'three empty files compare clean'); + like($out, qr/^OK:/m, 'success prints an OK line'); +} + +# -- Default mode ------------------------------------------------------------ + +{ + my ($rc, $out) = run_in(repo_root()); + is($rc, 0, 'default mode is clean on the current source'); + like($out, qr/^OK:/m, 'default mode prints an OK line'); +} + +{ + # Default mode reads .control relative to the working directory, so it + # is a usage error anywhere else rather than a guess at the repo layout. + my ($rc) = run_in(sql_dir()); + is($rc, 2, 'default mode outside the extension root exits 2'); +} + +done_testing(); diff --git a/bin/test/01-extract.t b/bin/test/01-extract.t new file mode 100644 index 0000000..fcedd4c --- /dev/null +++ b/bin/test/01-extract.t @@ -0,0 +1,661 @@ +#!/usr/bin/env perl +# +# What bin/update_lint extracts from a single file, asserted independently of +# any diff. +# +# The all-forms fixture below is the load-bearing case: it pins the EXACT set, +# not a count. A count still passes when an object is recorded under the wrong +# identity, and a set additionally catches over-extraction -- phantom objects +# invented out of function bodies, comments and format() templates, which is +# the failure mode that makes a lint noisy and then ignored. + +use strict; +use warnings; +use Test::More; +use lib do { require File::Basename; File::Basename::dirname(__FILE__) }; +use TestLint; + +# -- Empty input ------------------------------------------------------------- + +is_deeply(objects('/dev/null'), [], 'an empty file yields no objects'); + +# -- The exact object set of the all-forms fixture --------------------------- + +my @expected = ( + "acl\tfunction:lt.describe/2", + "acl\tfunction:lt.internal/0", + "acl\trelation:lt.thing_v", + "acl\tschema:lt", + "acl\ttype:lt.color", + "acl\ttype:lt.pair", + "acl\ttype:lt.positive", + "attr\tlt.pair.first_name", + "attr\tlt.pair.second_name", + "attr\tlt.thing.id", + "attr\tlt.thing.shade", + "cast\tchar=>lt.color", + "comment\tfunction:lt.describe/2", + "comment\ttype:lt.color", + "constraint\tlt.thing.thing__pk", + "data\tlt.thing", + "enumval\tlt.color:blue", + "enumval\tlt.color:green", + "enumval\tlt.color:red", + "enumval\tlt.color:ultraviolet", + "function\tlt.describe/2", + "function\tlt.internal/0", + "index\tlt.thing__shade", + "relation\tlt.thing", + "relation\tlt.thing_seq", + "relation\tlt.thing_v", + "relation\tlt.thing_v2", + "role\tlt__usage", + "schema\tlt", + "type\tlt.color", + "type\tlt.pair", + "type\tlt.positive", +); +is_deeply(objects(fixture('all-forms.sql.in')), \@expected, + 'all-forms.sql.in yields exactly the hand-authored object set'); + +# The scaffolding assertion is worth calling out on its own: it is a decision +# (created and dropped in one file cancels), not an accident of the fixture. +is_deeply([ grep { /__cat_tools/ } @{ objects(fixture('all-forms.sql.in')) } ], [], + '__cat_tools scaffolding is excluded from the object set'); + +{ + my $objs = objects(fixture('all-forms.sql.in')); + is_deeply($objs, [ sort @$objs ], '--list-objects output is sorted'); +} + +# -- Dollar quoting ---------------------------------------------------------- + +{ + # Verbatim shape of __cat_tools.create_function in sql/cat_tools.sql.in: a + # function body holding format() templates. A scanner that recurses into + # dollar quotes unconditionally invents four objects here. + my $f = write_tmp(<<'SQL'); +CREATE FUNCTION s.outer_fn( + a text + , b text +) RETURNS void LANGUAGE plpgsql AS $body$ +DECLARE + create_template CONSTANT text := $template$ +CREATE OR REPLACE FUNCTION %s( +%s +) RETURNS %s AS +%L +$template$ + ; + revoke_template CONSTANT text := $template$ +REVOKE ALL ON FUNCTION %s( +%s +) FROM public; +$template$ + ; + comment_template CONSTANT text := $template$ +COMMENT ON FUNCTION %s( +%s +) IS %L; +$template$ + ; +BEGIN + PERFORM 1; +END +$body$; +SQL + is_deeply(objects($f), ["function\ts.outer_fn/2"], + 'a nested dollar quote inside a function body yields only the outer function'); +} + +# -- create_function() gateway ---------------------------------------------- + +{ + my $f = write_tmp(<<'SQL'); +SELECT __cat_tools.create_function( + 'cat_tools.foo' + , 'a int + , b text + , c boolean' + , 'int LANGUAGE sql' + , $body$ +SELECT 1 +$body$ + , 'cat_tools__usage' + , 'Does a thing' +); +SQL + is_deeply( + objects($f), + [ "acl\tfunction:cat_tools.foo/3", + "comment\tfunction:cat_tools.foo/3", + "function\tcat_tools.foo/3" ], + 'a multi-line create_function() call yields the function, its ACL and its comment' + ); +} + +for my $n (3, 7) { + # Everything create_function() reads is positional, so a wrong argument + # count silently reads the wrong argument as the name or the signature. + my $args = join "\n , ", map { "'a$_'" } 1 .. $n; + my ($rc) = run('--list-objects', + write_tmp("SELECT __cat_tools.create_function(\n $args\n);\n")); + is($rc, 3, "create_function() with $n arguments exits 3"); +} + +{ + # OUT parameters do not count toward the signature, and neither do DEFAULT + # clauses -- a later DROP writes neither, and both keys must still match. + my $f = write_tmp(<<'SQL'); +CREATE FUNCTION s.f( + a int + , OUT b text + , c name[] DEFAULT array['x'] +) RETURNS void LANGUAGE sql AS $$SELECT$$; +DROP FUNCTION s.f( + a int + , OUT b text + , c name[] +); +SQL + is_deeply(objects($f), [], + 'a DROP derives the same key as its CREATE despite OUT and DEFAULT'); +} + +{ + my $f = write_tmp("SELECT 1;\n"); + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'a top-level SELECT that is not a known gateway is unanalyzable'); + like($err, qr/SELECT/, 'the error names the offending statement'); +} + +# -- exec() gateway ---------------------------------------------------------- + +{ + my $f = write_tmp(<<'SQL'); +SELECT __cat_tools.exec(format($fmt$ +CREATE OR REPLACE VIEW s.v AS + SELECT %s FROM s.t +; +$fmt$ + , 'a, b' +)); +SQL + is_deeply(objects($f), ["relation\ts.v"], + 'DDL inside exec() is extracted, and the format() placeholder is not'); +} + +# -- Enum labels ------------------------------------------------------------- + +{ + my $f = write_tmp(<<'SQL'); +CREATE TYPE s.e AS ENUM( + 'one', 'two' -- two on one line + /* interleaved + block comment */ + , 'three' + , 'four' -- SED: REQUIRES 9.5! + , 'five' -- SED: PRIOR TO 12! +); +SQL + is_deeply( + objects($f), + [ "enumval\ts.e:four", "enumval\ts.e:one", + "enumval\ts.e:three", "enumval\ts.e:two", "type\ts.e" ], + 'enum labels survive leading commas and both comment styles; the PRIOR TO branch is dropped' + ); +} + +# -- Preprocessing ----------------------------------------------------------- + +{ + # sql.mk turns the bare @generated@ marker into a comment; so does the + # scanner, including one buried in a function body. + my $f = write_tmp(<<'SQL'); +@generated@ VERSIONED FILE! + +CREATE SCHEMA s; + +CREATE FUNCTION s.f() RETURNS void LANGUAGE plpgsql AS $body$ +DECLARE + x int; +@generated@ +BEGIN + x := 1; +END +$body$; + +@generated@ +SQL + is_deeply(objects($f), [ "function\ts.f/0", "schema\ts" ], + '@generated@ markers are inert wherever they appear'); +} + +# -- Identity edge cases ----------------------------------------------------- + +{ + my $a = write_tmp("CREATE OR REPLACE VIEW s.v AS SELECT 1;\n"); + my $b = write_tmp("CREATE VIEW s.v AS SELECT 1;\n"); + is_deeply(objects($a), objects($b), + 'CREATE VIEW and CREATE OR REPLACE VIEW are the same identity'); +} + +{ + my $f = write_tmp(qq{CREATE CAST ("char" AS s.k) WITH INOUT AS IMPLICIT;\n}); + is_deeply(objects($f), ["cast\tchar=>s.k"], + 'a quoted source type in CREATE CAST is unquoted in the key'); +} + +# -- Unknown statement forms are a hard error -------------------------------- + +{ + # Deliberately a form that can never become real SQL, so this test cannot + # collide with a statement type added to the script later. The known list + # is not restated here -- keeping it in one place is the point. + my $f = write_tmp("CREATE SCHEMA s;\n\nCREATE FOO BAR baz;\n"); + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'an unrecognized CREATE exits 3'); + like($err, qr/:3:/, 'the error names the line number'); + like($err, qr/CREATE FOO BAR baz/, 'the error quotes the offending text'); +} + +# -- Unterminated constructs ------------------------------------------------- +# +# The worst failure this script can have: with no closing delimiter the rest of +# the file holds no statement boundary, fuses onto the statement in progress, +# and every object in it disappears -- reported as a clean "0 added, 0 +# removed". Each construct is followed here by objects that must not be lost +# silently, so a regression shows up as exit 0 rather than as a wrong count. + +my $swallowed = <<'SQL'; +CREATE TABLE s.t(i int); +CREATE VIEW s.v AS SELECT 1; +CREATE FUNCTION s.g() RETURNS void LANGUAGE sql AS $$SELECT$$; +GRANT SELECT ON s.v TO r; +SQL + +{ + my $f = write_tmp(<<"SQL"); +CREATE FUNCTION s.f() RETURNS void LANGUAGE plpgsql AS \$body\$ +BEGIN + PERFORM 1; +END +\$bodyX\$; +$swallowed +SQL + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'a dollar quote with no closing tag exits 3'); + like($err, qr/:1:/, 'the error names the line the dollar quote opened on'); +} + +{ + my $f = write_tmp("COMMENT ON SCHEMA s IS 'oops;\n$swallowed"); + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'a string literal with no closing quote exits 3'); + like($err, qr/:1:/, 'the error names the line the literal opened on'); +} + +{ + my $f = write_tmp("CREATE SCHEMA s;\n/* oops\n$swallowed"); + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'a block comment with no closing delimiter exits 3'); + like($err, qr/:2:/, 'the error names the line the comment opened on'); +} + +{ + my $f = write_tmp(qq{CREATE TABLE s."oops(i int);\n$swallowed}); + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'a quoted identifier with no closing quote exits 3'); + like($err, qr/:1:/, 'the error names the line the identifier opened on'); +} + +{ + # The outer scan steps over a gateway payload as one literal, so the + # payload needs a check of its own. + my $f = write_tmp("SELECT __cat_tools.exec(\$f\$CREATE VIEW s.v AS SELECT 1; /* oops \$f\$);\n"); + my ($rc) = run('--list-objects', $f); + is($rc, 3, 'an unterminated construct inside an exec() payload exits 3'); +} + +# -- DO blocks --------------------------------------------------------------- + +{ + # All on one line, so nothing is found by looking at line starts. + my $f = write_tmp("DO \$\$BEGIN CREATE ROLE r1 NOLOGIN; CREATE ROLE r2 NOLOGIN; END\$\$;\n"); + is_deeply(objects($f), [ "role\tr1", "role\tr2" ], + 'DDL sharing a line with a plpgsql keyword is still found'); +} + +{ + my $f = write_tmp(<<'SQL'); +DO $do$ +DECLARE + n int; + m text := 'x'; +BEGIN + IF NOT EXISTS (SELECT 1) THEN + RETURN; + END IF; + EXECUTE 'CREATE VIEW s.v AS SELECT 1'; +END +$do$; +SQL + is_deeply(objects($f), ["relation\ts.v"], + 'a DECLARE section, an IF and an EXECUTE yield only the executed DDL'); +} + +{ + my $f = write_tmp("DO \$\$BEGIN x := 1; END\$\$;\n"); + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'a statement form unknown inside a DO block exits 3'); + like($err, qr/x := 1/, 'the error quotes the offending statement'); +} + +{ + # PERFORM gets the SELECT rules: a call that is not a known gateway could + # be creating anything. + my $f = write_tmp("DO \$\$BEGIN PERFORM frobnicate(); END\$\$;\n"); + my ($rc) = run('--list-objects', $f); + is($rc, 3, 'PERFORM of an unknown function inside a DO block exits 3'); +} + +{ + my $f = write_tmp("DO \$\$DECLARE t text; BEGIN EXECUTE t; END\$\$;\n"); + my ($rc) = run('--list-objects', $f); + is($rc, 3, 'EXECUTE of a payload that is not resolvable DDL exits 3'); +} + +# A control header is peeled off the statement it guards, so anything hidden +# inside one would never be looked at. + +{ + my $f = write_tmp( + "DO \$\$BEGIN FOR r IN EXECUTE 'CREATE VIEW s.hidden AS SELECT 1' LOOP NULL; END LOOP; END\$\$;\n"); + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'a gateway inside a FOR ... LOOP header exits 3'); + like($err, qr/header/, 'the error says where it was'); +} + +{ + my $f = write_tmp( + "DO \$\$BEGIN IF __cat_tools.exec('CREATE VIEW s.hidden AS SELECT 1') THEN NULL; END IF; END\$\$;\n"); + my ($rc) = run('--list-objects', $f); + is($rc, 3, 'a gateway inside an IF ... THEN header exits 3'); +} + +# -- exec() payloads --------------------------------------------------------- + +{ + # Every real call site keeps its explanatory comment just outside the + # SELECT, so a comment moved one line inward must not lose the statement. + my $f = write_tmp(<<'SQL'); +SELECT __cat_tools.exec($fmt$ +-- rebuild the view +CREATE OR REPLACE VIEW s.v AS SELECT 1; +$fmt$); +SQL + is_deeply(objects($f), ["relation\ts.v"], + 'a comment ahead of the DDL in an exec() template does not hide it'); +} + +{ + my $f = write_tmp("SELECT __cat_tools.exec(format('%s', 'x'));\n"); + my ($rc) = run('--list-objects', $f); + is($rc, 3, 'an exec() whose payload resolves to no DDL exits 3'); +} + +{ + # Only format()'s FIRST argument is the template. A value that opens with a + # DDL keyword is data; parsing it would cancel the table it names. + my $f = write_tmp(<<'SQL'); +CREATE TABLE s.t(i int); +SELECT __cat_tools.exec(format($fmt$ +CREATE OR REPLACE VIEW s.w AS SELECT %s FROM s.t +$fmt$ + , 'DROP TABLE s.t' +)); +SQL + is_deeply(objects($f), + [ "attr\ts.t.i", "relation\ts.t", "relation\ts.w" ], + 'a format() value that reads as DDL does not cancel a real object'); +} + +# -- A gateway whose object list resolves at run time ------------------------ +# +# The fail-open shape: the fragment is DDL, so the zero-DDL guard is satisfied, +# but every object it names was concatenated in at run time. A handler that +# only loops over the pieces records no key and returns clean. + +{ + my $f = write_tmp( + "CREATE SCHEMA s;\n" + . "SELECT __cat_tools.exec('GRANT USAGE ON SCHEMA ' || quote_ident('s') || ' TO r');\n"); + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'an exec() GRANT with no object left in it exits 3'); + like($err, qr/GRANT/, 'the error names the statement'); +} + +{ + my $f = write_tmp( + "DO \$\$BEGIN EXECUTE 'GRANT USAGE ON SCHEMA ' || quote_ident(s) || ' TO r'; END\$\$;\n"); + my ($rc) = run('--list-objects', $f); + is($rc, 3, 'a DO-block EXECUTE GRANT with no object left in it exits 3'); +} + +{ + my $f = write_tmp("DO \$\$BEGIN EXECUTE 'DROP FUNCTION ' || f; END\$\$;\n"); + my ($rc, undef, $err) = run('--list-objects', $f); + is($rc, 3, 'a DROP with no object left in it exits 3'); + like($err, qr/DROP/, 'the error names the statement'); +} + +# -- ALTER DEFAULT PRIVILEGES ------------------------------------------------ + +{ + # TABLES and SEQUENCES are separate default-privilege categories that + # share the `relation` key kind, so the sequence must come out ungranted. + my $f = write_tmp(<<'SQL'); +CREATE SCHEMA s; +ALTER DEFAULT PRIVILEGES IN SCHEMA s GRANT SELECT ON TABLES TO r; +CREATE TABLE s.t(i int); +CREATE SEQUENCE s.q; +SQL + is_deeply(objects($f), + [ "acl\trelation:s.t", "attr\ts.t.i", + "relation\ts.q", "relation\ts.t", "schema\ts" ], + 'a default privilege on TABLES reaches the table and not the sequence'); +} + +{ + my $f = write_tmp(<<'SQL'); +CREATE SCHEMA s; +ALTER DEFAULT PRIVILEGES IN SCHEMA s GRANT EXECUTE ON FUNCTIONS TO r; +CREATE FUNCTION s.f(a int) RETURNS void LANGUAGE sql AS $$SELECT$$; +SQL + is_deeply(objects($f), + [ "acl\tfunction:s.f/1", "function\ts.f/1", "schema\ts" ], + 'a default privilege on FUNCTIONS reaches a later function'); +} + +{ + my $f = write_tmp(<<'SQL'); +CREATE SCHEMA s; +ALTER DEFAULT PRIVILEGES IN SCHEMA s GRANT USAGE ON TYPES TO r; +ALTER DEFAULT PRIVILEGES IN SCHEMA s REVOKE USAGE ON TYPES FROM r; +CREATE TYPE s.e AS ENUM( 'a' ); +SQL + is_deeply(objects($f), [ "enumval\ts.e:a", "schema\ts", "type\ts.e" ], + 'a REVOKE clears the flag, so a later type gets no synthesized grant'); +} + +{ + my $f = write_tmp("ALTER DEFAULT PRIVILEGES IN SCHEMA s GRANT USAGE ON SCHEMAS TO r;\n"); + my ($rc) = run('--list-objects', $f); + is($rc, 3, 'a default-privilege category with no model here exits 3'); +} + +# -- Keys that name more than a bare identifier ------------------------------ + +{ + my $f = write_tmp("CREATE SCHEMA AUTHORIZATION bob;\n"); + is_deeply(objects($f), ["schema\tbob"], + 'CREATE SCHEMA AUTHORIZATION names the schema after the role'); +} + +{ + # An index lives in its table's schema, and only a schema-qualified key can + # meet the qualified name a DROP INDEX writes. + my $f = write_tmp("CREATE INDEX ix ON s.t(a);\nDROP INDEX s.ix;\n"); + is_deeply(objects($f), [], + 'an index key carries the schema its table is in'); +} + +{ + my $f = write_tmp("CREATE INDEX ON s.t(a);\n"); + my ($rc) = run('--list-objects', $f); + is($rc, 3, 'an index with no name exits 3, its generated name being unknown'); +} + +for my $stmt ('CREATE TRIGGER trg AFTER INSERT ON s.t EXECUTE FUNCTION s.f()', + 'CREATE POLICY p ON s.t USING (true)', + 'CREATE RULE rr AS ON INSERT TO s.t DO NOTHING', + 'CREATE OPERATOR s.+ (LEFTARG = int, RIGHTARG = int, FUNCTION = s.f)') +{ + my ($rc) = run('--list-objects', write_tmp("$stmt;\n")); + my ($what) = $stmt =~ /\ACREATE (\w+)/; + is($rc, 3, "$what is refused rather than keyed by its name alone"); +} + +{ + my $f = write_tmp("CREATE FUNCTION s.f(a int) RETURNS void LANGUAGE sql AS \$\$SELECT\$\$;\nCOMMENT ON FUNCTION s.f IS 'x';\n"); + my ($rc) = run('--list-objects', $f); + is($rc, 3, 'COMMENT ON FUNCTION with no argument list exits 3'); +} + +# -- Cancellation reaches an object's dependents ------------------------------ + +{ + my $f = write_tmp(<<'SQL'); +CREATE SCHEMA scaf; +CREATE TYPE scaf.e AS ENUM( 'a', 'b' ); +COMMENT ON TYPE scaf.e IS 'scratch'; +GRANT USAGE ON TYPE scaf.e TO r; +CREATE TABLE scaf.t(id int CONSTRAINT t__pk PRIMARY KEY); +INSERT INTO scaf.t VALUES(1); +DROP TYPE scaf.e; +DROP TABLE scaf.t; +DROP SCHEMA scaf; +SQL + is_deeply(objects($f), [], + 'dropping an object cancels its labels, ACL, comment and constraints too'); +} + +{ + my $f = write_tmp(<<'SQL'); +CREATE SCHEMA scaf; +CREATE TYPE scaf.e AS ENUM( 'a' ); +CREATE FUNCTION scaf.f(a int) RETURNS void LANGUAGE sql AS $$SELECT$$; +DROP SCHEMA scaf CASCADE; +SQL + is_deeply(objects($f), [], + 'DROP SCHEMA ... CASCADE cancels the schema contents'); +} + +{ + my $f = write_tmp(<<'SQL'); +CREATE FUNCTION s.f(a int, b int) RETURNS void LANGUAGE sql AS $$SELECT$$; +DROP FUNCTION s.f; +SQL + is_deeply(objects($f), [], + 'a DROP FUNCTION with no argument list cancels whatever arity exists'); +} + +{ + # Cancellation is ORDER-sensitive: the same two statements the other way + # round are the idempotent rebuild an update script really writes, and + # cancelling that would lose the view and its ACL from the diff entirely. + my $f = write_tmp(<<'SQL'); +CREATE SCHEMA s; +DROP VIEW IF EXISTS s.v; +CREATE VIEW s.v AS SELECT 1; +GRANT SELECT ON s.v TO r; +SQL + is_deeply(objects($f), + [ "acl\trelation:s.v", "relation\ts.v", "schema\ts" ], + 'a DROP before the CREATE it precedes cancels nothing'); + + my $g = write_tmp(<<'SQL'); +CREATE SCHEMA s; +CREATE VIEW s.v AS SELECT 1; +GRANT SELECT ON s.v TO r; +DROP VIEW s.v; +SQL + is_deeply(objects($g), ["schema\ts"], + 'the same statements as scaffolding still cancel'); +} + +# -- Columns and composite-type attributes ----------------------------------- +# +# Both sides of every diff are fresh install scripts, which state a relation's +# final column list in the CREATE and never with an ALTER. Without keys from +# the CREATE, a column added by editing one is not an object at all and its +# missing ALTER TABLE ADD COLUMN could not be reported. + +{ + my $f = write_tmp(<<'SQL'); +CREATE TABLE s.t( + id int + CONSTRAINT t__pk PRIMARY KEY + , amount numeric(10,2) NOT NULL DEFAULT 0 + , tags text[] DEFAULT array['a', 'b'] + , CONSTRAINT t__positive CHECK( amount > 0 ) + , UNIQUE (id, amount) +); +SQL + is_deeply(objects($f), + [ "attr\ts.t.amount", "attr\ts.t.id", "attr\ts.t.tags", + "constraint\ts.t.t__pk", "constraint\ts.t.t__positive", + "relation\ts.t" ], + 'CREATE TABLE yields a key per column, and none for its constraint clauses'); +} + +{ + my $f = write_tmp("CREATE TYPE s.c AS (a int, b numeric(10,2), c text[]);\n"); + is_deeply(objects($f), + [ "attr\ts.c.a", "attr\ts.c.b", "attr\ts.c.c", "type\ts.c" ], + 'a composite CREATE TYPE yields a key per attribute'); +} + +{ + # RANGE and the plain domain form both keep a keyword between AS and the + # parenthesis, so neither reads as a composite. + my $f = write_tmp( + "CREATE TYPE s.r AS RANGE (SUBTYPE = int);\n" + . "CREATE DOMAIN s.d AS numeric(10,2) CHECK( VALUE > 0 );\n"); + is_deeply(objects($f), [ "type\ts.d", "type\ts.r" ], + 'a range type and a domain contribute no attributes'); +} + +{ + # ADD COLUMN takes IF NOT EXISTS, which is not the column's name. + my $f = write_tmp(<<'SQL'); +CREATE TABLE s.t(i int); +ALTER TABLE s.t ADD COLUMN IF NOT EXISTS j int; +ALTER TABLE s.t DROP COLUMN IF EXISTS i; +SQL + is_deeply(objects($f), [ "attr\ts.t.j", "relation\ts.t" ], + 'IF NOT EXISTS is not mistaken for the column being added'); +} + +# -- Quoted identifiers ------------------------------------------------------ + +{ + # A `;` inside a name is not a statement boundary, so the splitter must not + # cut the name in half. + my $f = write_tmp(qq{CREATE TABLE s."odd;name"(i int);\nCREATE VIEW s.v AS SELECT 1;\n}); + is_deeply(objects($f), + [ "attr\ts.odd;name.i", "relation\ts.odd;name", "relation\ts.v" ], + 'a semicolon inside a quoted identifier does not split the statement'); +} + +done_testing(); diff --git a/bin/test/02-diff.t b/bin/test/02-diff.t new file mode 100644 index 0000000..b54a480 --- /dev/null +++ b/bin/test/02-diff.t @@ -0,0 +1,251 @@ +#!/usr/bin/env perl +# +# The diff and coverage half of bin/update_lint: given two install scripts and +# an update script, which objects are reported as unhandled. +# +# Findings are matched by identifier only, never by message wording, so that +# rephrasing the report does not turn into a test edit. + +use strict; +use warnings; +use Test::More; +use lib do { require File::Basename; File::Basename::dirname(__FILE__) }; +use TestLint; + +# Objects the extra fixture adds on top of all-forms, hand-listed so the +# expectation does not come from the tool being tested. +my @delta = ( + 'acl:function:lt.measure/1', + 'acl:relation:lt.thing_v3', + 'acl:type:lt.size', + 'comment:type:lt.size', + 'enumval:lt.size:large', + 'enumval:lt.size:small', + 'function:lt.measure/1', + 'relation:lt.thing_v3', + 'type:lt.size', +); + +my $base = fixture('all-forms.sql.in'); +my $extended = concat_tmp($base, fixture('all-forms-extra.sql.in')); + +# -- A file against itself --------------------------------------------------- + +{ + my ($rc, $out) = run($base, $base, '/dev/null'); + is($rc, 0, 'a file against itself with no update script is clean'); + like($out, qr/0 object\(s\) added, 0 removed/, 'no objects added or removed'); +} + +# -- The delta, uncovered ---------------------------------------------------- + +{ + my ($rc, $out, $err) = run($base, $extended, '/dev/null'); + is($rc, 1, 'an empty update script leaves the whole delta unhandled'); + is_deeply(findings($out, 'added'), [@delta], 'every added object is reported'); + is_deeply(findings($out, 'removed'), [], 'nothing is reported as removed'); + like($err, qr/^FAIL:/m, 'the summary goes to stderr'); +} + +# -- The delta, reversed ----------------------------------------------------- + +{ + my ($rc, $out) = run($extended, $base, '/dev/null'); + is($rc, 1, 'the reversed pair is equally unhandled'); + is_deeply(findings($out, 'removed'), [@delta], 'the same delta appears on the removal side'); + is_deeply(findings($out, 'added'), [], 'nothing is reported as added'); +} + +# -- The delta, covered ------------------------------------------------------ + +{ + my ($rc, $out) = run($base, $extended, fixture('update-covers-all.sql.in')); + is($rc, 0, 'an update script covering the delta is clean'); + like($out, qr/9 object\(s\) added, 0 removed/, 'all nine added objects are seen'); +} + +# -- Coverage is set membership, not substring search ------------------------ + +{ + # cat_tools.column is a substring of _cat_tools.column, so a substring + # search would call the second one covered by the first. + my $old = write_tmp("CREATE SCHEMA s;\n"); + my $new = write_tmp("CREATE SCHEMA s;\nCREATE VIEW _s.thing AS SELECT 1;\nCREATE VIEW s.thing AS SELECT 1;\n"); + my $upd = write_tmp("CREATE VIEW s.thing AS SELECT 1;\n"); + my ($rc, $out) = run($old, $new, $upd); + is($rc, 1, 'a similarly-named object does not stand in for the real one'); + is_deeply(findings($out, 'added'), ['relation:_s.thing'], + 'only the genuinely uncovered object is reported'); +} + +{ + # A name that appears only in a comment is not coverage. This is the + # silent-false-negative direction: the lint says handled, nothing was done. + my $old = write_tmp("CREATE SCHEMA s;\n"); + my $new = write_tmp("CREATE SCHEMA s;\nCREATE VIEW s.v AS SELECT 1;\n"); + my $upd = write_tmp("-- TODO: create s.v here\n/* s.v */\n"); + my ($rc, $out) = run($old, $new, $upd); + is($rc, 1, 'a mention inside a comment is not coverage'); + is_deeply(findings($out, 'added'), ['relation:s.v'], 's.v is still reported'); +} + +{ + # ... while a name inside a string literal IS coverage, because that is + # where create_function() keeps the objects it builds. + my $old = write_tmp("CREATE SCHEMA s;\n"); + my $new = write_tmp("CREATE SCHEMA s;\nCREATE FUNCTION s.f(a int) RETURNS void LANGUAGE sql AS \$\$SELECT\$\$;\n"); + my $upd = write_tmp(<<'SQL'); +SELECT __cat_tools.create_function( + 's.f' + , 'a int' + , 'void LANGUAGE sql' + , $body$SELECT$body$ +); +SQL + my ($rc) = run($old, $new, $upd); + is($rc, 0, 'an object built through create_function() counts as coverage'); +} + +# -- Coverage has a direction ------------------------------------------------- +# +# The two halves below are the same object and the same update script, run the +# two ways round: a DROP is not coverage for an addition, nor a CREATE for a +# removal. Getting this wrong is silent -- the report says the update script +# handled the object, when what it did was the opposite. + +{ + my $old = write_tmp("CREATE SCHEMA s;\n"); + my $new = write_tmp("CREATE SCHEMA s;\nCREATE VIEW s.v AS SELECT 1;\n"); + my $create = "CREATE VIEW s.v AS SELECT 1;\n"; + my $drop = "DROP VIEW IF EXISTS s.v;\n"; + + my ($rc, $out) = run($old, $new, write_tmp($drop)); + is($rc, 1, 'a DROP is not coverage for an added object'); + is_deeply(findings($out, 'added'), ['relation:s.v'], 'the addition is still reported'); + + my ($rrc, $rout) = run($new, $old, write_tmp($create)); + is($rrc, 1, 'a CREATE is not coverage for a removed object'); + is_deeply(findings($rout, 'removed'), ['relation:s.v'], 'the removal is still reported'); + + # The rebuild pattern an update script really uses must stay covered. + my ($brc) = run($old, $new, write_tmp($drop . $create)); + is($brc, 0, 'a DROP followed by a CREATE covers the addition'); +} + +{ + # An added enum label is created by ALTER TYPE, never by a CREATE, so the + # rule cannot be "the update script must contain a CREATE". + my $old = write_tmp("CREATE TYPE s.e AS ENUM( 'a' );\n"); + my $new = write_tmp("CREATE TYPE s.e AS ENUM( 'a', 'b' );\n"); + my ($rc) = run($old, $new, write_tmp("ALTER TYPE s.e ADD VALUE 'b';\n")); + is($rc, 0, 'ALTER TYPE ... ADD VALUE covers an added label'); +} + +{ + # ACLs and comments are presence keys: a REVOKE is how you remove a grant, + # so both directions count as having been dealt with. + my $old = write_tmp("CREATE VIEW s.v AS SELECT 1;\nGRANT SELECT ON s.v TO r;\n"); + my $new = write_tmp("CREATE VIEW s.v AS SELECT 1;\n"); + my ($rc, $out) = run($old, $new, write_tmp("REVOKE SELECT ON s.v FROM r;\n")); + is($rc, 0, 'a REVOKE covers a removed ACL') or diag($out); +} + +# -- A function grant with no argument list ---------------------------------- + +{ + # PostgreSQL accepts the bare name where it is unambiguous, so the grant it + # writes has to be matched against whatever arity the function has. + my $old = write_tmp("CREATE SCHEMA s;\n"); + my $new = write_tmp(<<'SQL'); +CREATE SCHEMA s; +CREATE FUNCTION s.f(a int) RETURNS void LANGUAGE sql AS $$SELECT$$; +GRANT EXECUTE ON FUNCTION s.f(a int) TO r; +SQL + my $upd = write_tmp(<<'SQL'); +CREATE FUNCTION s.f(a int) RETURNS void LANGUAGE sql AS $$SELECT$$; +GRANT EXECUTE ON FUNCTION s.f TO r; +SQL + my ($rc, $out) = run($old, $new, $upd); + is($rc, 0, 'a grant with no argument list covers the arity that exists') + or diag($out); +} + +# -- Enum values ------------------------------------------------------------- + +{ + my $old = write_tmp("CREATE TYPE s.e AS ENUM( 'a', 'b' );\n"); + my $new = write_tmp("CREATE TYPE s.e AS ENUM( 'a', 'b', 'c' );\n"); + + my ($rc, $out) = run($old, $new, '/dev/null'); + is($rc, 1, 'a new enum label with no update script is a finding'); + is_deeply(findings($out, 'added'), ['enumval:s.e:c'], 'the new label is named'); + + for my $upd ("ALTER TYPE s.e ADD VALUE 'c';\n", + "ALTER TYPE s.e ADD VALUE 'c' AFTER 'b';\n", + "ALTER TYPE s.e ADD VALUE IF NOT EXISTS 'c' BEFORE 'a';\n") + { + my ($crc) = run($old, $new, write_tmp($upd)); + my $label = $upd; + $label =~ s/\s+/ /g; + is($crc, 0, "coverage via: $label"); + } +} + +# -- ALTER DEFAULT PRIVILEGES ------------------------------------------------ + +{ + my $adp = "ALTER DEFAULT PRIVILEGES IN SCHEMA s GRANT USAGE ON TYPES TO r;\n"; + my $old = write_tmp("CREATE SCHEMA s;\n$adp"); + my $new = write_tmp("CREATE SCHEMA s;\n$adp" . "CREATE TYPE s.t AS ENUM( 'a' );\n"); + + my ($rc) = run($old, $new, write_tmp("CREATE TYPE s.t AS ENUM( 'a' );\n")); + is($rc, 0, 'default privileges already in force in the old install carry into the update'); + + # Without that statement anywhere, the type's ACL is genuinely missing. + my $old2 = write_tmp("CREATE SCHEMA s;\n"); + my $new2 = write_tmp("CREATE SCHEMA s;\n$adp" . "CREATE TYPE s.t AS ENUM( 'a' );\n"); + my ($rc2, $out2) = run($old2, $new2, write_tmp("CREATE TYPE s.t AS ENUM( 'a' );\n")); + is($rc2, 1, 'a type created before its schema gains default privileges is uncovered'); + is_deeply(findings($out2, 'added'), ['acl:type:s.t'], + 'the missing grant is what gets reported'); +} + +# -- Seeded table contents are advisory -------------------------------------- + +{ + my $old = write_tmp("CREATE TABLE s.t(a int);\n"); + my $new = write_tmp("CREATE TABLE s.t(a int);\nINSERT INTO s.t VALUES(1);\n"); + my ($rc, $out) = run($old, $new, write_tmp("-- nothing\n")); + is($rc, 0, 'a table populated only by the new install does not fail the check'); + like($out, qr/^WARNING: data:s\.t\b/m, '... but it is reported'); +} + +# -- Removals ---------------------------------------------------------------- + +{ + my $old = write_tmp(<<'SQL'); +CREATE FUNCTION s.gone( + rel text + , omit name[] DEFAULT array['oid'] +) RETURNS text LANGUAGE sql AS $$SELECT ''$$; +SQL + my $new = write_tmp("CREATE SCHEMA s;\n"); + my ($rc, $out) = run($old, $new, '/dev/null'); + is($rc, 1, 'a removed function with no update script is a finding'); + is_deeply(findings($out, 'removed'), ['function:s.gone/2'], 'the removed function is named'); + + # The multi-line DROP form this repo actually uses, with the DEFAULT clause + # absent -- a line-oriented match would not find it. + my $upd = write_tmp(<<'SQL'); +DROP FUNCTION s.gone( + rel text + , omit name[] +); +SQL + my ($rc2) = run($old, $new, $upd); + is($rc2, 1, 'the removal is covered but the new schema is not'); + my (undef, $out2) = run($old, $new, $upd); + is_deeply(findings($out2, 'removed'), [], 'a multi-line DROP counts as coverage'); +} + +done_testing(); diff --git a/bin/test/03-real-pairs.t b/bin/test/03-real-pairs.t new file mode 100644 index 0000000..1be5d72 --- /dev/null +++ b/bin/test/03-real-pairs.t @@ -0,0 +1,70 @@ +#!/usr/bin/env perl +# +# bin/update_lint against this repo's own released version pairs. +# +# Those files are frozen (SQL file conventions in CLAUDE.md), which makes them a +# stable adversarial oracle no fixture can match: real scripts, real dynamic +# SQL, and one real historical gap. The 0.2.0 and 0.2.1 update paths to 0.2.2 +# never granted USAGE on the five enum types that predate 0.2.2, and pinning +# exactly those five here is what proves the check would have caught it. +# +# The current pair is also linted, so a source change that forgets to extend +# the update script fails here as well as in `make update-lint`. + +use strict; +use warnings; +use Test::More; +use lib do { require File::Basename; File::Basename::dirname(__FILE__) }; +use TestLint; + +sub lint_versions { + my ($old, $new) = @_; + my ($rc, $out, $err) = run('--versions', $old, $new, '--sql-dir', sql_dir()); + my ($added, $removed) = $out =~ /^ (\d+) object\(s\) added, (\d+) removed$/m; + return { rc => $rc, added => $added, removed => $removed, + gaps => findings($out), out => $out, err => $err }; +} + +# -- Clean pairs ------------------------------------------------------------- + +for my $case ([ '0.2.0', '0.2.1', 17 ], [ '0.2.3', '0.3.0', 121 ]) { + my ($old, $new, $n) = @$case; + my $r = lint_versions($old, $new); + is($r->{rc}, 0, "$old -> $new is clean"); + is($r->{added}, $n, "$old -> $new adds $n objects"); + is($r->{removed}, 0, "$old -> $new removes nothing"); +} + +{ + # The two files differ only inside function bodies, which this check does + # not look at -- so an empty diff here is the correct answer, not a parse + # failure that happens to produce one. + my $r = lint_versions('0.2.2', '0.2.3'); + is($r->{rc}, 0, '0.2.2 -> 0.2.3 is clean'); + is($r->{added}, 0, '0.2.2 -> 0.2.3 adds nothing'); + is($r->{removed}, 0, '0.2.2 -> 0.2.3 removes nothing'); +} + +# -- The historical gap ------------------------------------------------------ + +my @missing_grants = map { "acl:type:cat_tools.$_" } + qw(constraint_type object_type procedure_type relation_relkind relation_type); + +for my $case ([ '0.2.0', '0.2.2', 22 ], [ '0.2.1', '0.2.2', 5 ]) { + my ($old, $new, $n) = @$case; + my $r = lint_versions($old, $new); + is($r->{rc}, 1, "$old -> $new reports a gap"); + is($r->{added}, $n, "$old -> $new adds $n objects"); + is_deeply($r->{gaps}, \@missing_grants, + "$old -> $new is missing exactly the five pre-0.2.2 enum type grants"); +} + +# -- The current pair -------------------------------------------------------- + +{ + my ($rc, $out) = run_in(repo_root()); + is($rc, 0, 'the current version pair is clean') + or diag($out); +} + +done_testing(); diff --git a/bin/test/TestLint.pm b/bin/test/TestLint.pm new file mode 100644 index 0000000..8e02582 --- /dev/null +++ b/bin/test/TestLint.pm @@ -0,0 +1,95 @@ +package TestLint; +# +# Shared plumbing for the bin/update_lint test suite: run the script with a +# known working directory and capture its two streams separately, since which +# stream a line lands on is part of what is being asserted. + +use strict; +use warnings; +use Exporter 'import'; +use File::Basename qw(dirname); +use File::Spec; +use File::Temp qw(tempdir); +use Cwd qw(abs_path); +use Test::More; + +our @EXPORT = qw(run run_in repo_root sql_dir fixture write_tmp concat_tmp + objects findings usage_exit); + +my $TEST_DIR = abs_path(dirname(__FILE__)); +my $REPO_ROOT = abs_path(File::Spec->catdir($TEST_DIR, '..', '..')); +my $SCRIPT = File::Spec->catfile($REPO_ROOT, 'bin', 'update_lint'); +my $TMP = tempdir(CLEANUP => 1); + +sub repo_root { return $REPO_ROOT } +sub sql_dir { return File::Spec->catdir($REPO_ROOT, 'sql') } +sub fixture { return File::Spec->catfile($TEST_DIR, 'fixtures', $_[0]) } + +sub run { return run_in($REPO_ROOT, @_) } + +sub run_in { + my ($dir, @args) = @_; + my $out = File::Spec->catfile($TMP, 'stdout'); + my $err = File::Spec->catfile($TMP, 'stderr'); + my $cmd = join ' ', map { "'" . do { my $s = $_; $s =~ s/'/'\\''/g; $s } . "'" } + ($^X, $SCRIPT, @args); + system("cd '$dir' && $cmd > '$out' 2> '$err'"); + my $rc = $? >> 8; + return ($rc, _slurp($out), _slurp($err)); +} + +sub _slurp { + my ($p) = @_; + open my $fh, '<', $p or return ''; + local $/; + my $t = <$fh>; + close $fh; + return defined $t ? $t : ''; +} + +# Assert that @args is rejected with the usage exit code. There are enough of +# these that spelling out the whole run-and-compare each time buries the +# arguments, which are the only thing that differs between them. +sub usage_exit { + my ($what, @args) = @_; + my ($rc) = run(@args); + is($rc, 2, "$what exits 2"); +} + +my $seq = 0; + +# Write $content to a uniquely named .sql.in under the suite's temp dir. +sub write_tmp { + my ($content) = @_; + my $p = File::Spec->catfile($TMP, 'snippet' . ++$seq . '.sql.in'); + open my $fh, '>', $p or die "cannot write $p: $!"; + print $fh $content; + close $fh; + return $p; +} + +# Concatenate existing files into one new temp file. +sub concat_tmp { + my @parts = map { _slurp($_) } @_; + return write_tmp(join "\n", @parts); +} + +# The --list-objects output of $file as a list of lines. Fails loudly rather +# than returning an empty set, so a parse error can never read as "no objects". +sub objects { + my ($file) = @_; + my ($rc, $out, $err) = run('--list-objects', $file); + die "update_lint --list-objects $file exited $rc:\n$err" if $rc != 0; + return [ split /\n/, $out ]; +} + +# The keys reported as unhandled in $out, sorted. Report lines read +# " added, never created: "; pass $which ('added' or 'removed') to take +# one side only, since which side a key lands on is itself asserted. +sub findings { + my ($out, $which) = @_; + my $side = defined $which ? quotemeta($which) : '\w+'; + return [ sort($out =~ /^ $side, never \w+:\s+(\S+)$/mg) ]; +} + +1; diff --git a/bin/test/fixtures/all-forms-extra.sql.in b/bin/test/fixtures/all-forms-extra.sql.in new file mode 100644 index 0000000..c556668 --- /dev/null +++ b/bin/test/fixtures/all-forms-extra.sql.in @@ -0,0 +1,24 @@ +/* + * The delta half of the diff fixture pair. 02-diff.t concatenates + * all-forms.sql.in with this file to build the "new install" side, so the + * object set of all-forms.sql.in stays defined in exactly one place. + * + * Everything here is plain DDL rather than a __cat_tools.create_function() + * call, because the concatenation lands after all-forms.sql.in has dropped its + * scaffolding. update-covers-all.sql.in must account for every key this adds. + */ + +CREATE TYPE lt.size AS ENUM( + 'small' + , 'large' +); +COMMENT ON TYPE lt.size IS $$How big a thing is$$; + +CREATE VIEW lt.thing_v3 AS SELECT id FROM lt.thing; +GRANT SELECT ON lt.thing_v3 TO lt__usage; + +CREATE FUNCTION lt.measure( + thing_id int +) RETURNS int LANGUAGE sql AS $body$SELECT 1$body$; +REVOKE ALL ON FUNCTION lt.measure(thing_id int) FROM public; +GRANT EXECUTE ON FUNCTION lt.measure(thing_id int) TO lt__usage; diff --git a/bin/test/fixtures/all-forms.sql.in b/bin/test/fixtures/all-forms.sql.in new file mode 100644 index 0000000..8a1185e --- /dev/null +++ b/bin/test/fixtures/all-forms.sql.in @@ -0,0 +1,164 @@ +/* + * One instance of every statement form bin/update_lint recognizes. + * + * Teaching update_lint a new form means adding a line here AND extending the + * expected object set in bin/test/01-extract.t by hand. That hand-authored set + * IS the assertion: it is short enough to read, and a regenerated one would + * look equally plausible whichever way it was wrong. + * + * The helper names below (__cat_tools.exec, __cat_tools.create_function) are + * the literal names update_lint recurses through, so they are not renameable. + */ + +@generated@ + +DO $$ +BEGIN + CREATE ROLE lt__usage NOLOGIN; +EXCEPTION WHEN duplicate_object THEN + NULL; +END +$$; + +CREATE SCHEMA __cat_tools; +CREATE SCHEMA lt; +GRANT USAGE ON SCHEMA lt TO lt__usage; +ALTER DEFAULT PRIVILEGES IN SCHEMA lt GRANT USAGE ON TYPES TO lt__usage; + +CREATE FUNCTION __cat_tools.exec( + sql text +) RETURNS void LANGUAGE plpgsql AS $body$ +BEGIN + EXECUTE sql; +END +$body$; + +/* + * The nested $template$ strings below are format() templates -- data stored in + * a function body, not DDL -- so none of them may become objects. + */ +CREATE FUNCTION __cat_tools.create_function( + function_name text + , args text + , options text + , body text + , grants text DEFAULT NULL + , comment text DEFAULT NULL +) RETURNS void LANGUAGE plpgsql AS $body$ +DECLARE + create_template CONSTANT text := $template$ +CREATE OR REPLACE FUNCTION %s( +%s +) RETURNS %s AS +%L +$template$ + ; + revoke_template CONSTANT text := $template$ +REVOKE ALL ON FUNCTION %s( +%s +) FROM public; +$template$ + ; +@generated@ +BEGIN + PERFORM __cat_tools.exec(format(create_template, function_name, args, options, body)); + PERFORM __cat_tools.exec(format(revoke_template, function_name, args)); +END +$body$; + +@generated@ + +/* + * Leading commas, two labels on one line, both comment styles interleaved, and + * a version-conditional marker whose line stays code here. + */ +CREATE TYPE lt.color AS ENUM( + 'red', 'green' -- two labels, one line + /* a block comment in the middle of the label list */ + , 'blue' + , 'ultraviolet' -- SED: REQUIRES 9.5! +); +COMMENT ON TYPE lt.color IS $$Colors a thing can be$$; + +CREATE TYPE lt.pair AS ( + first_name text + , second_name text +); + +CREATE DOMAIN lt.positive AS int CHECK( VALUE > 0 ); + +CREATE TABLE lt.thing( + id int + CONSTRAINT thing__pk PRIMARY KEY + , shade lt.color +); +INSERT INTO lt.thing VALUES(1, 'red'); +UPDATE lt.thing SET shade = 'blue' WHERE id = 1; +CLUSTER lt.thing USING thing__pk; +SET LOCAL enable_seqscan = on; + +CREATE SEQUENCE lt.thing_seq; +CREATE INDEX thing__shade ON lt.thing(shade); + +/* + * Dynamic DDL through the exec() gateway. The view name is real; the %s is a + * placeholder and must not be mistaken for one. + */ +SELECT __cat_tools.exec(format($fmt$ +CREATE OR REPLACE VIEW lt.thing_v AS + SELECT %s FROM lt.thing +; +$fmt$ + , 'id, shade' +)); +REVOKE ALL ON lt.thing_v FROM public; +GRANT SELECT ON lt.thing_v TO lt__usage; + +CREATE VIEW lt.thing_v2 AS SELECT id FROM lt.thing; + +CREATE CAST ("char" AS lt.color) WITH INOUT AS IMPLICIT; + +SELECT __cat_tools.create_function( + 'lt.describe' + , 'thing_id int, verbose boolean' + , 'text LANGUAGE sql STABLE' + , $body$ +SELECT 'thing' +$body$ + , 'lt__usage' + , 'Describe a thing' +); + +-- No grants and no comment argument: only the function and its ACL. +SELECT __cat_tools.create_function( + 'lt.internal' + , '' + , 'void LANGUAGE sql' + , $body$ +SELECT NULL::void +$body$ +); + +GRANT USAGE ON TYPE + lt.color + , lt.positive + TO lt__usage; + +@generated@ + +/* + * Scaffolding teardown: every key created and dropped in one file cancels out, + * which is what keeps __cat_tools out of the object set with no name list. + */ +DROP FUNCTION __cat_tools.exec( + sql text +); +DROP FUNCTION __cat_tools.create_function( + function_name text + , args text + , options text + , body text + , grants text + , comment text +); +DROP SCHEMA __cat_tools; diff --git a/bin/test/fixtures/update-covers-all.sql.in b/bin/test/fixtures/update-covers-all.sql.in new file mode 100644 index 0000000..d3b8927 --- /dev/null +++ b/bin/test/fixtures/update-covers-all.sql.in @@ -0,0 +1,22 @@ +/* + * The update script that fully accounts for all-forms-extra.sql.in. + * + * lt.size deliberately carries no explicit GRANT: the ALTER DEFAULT PRIVILEGES + * in all-forms.sql.in already covers it, and only a run that seeds this + * script's default-privilege state from the OLD install can see that. + */ + +CREATE TYPE lt.size AS ENUM( + 'small' + , 'large' +); +COMMENT ON TYPE lt.size IS $$How big a thing is$$; + +CREATE VIEW lt.thing_v3 AS SELECT id FROM lt.thing; +GRANT SELECT ON lt.thing_v3 TO lt__usage; + +CREATE FUNCTION lt.measure( + thing_id int +) RETURNS int LANGUAGE sql AS $body$SELECT 1$body$; +REVOKE ALL ON FUNCTION lt.measure(thing_id int) FROM public; +GRANT EXECUTE ON FUNCTION lt.measure(thing_id int) TO lt__usage; diff --git a/bin/update_lint b/bin/update_lint new file mode 100755 index 0000000..7b9bba4 --- /dev/null +++ b/bin/update_lint @@ -0,0 +1,1810 @@ +#!/usr/bin/env perl +# +# update_lint - prove, statically, that an extension UPDATE script accounts for +# every object the install scripts on either side of it disagree about. +# +# Parse two versioned install scripts, diff their object sets, and check that +# the update script between them creates/drops/alters/grants/comments each +# object the diff demands. No database, no `make`, no pg_config -- it reads the +# tracked sql/*.sql.in sources directly, so it runs in a few hundred +# milliseconds in the same CI job as the style linter. +# +# It exists because the rule it enforces is otherwise human-only: a PR that +# changes an extension's SQL must also extend +# sql/----.sql.in so an existing install reaches +# the same objects. Nothing else fails when that is forgotten until the runtime +# check (bin/structural_diff via `bin/test_existing update-scenario`) runs, and +# that needs a database, several PostgreSQL majors, and minutes of CI. +# +# This is an early-warning net, NOT an authority. It compares object IDENTITY, +# never definition, so a changed function body or view definition is invisible +# to it; bin/structural_diff remains the check that a fresh install and an +# updated install are actually equivalent. A clean run here means only that no +# object was added or removed without the update script mentioning it. +# +# USAGE: +# bin/update_lint +# Lint the current pair: the highest tracked released install snapshot +# under --sql-dir, updated to the version in sql/.sql.in. +# +# bin/update_lint OLD_INSTALL NEW_INSTALL UPDATE_SCRIPT +# Lint an explicit trio of files. Nothing is inferred from the file +# names, so /dev/null is a legal argument for any of them: as +# OLD_INSTALL it means "compare against nothing", as UPDATE_SCRIPT it +# means "no update script at all". +# +# bin/update_lint --versions OLD NEW +# Sugar for the trio, resolved under --sql-dir as +# --OLD, --NEW and --OLD--NEW (each preferring .sql.in +# over .sql). A missing update script is treated as EMPTY rather than +# skipped -- skipping would pass silently on exactly the omission this +# check exists to catch. +# +# bin/update_lint --list-objects FILE +# Print one file's extracted object set, sorted, as "kindidentity". +# This asserts the parse on its own, independently of any diff, and is +# the first thing to run when a finding looks wrong. "data" entries are +# advisory (see handle_data below) and take no part in the diff. +# +# Options: --sql-dir DIR (default "sql"), --ext NAME (default "cat_tools"). +# Both affect only --versions and the default mode; paths are resolved +# relative to the current directory, never from this script's location. +# +# Exit: 0 clean, 1 gaps found, 2 usage error, 3 unanalyzable input. +# +# SCOPE: only the update path INTO the current unreleased version is linted by +# default. Version-specific install and update scripts are frozen once released +# (SQL file conventions in CLAUDE.md -- never hand-edited again), so a finding +# against a historical pair could never be fixed and would be permanently red. +# Historical pairs stay reachable by passing an explicit pair, which is how the +# test suite pins the pre-0.2.2 ACL gap as a known-bad oracle. There is +# deliberately no baseline or suppression file: the exclusion is structural. +# +# LIMITATIONS: +# +# Version-conditional `-- SED: REQUIRES N!` / `-- SED: PRIOR TO N!` lines are +# resolved for the NEWEST PostgreSQL: the REQUIRES branch stays code, the +# PRIOR TO branch is commented out, exactly as sql.mk would do it. Every marker +# in this tree names 9.3, 9.5 or 11 -- all below the PG12 support floor -- so +# the REQUIRES branch is what installs on every major this extension supports, +# and there is no supported server for which the other branch is the live one. +# An object that exists ONLY below the floor is therefore not tracked at all. +# +# Keeping both branches instead is not the safer choice: it doubles every +# version-gated line, and for a positional helper like create_function() a +# doubled argument list shifts the arguments and mislabels the object. +# +# Coverage of a %PRESENCE_KIND (acl, comment, seclabel, rolegrant) is +# direction-blind, so a REVOKE-only update script satisfies an ADDED grant. The +# rationale is at the %PRESENCE_KIND definition, but note that the flagship +# catch here -- five enum types that never got GRANT USAGE -- is in exactly +# that class, so a stray REVOKE naming one of them would silence it. +# +# ALTER DEFAULT PRIVILEGES seeding assumes the role running +# `ALTER EXTENSION ... UPDATE` is the one that ran `CREATE EXTENSION`: +# pg_default_acl is keyed per grantor role, so a different role gets none of +# the default privileges the old install left behind. +# +# Functions are keyed by name and ARITY, not by argument types, so two +# overloads that differ only in a type collide into one key. This is live, not +# hypothetical: cat_tools.relation__kind(cat_tools.relation_relkind) and +# cat_tools.relation__kind(text) share a key, as do eight other names in +# sql/cat_tools.sql.in. A brand-new overload of an existing name at an arity +# that name already has therefore reads as "nothing added", and so do its ACL +# and comment. Arity is nonetheless the right key: it is what a DROP writes +# (PostgreSQL ignores OUT parameters, argument names and DEFAULT clauses when +# matching a signature), so it is what makes a CREATE key and its later DROP +# key identical -- which the same-file scaffolding cancellation depends on. +# Distinguishing overloads would mean normalizing type names the way +# PostgreSQL does, which is a catalog lookup, not a text transformation. + +use strict; +use warnings; + +# Unbuffered, so the FAIL line on stderr lands after the findings it summarizes +# when both streams are redirected into one CI log. +$| = 1; + +my $PROG = 'bin/update_lint'; + +# --------------------------------------------------------------------------- +# Lexical scanner +# +# One pass over the text produces everything the rest of the script needs, so +# that comments, string literals and quoted identifiers are handled in exactly +# one place instead of being re-approximated by every regex: +# +# $code the text with comment regions blanked to spaces (same length) +# $masked $code with literal AND quoted-identifier contents also blanked, +# for locating keywords (ON / TO / FROM / IS / AS) and the `;` and +# `,` separators, none of which may match inside a quoted name +# @depth paren+bracket nesting depth at each character +# @lits [content_start, content_end, delimiter] for every string literal +# and dollar-quoted string, in source order +# @open [offset, description] for every construct with no closing +# delimiter, which makes the whole scan a guess: the text from there +# to EOF holds no recognizable statement boundary, so every object +# in it would silently disappear. Callers turn this into a hard +# error rather than analyzing what is left. +# +# Offsets are identical across $code, $masked and the original, so a regex on +# $masked can index straight into $code. +# --------------------------------------------------------------------------- + +sub scan { + my ($s) = @_; + my $n = length $s; + my $code = $s; + my $masked = $s; + my @depth = (0) x ($n + 1); + my @lits; + my @open; + + my $blank = sub { + my ($from, $to, $which) = @_; + return if $to <= $from; + substr($code, $from, $to - $from) = ' ' x ($to - $from) if $which ne 'masked'; + substr($masked, $from, $to - $from) = ' ' x ($to - $from); + }; + + my $i = 0; + my $d = 0; + while ($i < $n) { + $depth[$i] = $d; + my $c = substr($s, $i, 1); + my $two = substr($s, $i, 2); + + if ($two eq '--') { + my $nl = index($s, "\n", $i); + $nl = $n if $nl < 0; + $depth[$_] = $d for $i .. $nl - 1; + $blank->($i, $nl, 'both'); + $i = $nl; + next; + } + if ($two eq '/*') { + # Block comments nest in PostgreSQL, so this counts rather than + # stopping at the first */. + my $start = $i; + my $nest = 1; + $i += 2; + while ($i < $n && $nest) { + my $t = substr($s, $i, 2); + if ($t eq '/*') { $nest++; $i += 2 } + elsif ($t eq '*/') { $nest--; $i += 2 } + else { $i++ } + } + push @open, [ $start, 'block comment' ] if $nest; + $depth[$_] = $d for $start .. $i - 1; + $blank->($start, $i, 'both'); + next; + } + if ($c eq '$') { + pos($s) = $i; + if ($s =~ /\G(\$(?:[A-Za-z_\x80-\xFF][A-Za-z0-9_\x80-\xFF]*)?\$)/gc) { + # A dollar-quoted string is consumed atomically: the same tag + # cannot nest, so the first repeat of the opening tag ends it. + # This is what keeps a $template$...$template$ inside a + # $body$...$body$ from being seen as SQL of its own. + my $tag = $1; + my $cs = $i + length $tag; + my $close = index($s, $tag, $cs); + my $ce = $close < 0 ? $n : $close; + my $end = $close < 0 ? $n : $close + length $tag; + push @open, [ $i, "dollar-quoted string $tag" ] if $close < 0; + $depth[$_] = $d for $i .. $end - 1; + push @lits, [ $cs, $ce, $tag ]; + $blank->($cs, $ce, 'masked'); + $i = $end; + next; + } + # A bare $ (plpgsql positional parameter) is just a character. + $i++; + next; + } + if ($c eq "'") { + # Backslash escapes apply only to an E'' literal; a plain literal + # ends its content only at an unpaired quote. + my $esc = 0; + if ($i > 0) { + my $p = substr($s, $i - 1, 1); + my $q = $i >= 2 ? substr($s, $i - 2, 1) : ' '; + $esc = 1 if ($p eq 'E' || $p eq 'e') && $q !~ /[A-Za-z0-9_\$]/; + } + my $start = $i; + my $closed = 0; + $i++; + while ($i < $n) { + my $ch = substr($s, $i, 1); + if ($esc && $ch eq "\\") { $i += 2; next } + if ($ch eq "'") { + if (substr($s, $i + 1, 1) eq "'") { $i += 2; next } + $i++; + $closed = 1; + last; + } + $i++; + } + push @open, [ $start, 'string literal' ] unless $closed; + my $ce = $i - 1 > $start ? $i - 1 : $start + 1; + $depth[$_] = $d for $start .. $i - 1; + push @lits, [ $start + 1, $ce, "'" ]; + $blank->($start + 1, $ce, 'masked'); + next; + } + if ($c eq '"') { + # A quoted identifier keeps its content in $code -- names are read + # out of $code, and "char" must survive to be read -- but is blanked + # in $masked, because a `;` or `,` inside a name is not a separator. + my $start = $i; + my $closed = 0; + $i++; + while ($i < $n) { + my $ch = substr($s, $i, 1); + if ($ch eq '"') { + if (substr($s, $i + 1, 1) eq '"') { $i += 2; next } + $i++; + $closed = 1; + last; + } + $i++; + } + push @open, [ $start, 'quoted identifier' ] unless $closed; + $depth[$_] = $d for $start .. $i - 1; + $blank->($start + 1, $closed ? $i - 1 : $i, 'masked'); + next; + } + if ($c eq '(' || $c eq '[') { $depth[$i] = $d; $d++; $i++; next } + if ($c eq ')' || $c eq ']') { $d-- if $d > 0; $depth[$i] = $d; $i++; next } + $i++; + } + $depth[$n] = $d; + return ($code, $masked, \@depth, \@lits, \@open); +} + +# Split into top-level statements. Returns [ { text, offset } ], where offset +# indexes into the ORIGINAL string so callers can turn it into a line number. +sub split_stmts { + my ($s) = @_; + my ($code, $masked, $depth) = scan($s); + my @out; + my $start = 0; + my $n = length $code; + for (my $i = 0 ; $i < $n ; $i++) { + next unless substr($masked, $i, 1) eq ';' && $depth->[$i] == 0; + push @out, { text => substr($code, $start, $i - $start), offset => $start }; + $start = $i + 1; + } + push @out, { text => substr($code, $start), offset => $start } if $start < $n; + return [ grep { $_->{text} =~ /\S/ } @out ]; +} + +# Split on commas at nesting depth 0, outside literals and comments. +sub split_top_commas { + my ($s) = @_; + my ($code, $masked, $depth) = scan($s); + my @out; + my $start = 0; + my $n = length $code; + for (my $i = 0 ; $i < $n ; $i++) { + next unless substr($masked, $i, 1) eq ',' && $depth->[$i] == 0; + push @out, substr($code, $start, $i - $start); + $start = $i + 1; + } + push @out, substr($code, $start); + return @out; +} + +# Content of $s if it is exactly one string literal, else undef. +sub literal_value { + my ($s) = @_; + my ($code, $masked, $depth, $lits) = scan($s); + return undef unless @$lits == 1; + my ($cs, $ce, $delim) = @{ $lits->[0] }; + my $before = substr($code, 0, $cs - ($delim eq "'" ? 1 : length $delim)); + my $after = substr($code, $ce + ($delim eq "'" ? 1 : length $delim)); + return undef if $before =~ /\S/ || $after =~ /\S/; + my $v = substr($code, $cs, $ce - $cs); + $v =~ s/''/'/g if $delim eq "'"; + return $v; +} + +# --------------------------------------------------------------------------- +# Identifier and name handling +# --------------------------------------------------------------------------- + +my $IDENT = qr/(?:"(?:[^"]|"")*"|[A-Za-z_\x80-\xFF][A-Za-z0-9_\$\x80-\xFF]*)/; +my $QNAME = qr/$IDENT(?:\s*\.\s*$IDENT)*/; + +# Canonical form of a possibly-qualified, possibly-quoted name. The repo is +# uniformly lowercase and unquoted apart from "char", so folding everything to +# unquoted lowercase makes a CREATE key and its matching DROP key identical -- +# which is what the same-file scaffolding cancellation below depends on. +sub norm_name { + my ($raw) = @_; + return undef unless defined $raw; + $raw =~ s/\s*\.\s*/./g; + $raw =~ s/\A\s+//; + $raw =~ s/\s+\z//; + my @parts; + for my $p (split /\./, $raw) { + $p =~ s/\A"//; + $p =~ s/"\z//; + $p =~ s/""/"/g; + push @parts, lc $p; + } + return join '.', @parts; +} + +sub schema_of { + my ($name) = @_; + return undef unless defined $name && $name =~ /\A([^.]+)\./; + return $1; +} + +# Consume a leading qualified name from $$ref, returning its canonical form. +sub take_name { + my ($ref) = @_; + $$ref =~ s/\A\s+//; + return undef unless $$ref =~ s/\A($QNAME)//; + return norm_name($1); +} + +# Consume a leading parenthesized group from $$ref, returning its inner text. +sub take_paren_group { + my ($ref) = @_; + $$ref =~ s/\A\s+//; + return undef unless substr($$ref, 0, 1) eq '('; + my (undef, undef, $depth) = scan($$ref); + my $n = length $$ref; + for (my $i = 1 ; $i < $n ; $i++) { + next unless substr($$ref, $i, 1) eq ')' && $depth->[$i] == 0; + my $inner = substr($$ref, 1, $i - 1); + $$ref = substr($$ref, $i + 1); + return $inner; + } + return undef; +} + +# PostgreSQL ignores OUT parameters, argument names and DEFAULT clauses when +# matching a function signature, so arity over the non-OUT arguments is the +# cheapest identity that survives the argument-name differences between a +# CREATE and its later DROP. See the header's LIMITATIONS for what that costs. +sub arity_of_args { + my ($args) = @_; + return 0 unless defined $args && $args =~ /\S/; + my $n = 0; + for my $p (split_top_commas($args)) { + next unless $p =~ /\S/; + $n++ unless $p =~ /\A\s*OUT\b/i; + } + return $n; +} + +# --------------------------------------------------------------------------- +# Object-type vocabulary +# +# Longest phrase wins, so multi-word types are listed before the single words +# they start with. Types with no use in this extension today are still listed +# so that a statement naming one is RECOGNIZED; whether it can then be given a +# key is a separate question, answered by %FORBIDDEN_OBJ and %UNKEYABLE_OBJ +# below. +# --------------------------------------------------------------------------- + +my @OBJ_TYPES = ( + 'TEXT SEARCH CONFIGURATION', 'TEXT SEARCH DICTIONARY', + 'TEXT SEARCH PARSER', 'TEXT SEARCH TEMPLATE', + 'FOREIGN DATA WRAPPER', 'MATERIALIZED VIEW', + 'FOREIGN TABLE', 'OPERATOR CLASS', + 'OPERATOR FAMILY', 'USER MAPPING', + 'ACCESS METHOD', 'EVENT TRIGGER', + 'SCHEMA', 'TYPE', 'DOMAIN', 'VIEW', 'TABLE', 'SEQUENCE', 'INDEX', + 'FUNCTION', 'PROCEDURE', 'ROUTINE', 'AGGREGATE', 'CAST', 'TRANSFORM', + 'OPERATOR', 'TRIGGER', 'RULE', 'POLICY', 'STATISTICS', 'COLLATION', + 'CONVERSION', 'LANGUAGE', 'SERVER', 'ROLE', 'USER', 'GROUP', + 'PUBLICATION', 'SUBSCRIPTION', 'DATABASE', 'TABLESPACE', 'EXTENSION', +); + +# Object types that must never appear in an extension script (they are +# forbidden inside one, inside a transaction block, or both). +my %FORBIDDEN_OBJ = map { $_ => 1 } + ('PUBLICATION', 'SUBSCRIPTION', 'DATABASE', 'TABLESPACE', 'EXTENSION'); + +# Object types whose identity is not their name: a trigger, policy or rule is +# identified by its name AND the relation it hangs off, an operator by its +# argument types, a transform by its type and language, a user mapping by its +# user and server. CREATE, DROP, ALTER and COMMENT each name that second half +# differently, so each type would need four parses of its own. None is used by +# this extension, and a key built from the name alone would be actively wrong +# -- two same-named triggers on different tables would collide into one -- so +# every form naming one is a hard error instead. The day one is needed the +# failure says exactly that, and the handling gets written then. +my %UNKEYABLE_OBJ = map { $_ => 1 } + ('TRIGGER', 'RULE', 'POLICY', 'OPERATOR', 'OPERATOR CLASS', + 'OPERATOR FAMILY', 'TRANSFORM', 'USER MAPPING'); + +# True (having recorded the error) if $objtype cannot carry a key here. +sub reject_objtype { + my ($ctx, $st, $verb, $objtype) = @_; + if ($FORBIDDEN_OBJ{$objtype}) { + err($ctx, $st, "$verb $objtype is not allowed in an extension script"); + return 1; + } + if ($UNKEYABLE_OBJ{$objtype}) { + err($ctx, $st, "$objtype is not identified by its name alone; update_lint has no handling for it"); + return 1; + } + return 0; +} + +# Key prefix per object type. Relation-like types share one namespace because +# they share one PostgreSQL namespace: a view cannot be replaced by a table of +# the same name without the diff noticing. +my %KIND_OF = ( + 'SCHEMA' => 'schema', + 'TYPE' => 'type', + 'DOMAIN' => 'type', + 'VIEW' => 'relation', + 'MATERIALIZED VIEW' => 'relation', + 'TABLE' => 'relation', + 'FOREIGN TABLE' => 'relation', + 'SEQUENCE' => 'relation', + 'FUNCTION' => 'function', + 'PROCEDURE' => 'function', + 'ROUTINE' => 'function', + 'AGGREGATE' => 'aggregate', + 'CAST' => 'cast', + 'ROLE' => 'role', + 'USER' => 'role', + 'GROUP' => 'role', +); + +sub kind_of { + my ($objtype) = @_; + return $KIND_OF{$objtype} if exists $KIND_OF{$objtype}; + my $k = lc $objtype; + $k =~ s/\s+/_/g; + return $k; +} + +# A multi-word phrase as a pattern that tolerates any whitespace, including a +# newline, between its words. +sub phrase_re { my ($p) = @_; return join '\s+', map { quotemeta } split / /, $p } + +# Consume a leading object-type phrase from $$ref. +sub take_objtype { + my ($ref) = @_; + $$ref =~ s/\A\s+//; + for my $t (@OBJ_TYPES) { + my $re = phrase_re($t); + return $t if $$ref =~ s/\A$re\b//i; + } + return undef; +} + +# --------------------------------------------------------------------------- +# Parse context +# --------------------------------------------------------------------------- + +sub new_ctx { + my (%o) = @_; + return { + path => $o{path}, + # created/dropped map a key to the SEQUENCE NUMBER of the last event of + # that direction, not to a bare flag. Comparing the two is what tells a + # created-then-dropped scaffold (cancels) from a dropped-then-created + # rebuild (does not); numbering starts at 1 so every recorded key stays + # truthy for the plain set-membership tests elsewhere. + seq => 0, + created => {}, + dropped => {}, + touched => {}, + cascade => {}, # dropped keys whose drop was a CASCADE + data => {}, # table => concatenated normalized DML text + adp => { map { $_ => { %{ $o{seed_adp}{$_} } } } + keys %{ $o{seed_adp} || {} } }, + errors => [], + }; +} + +# A name carrying a format() placeholder is not a real identity -- it is a +# template that only resolves at run time -- so it is dropped rather than +# tracked or reported. +sub unresolvable { my ($k) = @_; return !defined $k || $k =~ /%/ } + +sub add_key { + my ($ctx, $key) = @_; + return if unresolvable($key); + $ctx->{created}{$key} = ++$ctx->{seq}; + $ctx->{touched}{$key} = 1; +} + +sub del_key { + my ($ctx, $key, $cascade) = @_; + return if unresolvable($key); + $ctx->{dropped}{$key} = ++$ctx->{seq}; + $ctx->{touched}{$key} = 1; + $ctx->{cascade}{$key} = 1 if $cascade; +} + +# ADD and DROP forms of the same clause differ only in direction, so call sites +# build the key and leave the direction here. +sub key_op { + my ($ctx, $op, $key) = @_; + uc($op) eq 'ADD' ? add_key($ctx, $key) : del_key($ctx, $key); +} + +sub touch_key { + my ($ctx, $key) = @_; + return if unresolvable($key); + $ctx->{touched}{$key} = 1; +} + +sub err_at { + my ($ctx, $offset, $msg) = @_; + push @{ $ctx->{errors} }, "$ctx->{path}:" . $ctx->{line_of}->($offset) . ": $msg"; +} + +sub err { + my ($ctx, $st, $msg) = @_; + my $line = $ctx->{line_of}->($st->{offset}); + my $snip = $st->{text}; + $snip =~ s/\s+/ /g; + $snip =~ s/\A //; + $snip = substr($snip, 0, 70) . '...' if length $snip > 73; + push @{ $ctx->{errors} }, "$ctx->{path}:$line: $msg: $snip"; +} + +# --------------------------------------------------------------------------- +# Statement processing +# --------------------------------------------------------------------------- + +# Statements of one SQL text stream -- the file itself, or a payload reached +# through a dynamic-SQL gateway -- with offsets rebased onto the file. +# +# An unterminated comment, string or dollar quote is refused here rather than +# analyzed: the text past the opening delimiter holds no statement boundary the +# scanner can trust, so it fuses onto the statement in progress and every +# object in it vanishes without a trace. Each stream needs its own check +# because the outer scan steps over a gateway payload as one literal, never +# looking inside it. +sub checked_stmts { + my ($ctx, $text, $base) = @_; + my (undef, undef, undef, undef, $open) = scan($text); + if (@$open) { + err_at($ctx, $base + $_->[0], "unterminated $_->[1]") for @$open; + return []; + } + my $sts = split_stmts($text); + $_->{offset} += $base for @$sts; + return $sts; +} + +sub process_sql { + my ($ctx, $sql, $base_offset) = @_; + process_stmt($ctx, $_) for @{ checked_stmts($ctx, $sql, $base_offset || 0) }; +} + +sub process_stmt { + my ($ctx, $st) = @_; + my $t = $st->{text}; + return unless $t =~ /\S/; + # Advance the offset past the stripped whitespace so a reported line number + # points at the statement, not at the newline that ended the previous one. + my $lead = $t =~ s/\A(\s+)// ? length $1 : 0; + $st = { %$st, text => $t, offset => $st->{offset} + $lead }; + + my ($kw) = $t =~ /\A([A-Za-z]+)/; + return err($ctx, $st, 'unrecognized statement') unless defined $kw; + $kw = uc $kw; + + return handle_create($ctx, $st) if $kw eq 'CREATE'; + return handle_alter($ctx, $st) if $kw eq 'ALTER'; + return handle_drop($ctx, $st) if $kw eq 'DROP'; + return handle_acl($ctx, $st) if $kw eq 'GRANT' || $kw eq 'REVOKE'; + return handle_comment($ctx, $st) if $kw eq 'COMMENT'; + return handle_seclabel($ctx, $st) if $kw eq 'SECURITY'; + return handle_do($ctx, $st) if $kw eq 'DO'; + return handle_select($ctx, $st) if $kw eq 'SELECT'; + return handle_data($ctx, $st) + if $kw =~ /\A(?:INSERT|UPDATE|DELETE|TRUNCATE|COPY|MERGE)\z/; + + # Physical/maintenance commands: no catalog-structural effect, so they + # cannot change the object set. + return if $kw =~ /\A(?:CLUSTER|ANALYZE|ANALYSE|REINDEX)\z/; + return if $t =~ /\AREFRESH\s+MATERIALIZED\s+VIEW\b/i; + + return err($ctx, $st, 'this command cannot run inside an extension script') + if $kw =~ /\A(?:BEGIN|COMMIT|ROLLBACK|ABORT|END|SAVEPOINT|RELEASE|START|PREPARE|VACUUM)\z/; + + if ($kw eq 'SET' || $kw eq 'RESET') { + # Session GUCs are inert here. The state-changing SET forms are not. + return err($ctx, $st, 'state-changing SET is not allowed in an extension script') + if $t =~ /\ASET\s+(?:ROLE|SESSION\s+AUTHORIZATION|CONSTRAINTS|TRANSACTION)\b/i; + return; + } + + return err($ctx, $st, 'unrecognized statement'); +} + +# --- CREATE ---------------------------------------------------------------- + +sub handle_create { + my ($ctx, $st) = @_; + my $rest = $st->{text}; + $rest =~ s/\A\s*CREATE\s+//i; + 1 while $rest =~ s/\A(?:OR\s+REPLACE|TEMPORARY|TEMP|GLOBAL|LOCAL|UNLOGGED|RECURSIVE|UNIQUE|CONSTRAINT|DEFAULT|TRUSTED|PROCEDURAL)\s+//i; + + my $objtype = take_objtype(\$rest); + return err($ctx, $st, 'unrecognized CREATE') unless defined $objtype; + return if reject_objtype($ctx, $st, 'CREATE', $objtype); + return err($ctx, $st, 'CREATE INDEX CONCURRENTLY cannot run in a transaction block') + if $objtype eq 'INDEX' && $rest =~ /\A\s*CONCURRENTLY\b/i; + + $rest =~ s/\A\s*IF\s+NOT\s+EXISTS\s+//i; + + if ($objtype eq 'CAST') { + my $group = take_paren_group(\$rest); + return err($ctx, $st, 'unparsable CREATE CAST') unless defined $group; + return err($ctx, $st, 'unparsable CREATE CAST') + unless $group =~ /\A\s*($QNAME)\s+AS\s+($QNAME)\s*\z/i; + add_key($ctx, 'cast:' . norm_name($1) . '=>' . norm_name($2)); + return; + } + + if ($objtype eq 'SCHEMA') { + # CREATE SCHEMA AUTHORIZATION role names the schema after the role. + my $name = $rest =~ s/\A\s*AUTHORIZATION\s+//i + ? take_name(\$rest) + : do { my $n = take_name(\$rest); + $rest =~ s/\A\s*AUTHORIZATION\s+$QNAME//i; + $n }; + return err($ctx, $st, 'unparsable CREATE SCHEMA') unless defined $name; + # Schema elements are CREATE statements of their own, and this reads + # none of them, so it must not claim to have read the statement. + return err($ctx, $st, 'CREATE SCHEMA with schema elements is not handled') + if $rest =~ /\S/; + add_key($ctx, "schema:$name"); + return; + } + + if ($objtype eq 'INDEX') { + # An index lives in its TABLE's schema, and CREATE INDEX names the + # index unqualified while DROP INDEX names it qualified, so the schema + # has to come off the table for the two keys to meet. + return err($ctx, $st, 'CREATE INDEX without a name generates one that cannot be predicted') + if $rest =~ /\A\s*ON\b/i; + my $name = take_name(\$rest); + return err($ctx, $st, 'unparsable CREATE INDEX') unless defined $name; + return err($ctx, $st, 'unparsable CREATE INDEX') unless $rest =~ s/\A\s*ON\s+//i; + $rest =~ s/\A\s*ONLY\s+//i; + my $table = take_name(\$rest); + return err($ctx, $st, 'unparsable CREATE INDEX') unless defined $table; + my $schema = schema_of($table); + $name = "$schema.$name" if defined $schema && $name !~ /\./; + add_key($ctx, "index:$name"); + return; + } + + my $kind = kind_of($objtype); + + if ($kind eq 'function' || $kind eq 'aggregate') { + my $name = take_name(\$rest); + return err($ctx, $st, "unparsable CREATE $objtype") unless defined $name; + my $args = take_paren_group(\$rest); + my $key = "$kind:$name/" . arity_of_args($args); + add_key($ctx, $key); + adp_synthesize($ctx, $objtype, $key); + return; + } + + my $name = take_name(\$rest); + return err($ctx, $st, "unparsable CREATE $objtype") unless defined $name; + add_key($ctx, "$kind:$name"); + adp_synthesize($ctx, $objtype, "$kind:$name"); + + if ($objtype eq 'TYPE' || $objtype eq 'DOMAIN') { + if ($rest =~ /\A\s*AS\s+ENUM\s*(?=\()/i) { + $rest =~ s/\A\s*AS\s+ENUM\s*//i; + my $group = take_paren_group(\$rest); + add_key($ctx, "enumval:$name:$_") for enum_labels($group); + } + # A composite type. RANGE and the base-type form both put a keyword + # between AS and the parenthesis, so requiring one right after AS is + # what tells the composite apart. + elsif ($objtype eq 'TYPE' && $rest =~ /\A\s*AS\s*(?=\()/i) { + $rest =~ s/\A\s*AS\s*//i; + add_key($ctx, "attr:$name.$_") for column_names(take_paren_group(\$rest)); + } + } + elsif ($objtype eq 'TABLE') { + my $group = take_paren_group(\$rest); + if (defined $group) { + add_key($ctx, "constraint:$name." . norm_name($1)) + while $group =~ /\bCONSTRAINT\s+($IDENT)/gi; + add_key($ctx, "attr:$name.$_") for column_names($group); + } + } + return; +} + +# Table-level clauses that share the element list with the columns. Everything +# else in the list opens with its own column name. +my $TABLE_CLAUSE = qr/\A\s*(?:CONSTRAINT|PRIMARY\s+KEY|UNIQUE|CHECK|FOREIGN\s+KEY + |EXCLUDE|LIKE|PERIOD\s+FOR)\b/xi; + +# Column names out of a CREATE TABLE element list or a composite CREATE TYPE. +# Both sides of every diff are FRESH INSTALL scripts, which state a relation's +# final column list right here and never with an ALTER, so without this a +# column added by editing a CREATE TABLE is not an object at all and its +# missing ALTER TABLE ADD COLUMN cannot be reported. +# +# Depth-aware splitting is what keeps a type's own parentheses and commas +# (numeric(10,2)) from reading as another column; a DEFAULT expression, an +# inline CHECK and a table-level clause all stay inside the piece they belong +# to for the same reason. +sub column_names { + my ($group) = @_; + my @out; + for my $piece (object_list(defined $group ? $group : '')) { + next if $piece =~ /$TABLE_CLAUSE/; + my $p = $piece; + my $n = take_name(\$p); + push @out, $n if defined $n; + } + return @out; +} + +sub enum_labels { + my ($group) = @_; + return () unless defined $group; + my ($code, undef, undef, $lits) = scan($group); + my @out; + for my $l (@$lits) { + next unless $l->[2] eq "'"; + my $v = substr($code, $l->[0], $l->[1] - $l->[0]); + $v =~ s/''/'/g; + push @out, $v; + } + return @out; +} + +# ALTER DEFAULT PRIVILEGES is not an object; it is persistent pg_default_acl +# state that implicitly grants on every object of one CATEGORY created in that +# schema AFTERWARDS, and it stays in effect for later update scripts too. It is +# modelled as a per-schema, per-category flag, and every subsequent CREATE in a +# flagged schema synthesizes the ACL key it would really produce. +# +# The category, not the key kind, is what the flag is stored under: TABLES and +# SEQUENCES are separate default-privilege categories but share the `relation` +# key kind, so a default grant on tables must not put an ACL on a sequence. +my %ADP_CATEGORY_OF = ( + 'TYPE' => 'TYPES', 'DOMAIN' => 'TYPES', + 'TABLE' => 'TABLES', 'VIEW' => 'TABLES', + 'FOREIGN TABLE' => 'TABLES', 'MATERIALIZED VIEW' => 'TABLES', + 'SEQUENCE' => 'SEQUENCES', + 'FUNCTION' => 'FUNCTIONS', 'PROCEDURE' => 'FUNCTIONS', + 'ROUTINE' => 'FUNCTIONS', 'AGGREGATE' => 'FUNCTIONS', +); + +sub adp_synthesize { + my ($ctx, $objtype, $key) = @_; + my $cat = $ADP_CATEGORY_OF{$objtype} or return; + my $schema = schema_of(key_identity($key)); + return unless defined $schema && $ctx->{adp}{$schema}{$cat}; + add_key($ctx, "acl:$key"); +} + +# ALTER DEFAULT PRIVILEGES ... IN SCHEMA s { GRANT | REVOKE } ... ON +sub handle_adp { + my ($ctx, $st) = @_; + my $t = $st->{text}; + + my ($schemas, $op) = $t =~ /\bIN\s+SCHEMA\s+(.+?)\s+(GRANT|REVOKE)\b/is; + return err($ctx, $st, 'unparsable ALTER DEFAULT PRIVILEGES') unless defined $schemas; + my ($cat) = $t =~ /\bON\s+(TABLES|SEQUENCES|FUNCTIONS|ROUTINES|TYPES)\b/i; + # ON SCHEMAS is the remaining category, and it does not fit this model at + # all: it grants on schemas the role creates later, anywhere, and cannot be + # scoped with IN SCHEMA. + return err($ctx, $st, 'unhandled ALTER DEFAULT PRIVILEGES category') unless defined $cat; + $cat = uc $cat; + $cat = 'FUNCTIONS' if $cat eq 'ROUTINES'; + + my @schemas = object_list($schemas); + return err($ctx, $st, 'ALTER DEFAULT PRIVILEGES names no schema') unless @schemas; + for my $s (@schemas) { + my $n = norm_name($s); + # A REVOKE has to clear the flag, or later creates keep being credited + # with a default privilege that is no longer in force -- the one way + # this model could hide a genuinely missing grant. + uc($op) eq 'GRANT' ? ($ctx->{adp}{$n}{$cat} = 1) : (delete $ctx->{adp}{$n}{$cat}); + } + return; +} + +# --- ALTER ----------------------------------------------------------------- + +sub handle_alter { + my ($ctx, $st) = @_; + my $t = $st->{text}; + + return handle_adp($ctx, $st) if $t =~ /\AALTER\s+DEFAULT\s+PRIVILEGES\b/i; + + return err($ctx, $st, "ALTER of global state is not allowed in an extension script") + if $t =~ /\AALTER\s+(?:SYSTEM|DATABASE|TABLESPACE|SUBSCRIPTION|LARGE\s+OBJECT)\b/i + || $t =~ /\AALTER\s+ROLE\b.*\bSET\b/is; + + if ($t =~ /\AALTER\s+EXTENSION\s+/i) { + my $rest = $t; + $rest =~ s/\AALTER\s+EXTENSION\s+//i; + take_name(\$rest); + return err($ctx, $st, 'unparsable ALTER EXTENSION') + unless $rest =~ s/\A\s*(ADD|DROP)\s+//i; + my $op = uc $1; + my $objtype = take_objtype(\$rest); + return err($ctx, $st, 'unparsable ALTER EXTENSION') unless defined $objtype; + return if reject_objtype($ctx, $st, "ALTER EXTENSION $op", $objtype); + my $key = member_key($objtype, \$rest); + return err($ctx, $st, 'unparsable ALTER EXTENSION') unless defined $key; + return err($ctx, $st, 'ALTER EXTENSION ADD needs an argument list') + if $op eq 'ADD' && $key =~ m{/\*\z}; + key_op($ctx, $op, $key); + return; + } + + my $rest = $t; + $rest =~ s/\AALTER\s+//i; + my $objtype = take_objtype(\$rest); + return err($ctx, $st, 'unrecognized ALTER') unless defined $objtype; + return if reject_objtype($ctx, $st, 'ALTER', $objtype); + $rest =~ s/\A\s*(?:IF\s+EXISTS\s+)?(?:ONLY\s+)?//i; + + my $kind = kind_of($objtype); + my $name; + my $arity; + if ($kind eq 'function' || $kind eq 'aggregate') { + $name = take_name(\$rest); + $arity = arity_of_args(take_paren_group(\$rest)); + } + else { + $name = take_name(\$rest); + } + return err($ctx, $st, "unparsable ALTER $objtype") unless defined $name; + my $self = defined $arity ? "$kind:$name/$arity" : "$kind:$name"; + + if ($objtype eq 'TYPE' && $rest =~ /\A\s*ADD\s+VALUE\b/i) { + # The only way an update script can add an enum value, versus the + # install script's CREATE TYPE ... AS ENUM(...). Both must normalize to + # the same enumval key or enum coverage means nothing. + $rest =~ s/\A\s*ADD\s+VALUE\s+(?:IF\s+NOT\s+EXISTS\s+)?//i; + my ($label) = enum_labels("($rest)"); + return err($ctx, $st, 'unparsable ALTER TYPE ... ADD VALUE') + unless defined $label; + add_key($ctx, "enumval:$name:$label"); + return; + } + if ($objtype eq 'TYPE' && $rest =~ /\A\s*RENAME\s+VALUE\b/i) { + my @l = enum_labels("($rest)"); + return err($ctx, $st, 'unparsable ALTER TYPE ... RENAME VALUE') unless @l == 2; + del_key($ctx, "enumval:$name:$l[0]"); + add_key($ctx, "enumval:$name:$l[1]"); + return; + } + # ADD COLUMN takes IF NOT EXISTS, DROP COLUMN takes IF EXISTS, and either + # unstripped would be captured as the column's own name. + my $if_exists = qr/(?:IF\s+(?:NOT\s+)?EXISTS\s+)?/i; + + if ($rest =~ /\A\s*(ADD|DROP)\s+ATTRIBUTE\s+$if_exists($IDENT)/i) { + key_op($ctx, $1, "attr:$name." . norm_name($2)); + return; + } + # Ahead of the column branch below, whose COLUMN keyword is optional and + # would otherwise swallow the word CONSTRAINT as a column name. + if ($rest =~ /\A\s*(ADD|DROP)\s+CONSTRAINT\s+$if_exists($IDENT)/i) { + key_op($ctx, $1, "constraint:$name." . norm_name($2)); + return; + } + if ($rest =~ /\A\s*(ADD|DROP)\s+(?:COLUMN\s+)?$if_exists($IDENT)/i + && $objtype eq 'TABLE') + { + key_op($ctx, $1, "attr:$name." . norm_name($2)); + return; + } + if ($rest =~ /\A\s*ALTER\s+(?:COLUMN\s+)?(?!CONSTRAINT\b)($IDENT)/i && $objtype eq 'TABLE') { + touch_key($ctx, "attr:$name." . norm_name($1)); + return; + } + if ($rest =~ /\A\s*RENAME\s+TO\s+($QNAME)/i) { + my $new = norm_name($1); + # RENAME takes an unqualified new name; keep the original schema. + my $sch = schema_of($name); + $new = "$sch.$new" if defined $sch && $new !~ /\./; + del_key($ctx, $self); + add_key($ctx, defined $arity ? "$kind:$new/$arity" : "$kind:$new"); + return; + } + if ($rest =~ /\A\s*(?:OWNER\s+TO|SET\s+SCHEMA)\b/i) { + touch_key($ctx, $self); + return; + } + return err($ctx, $st, "unrecognized ALTER $objtype"); +} + +# --- DROP ------------------------------------------------------------------ + +# Read one object reference of type $objtype from $$ref and return its key. +sub member_key { + my ($objtype, $ref) = @_; + my $kind = kind_of($objtype); + if ($objtype eq 'CAST') { + my $group = take_paren_group($ref); + return undef unless defined $group && $group =~ /\A\s*($QNAME)\s+AS\s+($QNAME)\s*\z/i; + return 'cast:' . norm_name($1) . '=>' . norm_name($2); + } + my $name = take_name($ref); + return undef unless defined $name; + if ($kind eq 'function' || $kind eq 'aggregate') { + my $group = take_paren_group($ref); + # PostgreSQL accepts a bare routine name only where it is unambiguous, + # and then means whichever arity exists. `/*` carries that "any arity" + # sense through to cancellation and coverage; a form that needs a real + # signature rejects it instead of pretending the arity is zero. + return "$kind:$name/" . (defined $group ? arity_of_args($group) : '*'); + } + return "$kind:$name"; +} + +# The non-blank pieces of a comma-separated object list. An empty result is a +# handler's cue to fail: a DDL-shaped fragment assembled at run time -- +# `'GRANT USAGE ON SCHEMA ' || quote_ident(s)` -- parses as a statement whose +# object list is entirely gone, and a handler that just loops over the pieces +# records nothing and returns clean. +sub object_list { + my ($s) = @_; + return grep { /\S/ } split_top_commas($s); +} + +# True if $key names any arity of a routine rather than one signature. +sub is_wildcard_key { my ($k) = @_; return $k =~ m{/\*\z} } + +# Every key in %$set that $key names, expanding an "any arity" wildcard on +# either side. Exact match is the common case and stays a single hash lookup. +sub matching_keys { + my ($set, $key) = @_; + return ($key) if $set->{$key}; + if (is_wildcard_key($key)) { + my ($stem) = $key =~ m{\A(.*)/\*\z}; + return grep { m{\A\Q$stem\E/\d+\z} } keys %$set; + } + my ($stem) = $key =~ m{\A(.*)/\d+\z}; + return () unless defined $stem; + return $set->{"$stem/*"} ? ("$stem/*") : (); +} + +sub handle_drop { + my ($ctx, $st) = @_; + my $rest = $st->{text}; + return err($ctx, $st, 'DROP OWNED is not allowed in an extension script') + if $rest =~ /\ADROP\s+OWNED\b/i; + $rest =~ s/\ADROP\s+//i; + + my $objtype = take_objtype(\$rest); + return err($ctx, $st, 'unrecognized DROP') unless defined $objtype; + return if reject_objtype($ctx, $st, 'DROP', $objtype); + + $rest =~ s/\A\s*CONCURRENTLY\s*//i; + $rest =~ s/\A\s*IF\s+EXISTS\s*//i; + my $cascade = $rest =~ s/\s*\bCASCADE\s*\z//i ? 1 : 0; + $rest =~ s/\s*\bRESTRICT\s*\z//i; + + # Set difference over parsed DROP keys, not a regex over the text: the + # multi-line `DROP FUNCTION name(\n arg\n , arg\n)` form used throughout + # this repo defeats any line-oriented match. + my @pieces = object_list($rest); + return err($ctx, $st, "DROP $objtype names no object") unless @pieces; + for my $piece (@pieces) { + my $p = $piece; + my $key = member_key($objtype, \$p); + return err($ctx, $st, "unparsable DROP $objtype") unless defined $key; + del_key($ctx, $key, $cascade); + } + return; +} + +# --- GRANT / REVOKE -------------------------------------------------------- + +my @ACL_OBJ_TYPES = ( + 'ALL TABLES IN SCHEMA', 'ALL SEQUENCES IN SCHEMA', 'ALL FUNCTIONS IN SCHEMA', + 'ALL PROCEDURES IN SCHEMA', 'ALL ROUTINES IN SCHEMA', + 'FOREIGN DATA WRAPPER', 'FOREIGN SERVER', 'LARGE OBJECT', + 'TABLE', 'SEQUENCE', 'DATABASE', 'DOMAIN', 'FUNCTION', 'PROCEDURE', + 'ROUTINE', 'LANGUAGE', 'PARAMETER', 'SCHEMA', 'TABLESPACE', 'TYPE', +); + +# GRANT and REVOKE are treated symmetrically: both are recorded as "this +# object's ACL is touched here". A presence key, not a privilege model -- the +# question this check answers is whether the update script did anything at all +# about an object whose ACL differs between the two installs. +sub handle_acl { + my ($ctx, $st) = @_; + my $t = $st->{text}; + my (undef, $masked, $depth) = scan($t); + + my $on = kw_pos($masked, $depth, qr/\bON\b/i, 0); + if (!defined $on) { + # GRANT role TO role / REVOKE role FROM role: role membership. + my $sep = kw_pos($masked, $depth, qr/\b(?:TO|FROM)\b/i, 0); + return err($ctx, $st, 'unparsable GRANT/REVOKE') unless defined $sep; + my $roles = substr($t, 0, $sep); + $roles =~ s/\A\s*(?:GRANT|REVOKE)\s+//i; + my $grantees = substr($t, $sep); + $grantees =~ s/\A\s*(?:TO|FROM)\s+//i; + $grantees =~ s/\s*\bWITH\b.*\z//is; + my @roles = object_list($roles); + my @grantees = object_list($grantees); + return err($ctx, $st, 'GRANT/REVOKE names no role') + unless @roles && @grantees; + for my $r (@roles) { + for my $g (@grantees) { + add_key($ctx, 'rolegrant:' . norm_name($r) . ':' . norm_name($g)); + } + } + return; + } + + my $rest = substr($t, $on); + $rest =~ s/\A\s*ON\s+//i; + my $objtype = 'TABLE'; + for my $ot (@ACL_OBJ_TYPES) { + my $re = phrase_re($ot); + if ($rest =~ s/\A$re\b//i) { $objtype = $ot; last } + } + + my @pieces = object_list(strip_grantees($rest)); + return err($ctx, $st, "GRANT/REVOKE ON $objtype names no object") unless @pieces; + + if ($objtype =~ /\AALL\s+(\w+)\s+IN\s+SCHEMA\z/i) { + my $what = lc $1; + add_key($ctx, "acl:all_$what:" . norm_name($_)) for @pieces; + return; + } + + my $kind = kind_of($objtype); + for my $piece (@pieces) { + my $p = $piece; + my $name = take_name(\$p); + return err($ctx, $st, 'unparsable GRANT/REVOKE object') unless defined $name; + if ($kind eq 'function' || $kind eq 'aggregate') { + my $group = take_paren_group(\$p); + # See member_key on what `/*` means; an ACL key without an arity at + # all could never meet the `/` key a CREATE produces. + $name .= '/' . (defined $group ? arity_of_args($group) : '*'); + } + add_key($ctx, "acl:$kind:$name"); + } + return; +} + +sub strip_grantees { + my ($s) = @_; + my (undef, $masked, $depth) = scan($s); + my $p = kw_pos($masked, $depth, qr/\b(?:TO|FROM)\b/i, 0); + return defined $p ? substr($s, 0, $p) : $s; +} + +# Offset of the first match of $re in $masked at nesting depth $want. Searching +# the masked copy is what keeps a TO/FROM/IS inside a string literal or comment +# from being mistaken for the real clause separator. +sub kw_pos { + my ($masked, $depth, $re, $want) = @_; + while ($masked =~ /$re/g) { + my $p = $-[0]; + return $p if $depth->[$p] == $want; + } + return undef; +} + +# --- COMMENT / SECURITY LABEL ---------------------------------------------- + +sub handle_comment { return handle_annotation(@_, 'comment', qr/\ACOMMENT\s+ON\s+/i) } + +sub handle_seclabel { + my ($ctx, $st) = @_; + return handle_annotation($ctx, $st, 'seclabel', + qr/\ASECURITY\s+LABEL\s+(?:FOR\s+$IDENT\s+)?ON\s+/i); +} + +sub handle_annotation { + my ($ctx, $st, $prefix, $head) = @_; + my $rest = $st->{text}; + return err($ctx, $st, "unparsable \U$prefix") unless $rest =~ s/$head//; + my $objtype = take_objtype(\$rest); + return err($ctx, $st, "unrecognized \U$prefix\E target") unless defined $objtype; + return if reject_objtype($ctx, $st, "\U$prefix\E ON", $objtype); + + my (undef, $masked, $depth) = scan($rest); + my $is = kw_pos($masked, $depth, qr/\bIS\b/i, 0); + $rest = substr($rest, 0, $is) if defined $is; + + my $kind = kind_of($objtype); + my $p = $rest; + my $key = member_key($objtype, \$p); + return err($ctx, $st, "unparsable \U$prefix") unless defined $key; + return err($ctx, $st, "\U$prefix\E ON $objtype needs an argument list") + if is_wildcard_key($key); + $key =~ s/\A[^:]+://; + add_key($ctx, "$prefix:$kind:$key"); + return; +} + +# --- Data statements ------------------------------------------------------- + +# Advisory only. bin/structural_diff compares structure, never table CONTENTS, +# so a seeded table is invisible to the runtime check as well; recording which +# tables an install script writes lets the report point out that the update +# script writes none of them. +sub handle_data { + my ($ctx, $st) = @_; + my $t = $st->{text}; + my $rest = $t; + $rest =~ s/\A(?:INSERT\s+INTO|DELETE\s+FROM|MERGE\s+INTO|UPDATE|TRUNCATE(?:\s+TABLE)?|COPY)\s+//i + or return err($ctx, $st, 'unparsable data statement'); + $rest =~ s/\A\s*ONLY\s+//i; + my $name = take_name(\$rest); + return err($ctx, $st, 'unparsable data statement') unless defined $name; + my $norm = $t; + $norm =~ s/\s+/ /g; + $ctx->{data}{"data:$name"} .= "$norm\n"; + add_key($ctx, "data:$name"); + return; +} + +# --- Dynamic SQL gateways -------------------------------------------------- +# +# A dollar-quoted string is DDL only when it is reached through one of exactly +# three constructs. Blanket-skipping dollar quotes would lose the views and the +# role this extension builds dynamically; blanket-scanning them would invent +# phantom objects out of the format() templates stored in function bodies. The +# discriminator is the construct, not the content. + +sub handle_select { + my ($ctx, $st) = @_; + my $t = $st->{text}; + + if ($t =~ /\ASELECT\s+(?:__cat_tools|pg_temp)\s*\.\s*create_function\s*(?=\()/i) { + my $rest = $t; + $rest =~ s/\ASELECT\s+(?:__cat_tools|pg_temp)\s*\.\s*create_function\s*//i; + my $group = take_paren_group(\$rest); + return err($ctx, $st, 'unparsable create_function() call') unless defined $group; + return gateway_create_function($ctx, $st, $group); + } + if ($t =~ /\ASELECT\s+(?:__cat_tools|pg_temp)\s*\.\s*exec\s*(?=\()/i) { + return err($ctx, $st, 'exec() payload does not resolve to any DDL') + unless gateway_literals($ctx, $st->{offset}, $t); + return; + } + # Every top-level SELECT in this extension is one of the two helpers above. + # Rejecting the rest also catches SELECT ... INTO, which silently creates a + # table. + return err($ctx, $st, 'unrecognized top-level SELECT'); +} + +# The helper's arguments are positional, so the object it will create is read +# off them directly. Argument 3 is the new function's BODY: data, never scanned +# -- that is where the format() templates live. +# +# The count is bounded on both sides because everything below is positional: a +# call with the wrong number of arguments does not fail here, it silently reads +# the wrong argument as the name, the signature or the comment. +sub gateway_create_function { + my ($ctx, $st, $group) = @_; + my @args = split_top_commas($group); + return err($ctx, $st, 'create_function() takes 4 to 6 arguments') + if @args < 4 || @args > 6; + + my $name = literal_value($args[0]); + my $args_txt = literal_value($args[1]); + return err($ctx, $st, 'create_function() name is not a literal') unless defined $name; + return err($ctx, $st, 'create_function() argument list is not a literal') + unless defined $args_txt; + + $name = norm_name($name); + my $sig = "$name/" . arity_of_args($args_txt); + add_key($ctx, "function:$sig"); + # The helper always emits REVOKE ALL ... FROM public, and a GRANT EXECUTE + # when argument 5 is non-NULL; either way the function's ACL is set here. + add_key($ctx, "acl:function:$sig"); + add_key($ctx, "comment:function:$sig") + if defined $args[5] && $args[5] =~ /\S/ && $args[5] !~ /\A\s*NULL\s*\z/i; + return; +} + +# Whether a resolved payload is DDL, decided on the COMMENT-STRIPPED text: a +# template that opens with an explanatory `--` or `/* */` is still DDL, and +# reading the raw text would drop the whole statement on the floor. +sub is_ddl_text { + my ($s) = @_; + my ($code) = scan($s); + return $code =~ /\A\s*(?:CREATE|ALTER|DROP|GRANT|REVOKE|COMMENT|SECURITY\s+LABEL)\b/i; +} + +# Offset ranges covering every format() argument after the first. Only that +# first argument is a template; the rest are VALUES substituted into it, and a +# value that happens to open with a DDL keyword ('DROP TABLE s.t' passed for a +# %s) is data, not a statement -- parsing it would cancel a real object. +sub format_value_ranges { + my ($t) = @_; + my (undef, $masked, $depth) = scan($t); + my $n = length $t; + my @out; + while ($masked =~ /\bformat\s*\(/gi) { + my $open = $+[0] - 1; + my $d = $depth->[$open]; + # scan() gives a '(' and its matching ')' the same depth, so the first + # ')' at $d after $open closes this call. + my ($close, $comma); + for (my $i = $open + 1 ; $i < $n ; $i++) { + my $c = substr($masked, $i, 1); + if ($c eq ')' && $depth->[$i] == $d) { $close = $i; last } + $comma = $i if $c eq ',' && $depth->[$i] == $d + 1 && !defined $comma; + } + push @out, [ $comma + 1, $close ] if defined $close && defined $comma; + } + return @out; +} + +# Parse every string literal in $t that resolves to DDL, and return how many +# there were. A caller that reached here through a gateway construct treats +# zero as an error: whatever that gateway executes at run time, this did not +# read it, and an unread gateway is exactly the blind spot to avoid. +sub gateway_literals { + my ($ctx, $base, $t) = @_; + my ($code, undef, undef, $lits) = scan($t); + my @values = format_value_ranges($t); + my $found = 0; + for my $l (@$lits) { + next if grep { $l->[0] >= $_->[0] && $l->[0] < $_->[1] } @values; + my $v = substr($code, $l->[0], $l->[1] - $l->[0]); + $v =~ s/''/'/g if $l->[2] eq "'"; + next unless is_ddl_text($v); + process_sql($ctx, $v, $base + $l->[0]); + $found++; + } + return $found; +} + +# --- DO blocks ------------------------------------------------------------- +# +# A DO block is a gateway too, so its body is parsed rather than skipped, and a +# form the parse does not understand is an error: the statement it declined to +# read could be the one creating an object. +# +# The body is split into statements exactly as top-level text is, then each +# statement has its leading control constructs peeled off. BEGIN, IF ... THEN +# and their relatives are PREFIXES of the statement they guard rather than +# statements of their own, so the DDL that follows one shares its statement -- +# which is why the peel is needed and why keying off line starts is not enough. +# What survives the peel is either a plpgsql statement with no catalog effect, +# or a statement handed to the same process_stmt() as top-level text. + +# Peeled off the front of a statement until none matches, appending everything +# taken to $$seen so the caller can vet it. Returns false if a construct is +# opened but its terminator (THEN, LOOP) is missing, which means the peel would +# otherwise consume the statement it was looking for. +sub peel_plpgsql_control { + my ($ref, $seen) = @_; + while (1) { + $$ref =~ s/\A\s+//; + if ($$ref =~ s/\A(BEGIN|ELSE|LOOP)\b//i) { $$seen .= $1; next } + my $terminator = + $$ref =~ /\A(?:IF|ELSIF|ELSEIF|CASE|WHEN|EXCEPTION\s+WHEN)\b/i ? 'THEN' + : $$ref =~ /\A(?:WHILE|FOR|FOREACH)\b/i ? 'LOOP' + : undef; + return 1 unless defined $terminator; + my (undef, $masked, $depth) = scan($$ref); + my $p = kw_pos($masked, $depth, qr/\b\Q$terminator\E\b/i, 0); + return 0 unless defined $p; + my $take = $p + length $terminator; + $$seen .= substr($$ref, 0, $take); + $$ref = substr($$ref, $take); + } +} + +# A control header is an expression, not a statement, so it may not carry DDL +# or reach a dynamic-SQL gateway. Matched against the header's MASKED text -- +# a DDL keyword inside a string literal there is a value, and the gateway that +# would execute it is the thing worth finding. +my $HEADER_HAZARD = qr/ + \b(?:CREATE|ALTER|DROP|GRANT|REVOKE|EXECUTE|PERFORM)\b + | \bCOMMENT\s+ON\b | \bSECURITY\s+LABEL\b + | \b(?:__cat_tools|pg_temp)\s*\.\s*(?:exec|create_function)\b +/xi; + +# plpgsql statements that cannot reach the catalog. EXECUTE and PERFORM are +# deliberately absent: both run something this script has to look inside. +my $INERT_PLPGSQL = qr/\A(?:END|NULL|RETURN|RAISE|ASSERT|CONTINUE|EXIT|GET)\b/i; + +sub handle_do { + my ($ctx, $st) = @_; + my $t = $st->{text}; + my ($code, undef, undef, $lits) = scan($t); + return err($ctx, $st, 'unparsable DO block') unless @$lits; + my ($cs, $ce) = @{ $lits->[0] }; + my $body = substr($code, $cs, $ce - $cs); + my $base = $st->{offset} + $cs; + + # A top-level DECLARE section runs to the block's BEGIN. Its contents are + # variable declarations, which no amount of them can turn into an object, + # and they are `;`-separated, so they are cut out ahead of the split rather + # than left to fail statement by statement. A DECLARE on a NESTED block is + # not recognized and reports itself as unhandled. + if ($body =~ /\A\s*DECLARE\b/i) { + my (undef, $masked, $depth) = scan($body); + my $p = kw_pos($masked, $depth, qr/\bBEGIN\b/i, 0); + return err($ctx, $st, 'DECLARE section with no BEGIN') unless defined $p; + $body = (' ' x $p) . substr($body, $p); + } + + for my $chunk (@{ checked_stmts($ctx, $body, $base) }) { + do_stmt($ctx, $chunk); + } + return; +} + +sub do_stmt { + my ($ctx, $st) = @_; + my $text = $st->{text}; + my $header = ''; + return err($ctx, $st, 'unterminated plpgsql control construct') + unless peel_plpgsql_control(\$text, \$header); + my (undef, $header_masked) = scan($header); + return err($ctx, $st, 'plpgsql control header carries DDL or a dynamic-SQL gateway') + if $header_masked =~ /$HEADER_HAZARD/; + return unless $text =~ /\S/; + + # The peel only removes a prefix, so the length it took off is how far the + # reported line has to move to land on the guarded statement rather than on + # the IF or BEGIN in front of it. + $st = { text => $text, + offset => $st->{offset} + length($st->{text}) - length($text) }; + + return if $text =~ /$INERT_PLPGSQL/; + + # EXECUTE and PERFORM both run something built elsewhere. PERFORM is a + # SELECT with its result thrown away, so it gets the SELECT rules -- + # including the refusal to guess at a function call that is not a known + # gateway. + if ($text =~ /\AEXECUTE\b/i) { + return err($ctx, $st, 'EXECUTE payload does not resolve to any DDL') + unless gateway_literals($ctx, $st->{offset}, $text); + return; + } + if ($text =~ s/\APERFORM\b/SELECT/i) { + return handle_select($ctx, { %$st, text => $text }); + } + return process_stmt($ctx, $st); +} + +# --------------------------------------------------------------------------- +# File handling +# --------------------------------------------------------------------------- + +# sql.mk rewrites the bare @generated@ marker into a -- comment on its way to +# the generated .sql; doing the identical substitution here is what makes the +# marker inert without special-casing it in the scanner. +# +# +# The version-conditional `-- SED: REQUIRES N!` / `-- SED: PRIOR TO N!` markers +# get the same treatment, resolved as sql.mk resolves them for the newest +# PostgreSQL: the REQUIRES branch is left alone and the PRIOR TO branch becomes +# a comment. See the header's LIMITATIONS for why that branch and what it costs. +sub preprocess { + my ($text) = @_; + $text =~ s/\@generated\@/-- GENERATED FILE! DO NOT EDIT!/g; + $text =~ s/^(.*)-- SED: PRIOR TO ([^!\n]*)!/-- Not used prior to $2: $1/gm; + return $text; +} + +sub read_file { + my ($path) = @_; + open my $fh, '<', $path + or usage_error("cannot read $path: $!"); + # A directory opens and then reads as the empty string, so a mistyped path + # would otherwise come out as a clean run over no objects at all. This + # cannot be a plain -f test: /dev/null is a documented argument. + usage_error("$path is not a plain file") unless -f $fh || -c $fh; + local $/; + my $t = <$fh>; + close $fh; + return defined $t ? $t : ''; +} + +# Object keys $key hangs off. Dropping an object takes its enum labels, ACL, +# comment, columns and constraints with it -- otherwise a file that created and +# then dropped a type is left claiming an ACL on something that never survived. +# +# Ownership is read off the key shapes; there is no separate dependency graph. +# Where a key shape is ambiguous (a constraint hangs off a table OR a domain) +# both candidates are returned: at most one of them is ever a real key. +sub owner_keys { + my ($key) = @_; + my $kind = key_kind($key); + my $id = key_identity($key); + my @owners; + + if ($kind =~ /\A(?:acl|comment|seclabel)\z/) { + push @owners, $id if $id =~ /\A[a-z_]+:/; + } + elsif ($kind eq 'enumval') { + push @owners, "type:$1" if $id =~ /\A(.*):[^:]*\z/s; + } + elsif ($kind eq 'constraint' || $kind eq 'attr') { + push @owners, "relation:$1", "type:$1" if $id =~ /\A(.*)\.[^.]+\z/; + } + elsif ($kind eq 'data') { push @owners, "relation:$id" } + elsif ($kind eq 'cast') { push @owners, map { "type:$_" } split /=>/, $id, 2 } + elsif ($kind eq 'rolegrant') { push @owners, map { "role:$_" } split /:/, $id, 2 } + + # A schema owns everything in it. Only reached for a CASCADE drop, which is + # the only DROP SCHEMA that can run against a non-empty schema at all. + my $obj = @owners && $owners[0] =~ /\A[a-z_]+:/ ? key_identity($owners[0]) : $id; + push @owners, "schema:$1" if $kind ne 'schema' && $obj =~ /\A([^.:]+)\./; + + return @owners; +} + +sub parse_file { + my ($path, $seed_adp) = @_; + my $src = preprocess(read_file($path)); + my $ctx = new_ctx(path => $path, seed_adp => $seed_adp); + + # Line numbers are resolved from the offset each statement carries, using + # one precomputed index of newline positions. + my @nl; + my $p = -1; + push @nl, $p while ($p = index($src, "\n", $p + 1)) >= 0; + $ctx->{line_of} = sub { + my ($off) = @_; + my ($lo, $hi) = (0, scalar @nl); + while ($lo < $hi) { + my $mid = int(($lo + $hi) / 2); + $nl[$mid] < $off ? ($lo = $mid + 1) : ($hi = $mid); + } + return $lo + 1; + }; + + process_sql($ctx, $src, 0); + + # Scaffolding cancellation: an object created and then dropped inside the + # same file never existed as far as a later version is concerned. This is + # what removes the __cat_tools helper schema and its functions without a + # hardcoded name list -- and it only works because a DROP derives a + # byte-identical key to its CREATE. + # + # ORDER decides it, which is why the keys carry sequence numbers: the same + # pair of statements is scaffolding one way round and an idempotent rebuild + # (`DROP VIEW IF EXISTS v; CREATE VIEW v ...`) the other, and cancelling a + # rebuilt object would lose it from the diff entirely. + # + # %removed_at holds the last time each key was destroyed. A key whose most + # recent CREATE is later than that survives. A DROP of something this file + # never created still gets an entry, because whatever hangs off it was + # destroyed too. + my %removed_at; + my $remove_at = sub { + my ($k, $t) = @_; + return if defined $removed_at{$k} && $removed_at{$k} >= $t; + $removed_at{$k} = $t; + return 1; + }; + for my $d (keys %{ $ctx->{dropped} }) { + my $t = $ctx->{dropped}{$d}; + $remove_at->($_, $t) for matching_keys($ctx->{created}, $d), $d; + } + + # Dependents go down with their owner (see owner_keys), but only those that + # existed when it was dropped. This runs to a fixed point rather than in one + # pass: an enum label is reached through its type, which may itself be + # reached through its schema. + my $reached = 1; + while ($reached) { + $reached = 0; + for my $k (keys %{ $ctx->{created} }) { + for my $o (owner_keys($k)) { + my $t = $removed_at{$o}; + next unless defined $t && $t > $ctx->{created}{$k}; + next if key_kind($o) eq 'schema' && !$ctx->{cascade}{$o}; + $reached = 1 if $remove_at->($k, $t); + } + } + } + + my %objects = map { $_ => 1 } + grep { !defined $removed_at{$_} || $ctx->{created}{$_} > $removed_at{$_} } + keys %{ $ctx->{created} }; + $ctx->{objects} = \%objects; + return $ctx; +} + +# --------------------------------------------------------------------------- +# Reporting +# --------------------------------------------------------------------------- + +sub key_kind { my ($k) = @_; my ($a) = $k =~ /\A([^:]+):/; return $a } +sub key_identity { my ($k) = @_; my ($a) = $k =~ /\A[^:]+:(.*)\z/s; return $a } + +sub usage { + print STDERR <<"END"; +usage: $PROG [OPTIONS] + $PROG OLD_INSTALL NEW_INSTALL UPDATE_SCRIPT + $PROG --versions OLD NEW + $PROG --list-objects FILE + + With no arguments, lints the highest tracked released install snapshot + against the current source, using the update script between them. + + --sql-dir DIR directory holding the versioned SQL (default: sql) + --ext NAME extension name (default: cat_tools) + -h, --help this message + + Exit: 0 clean, 1 gaps found, 2 usage error, 3 unanalyzable input. +END + exit 2; +} + +sub usage_error { + my ($msg) = @_; + print STDERR "$PROG: $msg\n"; + exit 2; +} + +# --------------------------------------------------------------------------- +# Path and version resolution +# --------------------------------------------------------------------------- + +# Prefer the tracked .sql.in source; fall back to a plain .sql, which is how +# pre-0.2.0 versions are tracked. +sub resolve_stem { + my ($stem) = @_; + return "$stem.sql.in" if -e "$stem.sql.in"; + return "$stem.sql" if -e "$stem.sql"; + return undef; +} + +sub vercmp { + my ($a, $b) = @_; + my @a = split /\./, $a; + my @b = split /\./, $b; + while (@a || @b) { + my $x = shift(@a); + my $y = shift(@b); + $x = 0 unless defined $x; + $y = 0 unless defined $y; + my $c = ($x =~ /\A\d+\z/ && $y =~ /\A\d+\z/) ? $x <=> $y : $x cmp $y; + return $c if $c; + } + return 0; +} + +# default_version out of the .control file. Mirrors the tolerant parse in +# pgxntool/control.mk.sh: strip a trailing # comment, then the quotes. +sub control_default_version { + my ($path) = @_; + open my $fh, '<', $path + or usage_error("cannot read $path (default mode must run from the extension root)"); + my $v; + while (my $l = <$fh>) { + chomp $l; + next unless $l =~ /\A\s*default_version\s*=\s*(.*)\z/; + my $raw = $1; + $raw =~ s/#.*\z//; + $raw =~ s/\A\s+//; + $raw =~ s/\s+\z//; + $raw =~ s/\A'(.*)'\z/$1/ or $raw =~ s/\A"(.*)"\z/$1/; + $v = $raw; + last; + } + close $fh; + usage_error("no default_version in $path") unless defined $v && length $v; + return $v; +} + +# Highest tracked install snapshot under $dir, excluding the pseudo-version +# named by the control file's default_version (it is regenerated, not tracked). +sub highest_released { + my ($dir, $ext, $exclude) = @_; + opendir my $dh, $dir or usage_error("cannot read directory $dir: $!"); + my %seen; + for my $f (readdir $dh) { + # The version pattern admits a single dash but never two, which is what + # keeps ---- update scripts out. + next unless $f =~ /\A\Q$ext\E--([^-]+(?:-[^-]+)*)\.sql(?:\.in)?\z/; + my $v = $1; + next if $v eq $exclude; + $seen{$v} = 1; + } + closedir $dh; + my @v = sort { vercmp($a, $b) } keys %seen; + usage_error("no released install script found in $dir") unless @v; + return $v[-1]; +} + +# --------------------------------------------------------------------------- +# Main +# --------------------------------------------------------------------------- + +my $sql_dir = 'sql'; +my $ext = 'cat_tools'; +my $mode_versions; +my $list_objects; +my @positional; + +while (@ARGV) { + my $a = shift @ARGV; + if ($a eq '-h' || $a eq '--help') { usage() } + elsif ($a eq '--sql-dir') { $sql_dir = shift @ARGV // usage_error('--sql-dir needs a value') } + elsif ($a eq '--ext') { $ext = shift @ARGV // usage_error('--ext needs a value') } + elsif ($a eq '--versions') { + my $old = shift @ARGV; + my $new = shift @ARGV; + usage_error('--versions needs OLD and NEW') unless defined $old && defined $new; + $mode_versions = [ $old, $new ]; + } + elsif ($a eq '--list-objects') { + $list_objects = shift @ARGV // usage_error('--list-objects needs a FILE'); + } + elsif ($a =~ /\A-/) { usage_error("unknown option $a") } + else { push @positional, $a } +} + +if (defined $list_objects) { + usage_error('--list-objects takes no other arguments') + if @positional || $mode_versions; + my $ctx = parse_file($list_objects, {}); + report_errors($ctx) if @{ $ctx->{errors} }; + for my $k (sort keys %{ $ctx->{objects} }) { + print key_kind($k), "\t", key_identity($k), "\n"; + } + exit 0; +} + +usage_error('--versions and explicit file arguments are mutually exclusive') + if $mode_versions && @positional; +usage() if @positional && @positional != 3; + +my ($old_path, $new_path, $upd_path, $label); + +if (@positional == 3) { + ($old_path, $new_path, $upd_path) = @positional; + for my $p ($old_path, $new_path, $upd_path) { + usage_error("cannot read $p") unless -e $p; + } +} +else { + my ($old_v, $new_v); + if ($mode_versions) { + ($old_v, $new_v) = @$mode_versions; + $old_path = resolve_stem("$sql_dir/$ext--$old_v") + or usage_error("no install script for $ext $old_v under $sql_dir"); + $new_path = resolve_stem("$sql_dir/$ext--$new_v") + or usage_error("no install script for $ext $new_v under $sql_dir"); + } + else { + my $default_version = control_default_version("$ext.control"); + $old_v = highest_released($sql_dir, $ext, $default_version); + $new_v = $default_version; + $old_path = resolve_stem("$sql_dir/$ext--$old_v") + or usage_error("no install script for $ext $old_v under $sql_dir"); + # The current version's source, NOT sql/--.sql.in: + # that one is generated and gitignored, so it is absent before `make`. + # Resolved the same way as a versioned stem, because an extension with + # no .sql.in preprocessing step keeps its source in sql/.sql. + $new_path = resolve_stem("$sql_dir/$ext") + or usage_error("no current source $sql_dir/$ext.sql.in or $sql_dir/$ext.sql"); + } + $upd_path = resolve_stem("$sql_dir/$ext--$old_v--$new_v"); + if (!defined $upd_path) { + # Treated as empty rather than skipped: skipping would report success + # on precisely the omission this check exists to catch. + print "note: no update script $sql_dir/$ext--$old_v--$new_v.sql.in; treating it as empty\n"; + $upd_path = '/dev/null'; + } + $label = "$ext $old_v -> $new_v"; +} + +my $old = parse_file($old_path, {}); +my $new = parse_file($new_path, {}); +# The old database already ran the old install's ALTER DEFAULT PRIVILEGES, so +# its effect is still in force while the update script runs. Without seeding, +# every type the update script creates looks as though it never got its grant. +my $upd = parse_file($upd_path, $old->{adp}); + +report_errors($old, $new, $upd); + +sub report_errors { + my @ctxs = @_; + my @all = map { @{ $_->{errors} } } @ctxs; + return unless @all; + print STDERR "$_\n" for @all; + print STDERR "FAIL: " + . scalar(@all) + . " statement(s) could not be analyzed; update_lint cannot vouch for this pair\n"; + exit 3; +} + +# Data statements are advisory (see handle_data), so they are held out of the +# gating diff. +sub gating { + my ($ctx) = @_; + return { map { $_ => 1 } grep { !/\Adata:/ } keys %{ $ctx->{objects} } }; +} + +my $old_g = gating($old); +my $new_g = gating($new); + +my @added = sort grep { !$old_g->{$_} } keys %$new_g; +my @removed = sort grep { !$new_g->{$_} } keys %$old_g; + +# Coverage is exact set membership over keys parsed out of the update script, +# never a substring search over its text. `cat_tools.column` is a substring of +# `_cat_tools.column`, and enum labels like 'in' or 'v' match almost anything. +# +# Note that extraction and coverage need OPPOSITE treatment of string literals: +# an object's name lives INSIDE a literal when it is created through +# create_function(), yet a name that appears only in a comment must not count. +# Parsing the update script into the same keys is what gets both right; a text +# scan cannot. +# +# Key kinds that record an object's EXISTENCE are covered directionally: what +# the new install added must be created and what it removed must be dropped, +# because a DROP is no substitute for a CREATE. The `created`/`dropped` sets +# already carry that distinction, and creation is not limited to CREATE -- an +# added enum label is created by ALTER TYPE ... ADD VALUE and an added column +# by ALTER TABLE ... ADD COLUMN, both of which record a creation. +# +# The kinds below are PRESENCE keys instead, and stay direction-blind. An ACL, +# comment, security label or role membership is recorded identically whichever +# way the update script sets it -- a REVOKE, or a `COMMENT ON ... IS NULL`, is +# how you remove one -- so what is asserted is only that the update script said +# something about it at all. +my %PRESENCE_KIND = map { $_ => 1 } qw(acl comment seclabel rolegrant); + +sub covered { + my ($key, $side) = @_; + my $set = $PRESENCE_KIND{ key_kind($key) } ? $upd->{touched} : $upd->{$side}; + return matching_keys($set, $key) ? 1 : 0; +} + +my @gap_added = grep { !covered($_, 'created') } @added; +my @gap_removed = grep { !covered($_, 'dropped') } @removed; + +print "update_lint: $label\n" if defined $label; +print " old install: $old_path\n"; +print " new install: $new_path\n"; +print " update script: $upd_path\n"; +printf " %d object(s) added, %d removed\n", scalar @added, scalar @removed; + +# Advisory: a table whose seeded contents changed between the two installs, with +# nothing in the update script writing to it. Never gating -- contents are +# outside what either this check or bin/structural_diff compares. +for my $k (sort keys %{ $new->{data} }) { + next if ($old->{data}{$k} || '') eq $new->{data}{$k}; + next if $upd->{data}{$k}; + print "WARNING: $k is populated differently by the two install scripts and the update script does not write to it\n"; +} + +if (@gap_added || @gap_removed) { + print "\nNot handled by the update script:\n"; + print " added, never created: $_\n" for @gap_added; + print " removed, never dropped: $_\n" for @gap_removed; + print STDERR "FAIL: " + . (scalar(@gap_added) + scalar(@gap_removed)) + . " object(s) differ between $old_path and $new_path but are untouched by $upd_path\n"; + print STDERR "hint: add the matching statements to $upd_path; " + . "$PROG --list-objects FILE shows what was extracted from a file.\n"; + exit 1; +} + +printf "OK: %s accounts for all %d added and %d removed object(s)\n", + $upd_path, scalar @added, scalar @removed; +exit 0;