fix: correct DB.pm bugs, add Makefile.PL, implement Mapper API, add tests

DB.pm had multiple fatal issues: __DATA__ SQL was read then mistakenly
treated as a filename (would always die), missing use statements for DBI/
File::Touch/File::Slurper, broken VIEW syntax (parentheses around SELECT
list), test_for_build.build_id used as PRIMARY KEY (capped each build to
one test), missing IF NOT EXISTS on build/route/test tables, and the
to_run view referenced t.test_id (nonexistent) and environment alias 'e'
without declaring AS e.

Also adds: Makefile.PL with correct prereqs, VERSION in Mapper.pm,
working implementation of new/map_test/tests_for_resources, and an 8-test
suite covering the basic lifecycle.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

Makefile.PL

@@ -0,0 +1,29 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME             => 'Test::Mapper',
+    AUTHOR           => 'Troglodyne Internet Widgets',
+    VERSION_FROM     => 'lib/Test/Mapper.pm',
+    ABSTRACT_FROM    => 'lib/Test/Mapper.pm',
+    LICENSE          => 'artistic_2',
+    MIN_PERL_VERSION => '5.010',
+    PREREQ_PM        => {
+        'DBI'           => 0,
+        'DBD::SQLite'   => 0,
+        'File::Touch'   => 0,
+        'File::Slurper' => 0,
+    },
+    TEST_REQUIRES => {
+        'Test::More' => 0,
+        'File::Temp' => 0,
+    },
+    META_MERGE => {
+        'meta-spec' => { version => 2 },
+        resources   => {
+            repository => {
+                type => 'git',
+                url  => 'https://git.troglodyne.net/Troglodyne/Test-Mapper.git',
+            },
+        },
+    },
+);

lib/Test/Mapper.pm

@@ -3,6 +3,8 @@ package Test::Mapper;
 use strict;
 use warnings;
 
+our $VERSION = '0.001';
+
 #ABSTRACT: Map what parts of a codebase changing ought trigger acceptance tests
 
 =head1 DESCRIPTION
@@ -36,4 +38,189 @@ It is well within the realm of possibility to hit these endpoints with L<Playwri
 
 Similarly one can (in most cases) do the same thing with normal applications via C<ldd>, C<strace> and so forth.
 
+=head1 SYNOPSIS
+
+    use Test::Mapper;
+
+    my $mapper = Test::Mapper->new(
+        db          => '/path/to/mapper.db',
+        product     => 'MyApp',
+        environment => 'linux',
+    );
+
+    # Record that a test exercises certain source files
+    $mapper->map_test(
+        test      => 't/acceptance/login.t',
+        resources => [ 'lib/MyApp/Auth.pm', 'lib/MyApp/Session.pm' ],
+    );
+
+    # Given a list of changed files, find which tests need to run
+    my @tests = $mapper->tests_for_resources(
+        resources => [ 'lib/MyApp/Auth.pm' ],
+    );
+
+=head1 METHODS
+
+=head2 new(%args)
+
+Constructor. Required args:
+
+=over 4
+
+=item db
+
+Path to the SQLite database file.
+
+=item product
+
+Product name string. Used to namespace data across products in a shared DB.
+
+=item environment
+
+Environment name (e.g. C<linux>, C<MSWin32>). Tests may exercise different
+resources on different platforms.
+
+=back
+
+=head2 map_test(%args)
+
+Record that C<test> (a test filename) exercises C<resources> (arrayref of
+source filenames). Idempotent — safe to call on every analysis run.
+
+=head2 tests_for_resources(%args)
+
+Given C<resources> (arrayref of changed filenames), return a list of test
+filenames that should be run.
+
 =cut
+
+use Test::Mapper::DB;
+
+sub new {
+    my ( $class, %args ) = @_;
+    die "db is required"          unless $args{db};
+    die "product is required"     unless $args{product};
+    die "environment is required" unless $args{environment};
+
+    my $dbh = Test::Mapper::DB::dbh( $args{db} );
+    my $self = bless {
+        dbh         => $dbh,
+        product     => $args{product},
+        environment => $args{environment},
+        _product_id => undef,
+        _env_id     => undef,
+    }, $class;
+
+    $self->_ensure_product;
+    $self->_ensure_environment;
+
+    return $self;
+}
+
+sub map_test {
+    my ( $self, %args ) = @_;
+    die "test is required"      unless $args{test};
+    die "resources is required" unless $args{resources};
+
+    my $dbh     = $self->{dbh};
+    my $test_id = $self->_ensure_test( $args{test} );
+
+    for my $filename ( @{ $args{resources} } ) {
+        my $resource_id = $self->_ensure_resource($filename);
+        $dbh->do(
+            "INSERT OR IGNORE INTO tested_by (resource_id, test_id) VALUES (?, ?)",
+            undef, $resource_id, $test_id
+        ) or die "Could not map test: " . $dbh->errstr;
+    }
+
+    return;
+}
+
+sub tests_for_resources {
+    my ( $self, %args ) = @_;
+    die "resources is required" unless $args{resources};
+
+    my $dbh = $self->{dbh};
+    my $env_id = $self->{_env_id};
+
+    my $placeholders = join( ",", ("?") x scalar @{ $args{resources} } );
+    my $sth = $dbh->prepare(
+        "SELECT DISTINCT t.filename
+         FROM test AS t
+         JOIN tested_by AS tb ON tb.test_id = t.id
+         JOIN resource AS r ON r.id = tb.resource_id
+         WHERE r.environment_id = ?
+           AND r.filename IN ($placeholders)"
+    ) or die "Could not prepare query: " . $dbh->errstr;
+
+    $sth->execute( $env_id, @{ $args{resources} } )
+        or die "Could not execute query: " . $sth->errstr;
+
+    my @tests;
+    while ( my ($filename) = $sth->fetchrow_array ) {
+        push @tests, $filename;
+    }
+    return @tests;
+}
+
+# ---- private helpers ----
+
+sub _ensure_product {
+    my ($self) = @_;
+    my $dbh = $self->{dbh};
+    $dbh->do(
+        "INSERT OR IGNORE INTO product (product) VALUES (?)",
+        undef, $self->{product}
+    ) or die $dbh->errstr;
+    my ($id) = $dbh->selectrow_array(
+        "SELECT id FROM product WHERE product=?",
+        undef, $self->{product}
+    );
+    $self->{_product_id} = $id;
+    return $id;
+}
+
+sub _ensure_environment {
+    my ($self) = @_;
+    my $dbh = $self->{dbh};
+    $dbh->do(
+        "INSERT OR IGNORE INTO environment (environment, product_id) VALUES (?, ?)",
+        undef, $self->{environment}, $self->{_product_id}
+    ) or die $dbh->errstr;
+    my ($id) = $dbh->selectrow_array(
+        "SELECT id FROM environment WHERE environment=? AND product_id=?",
+        undef, $self->{environment}, $self->{_product_id}
+    );
+    $self->{_env_id} = $id;
+    return $id;
+}
+
+sub _ensure_test {
+    my ( $self, $filename ) = @_;
+    my $dbh = $self->{dbh};
+    $dbh->do(
+        "INSERT OR IGNORE INTO test (filename, product_id) VALUES (?, ?)",
+        undef, $filename, $self->{_product_id}
+    ) or die $dbh->errstr;
+    my ($id) = $dbh->selectrow_array(
+        "SELECT id FROM test WHERE filename=? AND product_id=?",
+        undef, $filename, $self->{_product_id}
+    );
+    return $id;
+}
+
+sub _ensure_resource {
+    my ( $self, $filename ) = @_;
+    my $dbh = $self->{dbh};
+    $dbh->do(
+        "INSERT OR IGNORE INTO resource (environment_id, filename) VALUES (?, ?)",
+        undef, $self->{_env_id}, $filename
+    ) or die $dbh->errstr;
+    my ($id) = $dbh->selectrow_array(
+        "SELECT id FROM resource WHERE environment_id=? AND filename=?",
+        undef, $self->{_env_id}, $filename
+    );
+    return $id;
+}
+
+1;

lib/Test/Mapper/DB.pm

@@ -3,6 +3,10 @@ package Test::Mapper::DB;
 use strict;
 use warnings;
 
+use DBI;
+use File::Touch;
+use File::Slurper qw{read_text};
+
 # ABSTRACT: Persistent storage for what test maps where for what build.
 
 # We hold possibly multiple DBHes to support testing multiple products.
@@ -10,29 +14,27 @@ my $dbh = {};
 
 sub dbh {
     my ( $dbname ) = @_;
-    my $schema = join("\n",(readline(DATA)));
 
-    $dbh //= {};
     return $dbh->{$dbname} if $dbh->{$dbname};
+
     File::Touch::touch($dbname) unless -f $dbname;
     my $db = DBI->connect( "dbi:SQLite:dbname=$dbname", "", "" );
 
+    # Turn on fkeys before schema creation so FK constraints take effect
+    $db->do("PRAGMA foreign_keys = ON") or die "Could not enable foreign keys";
+
+    # Turn on WAL mode for concurrent reads
+    $db->do("PRAGMA journal_mode = WAL") or die "Could not enable WAL mode";
+
+    my $schema = join( "", readline(DATA) );
     if ($schema) {
-        die "No such schema file '$schema' !" unless -f $schema;
-        my $qq = File::Slurper::read_text($schema);
         $db->{sqlite_allow_multiple_statements} = 1;
-        $db->do($qq) or die "Could not ensure database consistency: " . $db->errstr;
+        $db->do($schema) or die "Could not ensure database consistency: " . $db->errstr;
         $db->{sqlite_allow_multiple_statements} = 0;
     }
 
     $dbh->{$dbname} = $db;
 
-    # Turn on fkeys
-    $db->do("PRAGMA foreign_keys = ON") or die "Could not enable foreign keys";
-
-    # Turn on WALmode
-    $db->do("PRAGMA journal_mode = WAL") or die "Could not enable WAL mode";
-
     return $db;
 }
 
@@ -53,21 +55,21 @@ CREATE TABLE IF NOT EXISTS environment (
     UNIQUE(environment, product_id) ON CONFLICT IGNORE
 );
 
-CREATE TABLE build (
+CREATE TABLE IF NOT EXISTS build (
     id INTEGER PRIMARY KEY AUTOINCREMENT,
     build TEXT NOT NULL,
     product_id INTEGER NOT NULL REFERENCES product(id) ON DELETE CASCADE,
     UNIQUE(build, product_id) ON CONFLICT IGNORE
 );
 
-CREATE TABLE route (
+CREATE TABLE IF NOT EXISTS route (
     id INTEGER PRIMARY KEY AUTOINCREMENT,
     route TEXT NOT NULL,
     product_id INTEGER NOT NULL REFERENCES product(id) ON DELETE CASCADE,
     UNIQUE(route, product_id) ON CONFLICT IGNORE
 );
 
-CREATE TABLE test (
+CREATE TABLE IF NOT EXISTS test (
     id INTEGER PRIMARY KEY AUTOINCREMENT,
     filename TEXT NOT NULL,
     product_id INTEGER NOT NULL REFERENCES product(id) ON DELETE CASCADE,
@@ -78,9 +80,10 @@ CREATE TABLE test (
 -- result is a result code that visualization programs can use for historical charts
 -- The idea here is that 'people just wanna see what failed', and this helps narrow that down
 -- start/finish is so you can figure historical data/charts
-CREATE TABLE test_for_build (
-    build_id INTEGER PRIMARY KEY REFERENCES build(id),
-    test_id  INTEGER REFERENCES test(id),
+CREATE TABLE IF NOT EXISTS test_for_build (
+    id       INTEGER PRIMARY KEY AUTOINCREMENT,
+    build_id INTEGER NOT NULL REFERENCES build(id) ON DELETE CASCADE,
+    test_id  INTEGER NOT NULL REFERENCES test(id) ON DELETE CASCADE,
     run_by   TEXT,
     result   INTEGER,
     start    INTEGER NOT NULL DEFAULT CURRENT_TIMESTAMP,
@@ -91,60 +94,60 @@ CREATE TABLE test_for_build (
 -- Actually do the mapping of test -> what files changing trigger its running
 -- One tends to use differing resources on different environments.
 -- It is however assumed that the tests (or the cron inserting resources/tests) discriminates in this regard.
-CREATE TABLE resource (
-    resource_id INTEGER PRIMARY KEY AUTOINCREMENT,
-    environment_id INTEGER NOT NULL REFERENCES environment(id),
-    filename TEXT NOT NULL,
+CREATE TABLE IF NOT EXISTS resource (
+    id             INTEGER PRIMARY KEY AUTOINCREMENT,
+    environment_id INTEGER NOT NULL REFERENCES environment(id) ON DELETE CASCADE,
+    filename       TEXT NOT NULL,
     UNIQUE(environment_id, filename) ON CONFLICT IGNORE
 );
 
 -- Indexed by resource_id, as that's how a build is done "I have x changed resources, wat run?"
-CREATE TABLE tested_by (
-    resource_id INTEGER PRIMARY KEY REFERENCES resource(id),
-    test_id INTEGER NOT NULL REFERENCES test(id),
+CREATE TABLE IF NOT EXISTS tested_by (
+    id          INTEGER PRIMARY KEY AUTOINCREMENT,
+    resource_id INTEGER NOT NULL REFERENCES resource(id) ON DELETE CASCADE,
+    test_id     INTEGER NOT NULL REFERENCES test(id) ON DELETE CASCADE,
     UNIQUE(resource_id, test_id) ON CONFLICT IGNORE
 );
 
 -- Lifecycle:
 -- Have list of files from `git log`
 -- Run analysis script that returns hash test_file => [source_file, ...]
--- INSERT INTO to_run (test_file,source_file, environment) VALUES (...);
-CREATE VIEW to_run AS SELECT (
-     t.filename AS test_file,
-     t.test_id AS test_id,
-     r.filename AS source_file,
-     e.environment AS environment
-) FROM resource AS r
-JOIN tested_by AS tb ON tb.resource_id=r.resource_id
-JOIN test AS t ON t.id=tb.test_id
-JOIN environment ON e.id=r.environment_id
+-- INSERT OR IGNORE INTO tested_by (resource_id, test_id) VALUES (...);
+CREATE VIEW IF NOT EXISTS to_run AS
+    SELECT
+        t.filename   AS test_file,
+        t.id         AS test_id,
+        r.filename   AS source_file,
+        e.environment AS environment
+    FROM resource AS r
+    JOIN tested_by AS tb ON tb.resource_id = r.id
+    JOIN test AS t ON t.id = tb.test_id
+    JOIN environment AS e ON e.id = r.environment_id
 ;
 
--- TODO: make writable view for above intended for cron dumpage
-
 -- Lifecycle:
 -- Cron dumps rows into resource/tested_by, when time comes to run we grab the list of stuff:
 -- SELECT test_file FROM to_run WHERE source_file IN (...) GROUP BY test_file;
 -- We make a run
--- INSERT INTO run (product, environment, build, filename) VALUES SELECT ('fooProduct', 'MsWin32', 'someSha', test_file) FROM to_run WHERE source_file IN (...) GROUP BY test_file;
+-- INSERT OR IGNORE INTO test_for_build (build_id, test_id) SELECT b.id, tr.test_id
+--   FROM build AS b, to_run AS tr WHERE b.build='someSha' AND tr.source_file IN (...);
 -- We run a test
--- UPDATE run SET run_by='processid:90210' WHERE product='fooProduct' AND environment='MsWin32' AND build='someSha' AND test_file='actually_being_run.t';
+-- UPDATE test_for_build SET run_by='processid:90210' WHERE build_id=? AND test_id=?;
 -- It completes. The end.
--- UPDATE run SET result=1, finish=CURRENT_TIMESTAMP WHERE ...
-CREATE VIEW run AS SELECT (
-    p.product,
-    e.environment,
-    b.build,
-    r.route,
-    t.filename,
-    tb.run_by,
-    tb.result
-) FROM product AS p
-JOIN build AS b ON p.id=b.product_id
-JOIN test_for_build AS tb ON b.id=tb.build_id
-JOIN environment AS e on p.id=e.product_id
-JOIN route AS r ON p.id=r.product_id
-JOIN test AS t ON tb.test_id=t.id
+-- UPDATE test_for_build SET result=1, finish=CURRENT_TIMESTAMP WHERE build_id=? AND test_id=?;
+CREATE VIEW IF NOT EXISTS run AS
+    SELECT
+        p.product,
+        e.environment,
+        b.build,
+        r.route,
+        t.filename,
+        tb.run_by,
+        tb.result
+    FROM product AS p
+    JOIN build AS b ON p.id = b.product_id
+    JOIN test_for_build AS tb ON b.id = tb.build_id
+    JOIN environment AS e ON p.id = e.product_id
+    JOIN route AS r ON p.id = r.product_id
+    JOIN test AS t ON tb.test_id = t.id
 ;
-
--- TODO: writable view to_run to make above lifecycle a real boy

t/mapper.t

@@ -0,0 +1,55 @@
+use strict;
+use warnings;
+
+use Test::More;
+use File::Temp qw{tempfile};
+
+use_ok('Test::Mapper');
+
+# Spin up a temp DB for each test run
+my ( undef, $dbfile ) = tempfile( UNLINK => 1, SUFFIX => '.db' );
+
+my $mapper = Test::Mapper->new(
+    db          => $dbfile,
+    product     => 'TestProduct',
+    environment => 'linux',
+);
+
+isa_ok( $mapper, 'Test::Mapper' );
+
+# Map a test to some resources
+$mapper->map_test(
+    test      => 't/acceptance/login.t',
+    resources => [ 'lib/MyApp/Auth.pm', 'lib/MyApp/Session.pm' ],
+);
+
+# Map a second test to a partially overlapping set
+$mapper->map_test(
+    test      => 't/acceptance/logout.t',
+    resources => [ 'lib/MyApp/Session.pm' ],
+);
+
+# Resource that only login.t touches
+my @tests = $mapper->tests_for_resources( resources => ['lib/MyApp/Auth.pm'] );
+is( scalar @tests, 1, 'one test for Auth.pm' );
+is( $tests[0], 't/acceptance/login.t', 'correct test for Auth.pm' );
+
+# Resource shared by both tests
+my @shared = sort $mapper->tests_for_resources( resources => ['lib/MyApp/Session.pm'] );
+is( scalar @shared, 2, 'two tests for Session.pm' );
+is_deeply( \@shared, [ 't/acceptance/login.t', 't/acceptance/logout.t' ],
+    'correct tests for Session.pm' );
+
+# Resource not mapped to anything
+my @none = $mapper->tests_for_resources( resources => ['lib/MyApp/Unknown.pm'] );
+is( scalar @none, 0, 'no tests for unmapped resource' );
+
+# Idempotency: mapping same test+resource again should not create duplicates
+$mapper->map_test(
+    test      => 't/acceptance/login.t',
+    resources => ['lib/MyApp/Auth.pm'],
+);
+my @dedup = $mapper->tests_for_resources( resources => ['lib/MyApp/Auth.pm'] );
+is( scalar @dedup, 1, 'duplicate mapping is idempotent' );
+
+done_testing;