The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl -w
# $Id: thread.t,v 1.5 2005/10/01 13:05:13 mpeppler Exp $
# Test support for threads in DBD::Sybase.

use strict;
use Config qw(%Config);

BEGIN {
    if (!$Config{useithreads} || $] < 5.008) {
	print "1..0 # Skipped: this perl $] not configured to support iThreads\n";
	exit 0;
    }
}

use threads;

use DBI;
use DBD::Sybase;		# REQUIRED!!!

BEGIN {
    if (!DBD::Sybase::thread_enabled()) {
	print "1..0 # Skipped: this DBD::Sybase not configured to support iThreads\n";
	exit 0;
    }
}

use Test::More tests => 10;

use Thread::Queue;

use lib 't';
use _test;

use vars qw($Pwd $Uid $Srv $Db);


($Uid, $Pwd, $Srv, $Db) = _test::get_info();

my $database = getDatabase();
print "Using database $database\n";

my $queue = Thread::Queue->new;

my $rdr = threads->create(\&reader, $queue, $database);
my @thr;
foreach (1 .. 3) {
    push(@thr, threads->create(\&test_it, $queue, $database));
}
my $count = $rdr->join;
my $total = 0;
foreach (@thr) {
    $total += $_->join;
}
is($count, $total);

sub reader {
    my $queue = shift;
    my $db    = shift;

    my $dbh = getDbh($db);
    ok(defined($dbh));
    my $sth = $dbh->prepare("select id from sysobjects");
    ok(defined($sth));
    my $rc = $sth->execute;
    ok($rc);
    my $count = 0;
    while(my $row = $sth->fetch) {
	$queue->enqueue($row->[0]);
	++$count;
    }

    return $count;
}

sub test_it {
    my $queue = shift;
    my $db    = shift;

    my $dbh = getDbh($db);
    ok(defined($dbh));

    my $sth = $dbh->prepare("select name, crdate, instrig, deltrig, type, uid, sysstat, updtrig from sysobjects where id = ?");
    ok(defined($sth));
    my $count = 0;
    my $rc;
    my $tid = threads->tid();
    while(1) {
	my $id = $queue->dequeue_nb;
	last unless(defined($id));
	$rc = $sth->execute($id);
#	ok($rc);
	while(my $row = $sth->fetch) {
	    print "$tid - fetched($id) == $row->[0]\n";
	    ++$count;
	}
    }

    return $count;
}


sub getDbh {
    my $dbname = shift || 'master';
    my $dbh = DBI->connect("dbi:Sybase:server=$Srv;database=$dbname;timeout=60;loginTimeout=20", $Uid, $Pwd, {PrintError => 1});

    if(!$dbh) {
	warn "No connection - did you set the user, password and server name correctly in PWD?\n";
	for (4 .. 10) {
	    ok(0);
	}
	exit(0);
    }

    return $dbh;
}

sub getDatabase {
    my $dbh = getDbh();
    my $sth = $dbh->prepare("select 1 from master..sysdatabases where name = 'sybsystemprocs'");
    $sth->execute;
    my $database = 'master';
    while(my $row = $sth->fetch) {
	$database = 'sybsystemprocs';
    }

    return $database;
}