#!/usr/local/bin/perl -w
#
#
# test cases:
# event creation, register callback, cancel callback
# event creation, fork / thread (except win32), destruction
# event creation, fork / thread (except win32), wait event, destruction
# event creation, fork / thread (except win32), register callback, destruction
use strict;
use warnings;
use Data::Dumper;
use DBI;
use Config;
use Test::More;
use lib 't','.';
use Time::HiRes qw(sleep);
use TestFirebird;
my $T = TestFirebird->new;
my ($dbh, $error_str) = $T->connect_to_database;
my ( $test_dsn, $test_user, $test_password ) =
( $T->{tdsn}, $T->{user}, $T->{pass} );
if ($error_str) {
BAIL_OUT("Error! $error_str!");
}
unless ( $dbh->isa('DBI::db') ) {
plan skip_all => 'Connection to database failed, cannot continue testing';
}
else {
plan tests => 22;
}
ok($dbh, 'Connected to the database');
my $table = find_new_table($dbh);
ok($table, qq{Table is '$table'});
# create required test table and triggers
{
my @ddl = (<<"DDL", <<"DDL", <<"DDL");
CREATE TABLE $table (
id INTEGER NOT NULL,
title VARCHAR(255) NOT NULL
);
DDL
CREATE TRIGGER ins_${table}_trig FOR $table
AFTER INSERT POSITION 0
AS BEGIN
POST_EVENT 'foo_inserted';
END
DDL
CREATE TRIGGER del_${table}_trig FOR $table
AFTER DELETE POSITION 0
AS BEGIN
POST_EVENT 'foo_deleted';
END
DDL
ok($dbh->do($_)) foreach @ddl; # 3 times
}
my $evh = $dbh->func('foo_inserted', 'foo_deleted', 'ib_init_event');
ok($evh);
ok($dbh->func($evh, sub { print "about to cancel"; 1 }, 'ib_register_callback'));
ok($dbh->func($evh, 'ib_cancel_callback'));
my $worker = sub {
my $table = shift;
my @dbi_args = ( shift, shift, shift );
my $delay = shift;
my $dbh = DBI->connect(@dbi_args, {AutoCommit => 1 }) or return 0;
sleep($delay) if $delay;
for (1..5) {
$dbh->do(qq{INSERT INTO $table VALUES($_, 'bar')});
}
$dbh->do(qq{DELETE FROM $table});
$dbh->disconnect;
};
# try ithreads
{
my $how_many = 10;
SKIP: {
skip "this $^O perl $] is not configured to support iThreads", $how_many if (!$Config{useithreads} || $] < 5.008);
skip "known problems under MSWin32 ActivePerl's iThreads", $how_many if $Config{osname} eq 'MSWin32';
skip "Perl version is older than 5.8.8", $how_many if $^V and $^V lt v5.8.8;
# TODO: try enabling this when firebird 3 is released stable
skip "thread tests unstable under load", $how_many
if $ENV{AUTOMATED_TESTING};
eval { require threads };
skip "unable to use threads;", $how_many if $@;
%::CNT = ();
ok($dbh->func($evh,
sub {
my $posted_events = shift;
while (my ($k, $v) = each %$posted_events) {
$::CNT{$k} += $v;
}
1;
},
'ib_register_callback'
), 'callback registered');
my $t = threads->create($worker, $table, $test_dsn, $test_user, $test_password);
ok($t, 'thread created');
ok($t->join, 'thread joined');
while (not exists $::CNT{'foo_deleted'}) {}
ok($dbh->func($evh, 'ib_cancel_callback'), 'callback unregistered');
is($::CNT{'foo_inserted'}, 5);
is($::CNT{'foo_deleted'}, 5);
SKIP: {
skip
"automated test of ib_wait_event -- flagile under load",
4
if $ENV{AUTOMATED_TESTING};
# test ib_wait_event
%::CNT = ();
$t = threads->create($worker, $table, $test_dsn, $test_user, $test_password, 0.2);
ok($t, "create thread");
for (1..6) {
my $posted_events = $dbh->func($evh, 'ib_wait_event');
while (my ($k, $v) = each %$posted_events) {
$::CNT{$k} += $v;
}
}
ok($t->join);
is($::CNT{'foo_inserted'}, 5);
is($::CNT{'foo_deleted'}, 5);
}
}}
ok($dbh->do(qq(DROP TRIGGER ins_${table}_trig)));
ok($dbh->do(qq(DROP TRIGGER del_${table}_trig)));
ok($dbh->do(qq(DROP TABLE $table)));
ok($dbh->disconnect);