view release on metacpan or  search on metacpan

t/1017_regression.t  view on Meta::CPAN

# Embedded test harness (no Test::More dependency)
###############################################################################
my($PASS, $FAIL, $T) = (0, 0, 0);
sub ok {
    my($c, $n) = @_;
    $T++;
    $c ? ($PASS++, print "ok $T - $n\n")
       : ($FAIL++, print "not ok $T - $n\n");
}
sub is {
    my($g, $e, $n) = @_;
    my $got = defined($g) ? $g : 'undef';
    $T++;
    ("$got" eq "$e")
        ? ($PASS++, print "ok $T - $n\n")
        : ($FAIL++, print "not ok $T - $n  (got='$got', exp='$e')\n");
}

my $BASE = File::Spec->catdir(File::Spec->tmpdir, "dbhandy_regr_$$");
File::Path::rmtree($BASE) if -d $BASE;

# Remove the scratch directory however the script leaves: a normal exit,
# a die in mid-file, or an interrupt.  Without this an aborted run left a
# stale tree behind in the system temp directory.
END { File::Path::rmtree($BASE) if defined($BASE) && -d $BASE }

my $db = DB::Handy->new(base_dir => $BASE);
$db->create_database('regr');
$db->use_database('regr');

# Collect any warning the engine emits, so R8 can assert on it.
my @WARN;
$SIG{__WARN__} = sub { push @WARN, $_[0] };

# Flatten a result row set into a comparable string.
sub rowstr {
    my($r, @cols) = @_;
    return 'ERROR' unless $r && ($r->{type} eq 'rows');
    my @out;
    for my $row (@{$r->{data}}) {
        push @out, join(',', map { defined($row->{$_}) ? $row->{$_} : 'NULL' } @cols);
    }
    return join('|', @out);
}

###############################################################################
# Test bodies.  The plan count is derived from this list, never hard-coded.
###############################################################################
my @tests = (

    # -------------------------------------------------------------------
    # R1 -- _load_schema() must not touch the caller's $_
    # -------------------------------------------------------------------
    sub {
        $db->execute('CREATE TABLE r1 (id INT)');
        my @ids = (11, 22, 33);
        for (@ids) { $db->execute("INSERT INTO r1 (id) VALUES ($_)") }
        is(join(',', @ids), '11,22,33', 'R1 - caller @_ array survives execute()');
    },
    sub {
        my $alive = 1;
        # A read-only value would die with "Modification of a read-only value".
        eval {
            $db->{_tables} = {};
            for (44) { $db->execute("INSERT INTO r1 (id) VALUES ($_)") }
        };
        $alive = 0 if $@;
        ok($alive, 'R1 - constant list element is not modified');
    },
    sub {
        $db->{_tables} = {};
        my @seen = map { $db->execute('SELECT id FROM r1 WHERE id = 11'); $_ } (1, 2, 3);
        is(join(',', @seen), '1,2,3', 'R1 - $_ intact inside map');
    },

    # -------------------------------------------------------------------
    # R2 -- LIMIT / OFFSET with no WHERE / ORDER BY / GROUP BY
    # -------------------------------------------------------------------
    sub {
        $db->execute('CREATE TABLE r2 (id INT, s VARCHAR(10))');
        $db->execute("INSERT INTO r2 (id,s) VALUES ($_,'v$_')") for 1 .. 5;
        my $r = $db->execute('SELECT id FROM r2 LIMIT 2');
        is(scalar(@{$r->{data}}), 2, 'R2 - bare LIMIT is honoured');
    },
    sub {
        my $r = $db->execute('SELECT id FROM r2 OFFSET 3');
        is(scalar(@{$r->{data}}), 2, 'R2 - bare OFFSET is honoured');
    },
    sub {
        my $r = $db->execute('SELECT * FROM r2 LIMIT 1');
        is(scalar(@{$r->{data}}), 1, 'R2 - SELECT * with bare LIMIT');
    },
    sub {
        my $r = $db->execute('SELECT id FROM r2 ORDER BY id LIMIT 2 OFFSET 1');
        is(rowstr($r, 'id'), '2|3', 'R2 - ORDER BY with LIMIT/OFFSET still works');
    },
    sub {
        my $r = $db->execute('SELECT id FROM r2 WHERE id > 1 LIMIT 2');
        is(scalar(@{$r->{data}}), 2, 'R2 - WHERE with LIMIT still works');
    },

    # -------------------------------------------------------------------
    # R3 -- CHECK constraint versus NULL
    # -------------------------------------------------------------------
    sub {
        $db->execute('CREATE TABLE r3 (id INT, age INT CHECK (age >= 0))');
        my $r = $db->execute('INSERT INTO r3 (id,age) VALUES (1,5)');
        is($r->{type}, 'ok', 'R3 - value satisfying CHECK is accepted');
    },
    sub {
        my $r = $db->execute('INSERT INTO r3 (id) VALUES (2)');
        is($r->{type}, 'ok', 'R3 - omitted checked column is accepted');
    },
    sub {
        my $r = $db->execute('INSERT INTO r3 (id,age) VALUES (3,NULL)');
        is($r->{type}, 'ok', 'R3 - explicit NULL passes CHECK');
    },
    sub {
        my $r = $db->execute('INSERT INTO r3 (id,age) VALUES (4,-1)');
        is($r->{type}, 'error', 'R3 - value violating CHECK is still rejected');
    },
    sub {
        my $r = $db->execute('UPDATE r3 SET age = -9 WHERE id = 1');
        is($r->{type}, 'error', 'R3 - UPDATE violating CHECK is still rejected');
    },
    sub {
        my $r = $db->execute('UPDATE r3 SET age = 7 WHERE id = 1');
        is($r->{type}, 'ok', 'R3 - UPDATE satisfying CHECK is accepted');