Test-Mapper/lib/Test/Mapper.pm

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

The general tradition in perl unit testing is to map 'what to test' when a piece of code changes is simple:

    lib/Foo/Bar.pm -> t/lib-Foo-Bar.t (or t/lib-Foo/Bar.t)
    bin/baz -> t/bin-baz.t

Unfortunately things tend to get messy when you engage in more complicated testing, such as integration testing.
There, you have one-to-many relationships, but which can still be easily discerned programmatically via inspecting @INC.
That is unless you require() modules (or worse, read & eval/exec), in which case analysis via PPI must be brought to bear.
Still, most people solve that particular problem with the doctor's adage about "not doing things that hurt".

However, acceptance tests will blow out your build server's thinking budget quickly, being a many-to-many mapping.
To make things worse, much of the stack isn't necessarily in $LANGUAGE_OF_CHOICE.
Furthermore this is not something that can simply be avoided via careful structuring.

Knowing all this, what then shall we do?  Cheat.
AKA breaking an insoluble problem into many smaller soluble ones.
It is well within the ability of a test author to discern the route via which an acceptance test accesses a feature.
Indeed this is necessarily so.

As such if we structure our mapping from this perspective life becomes quickly simplified.
Taking as an example an average web application, we can imagine a mapping like:

    t/acceptance/DoFoobarFeature.t -> GET /ez/bez, POST /huth/buth, ...

And every single so loaded "endpoint" necessarily has a number of resources loaded.
It is well within the realm of possibility to hit these endpoints with L<Playwright>, grab a HttpARchive and map that to the relevant source files in the repo.

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;