rx_tiesql.test

来自「UNIX下perl实现代码」· TEST 代码 · 共 87 行

BEGIN {
    chdir 't' if -d 't/lib';
    @INC = '../lib';
    require Config; import Config;
    if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
	print "1..0\n";
	exit 0;
    }
}

#extproc perl5 -Rx
#! perl

use REXX;

$db2 = load REXX "sqlar" or die "load";
tie $sqlcode, REXX, "SQLCA.SQLCODE";
tie $sqlstate, REXX, "SQLCA.SQLSTATE";
tie %rexx, REXX, "";

sub stmt
{
	my ($s) = @_;
	$s =~ s/\s*\n\s*/ /g;
	$s =~ s/^\s+//;
	$s =~ s/\s+$//;
	return $s;
}

sub sql
{
	my ($stmt) = stmt(@_);
	return 0 if $db2->SqlExec($stmt);
	return $sqlcode >= 0;
}

sub dbs
{
	my ($stmt) = stmt(@_);
	return 0 if $db2->SqlDBS($stmt);
	return $sqlcode >= 0;
}

sub error
{
	my ($where) = @_;
	print "ERROR in $where: sqlcode=$sqlcode, sqlstate=$sqlstate\n";
	dbs("GET MESSAGE INTO :msg LINEWIDTH 75");
	print "\n", $rexx{'MSG'};
	exit 1;
}

sql(<<) or error("connect");
     CONNECT TO sample IN SHARE MODE

$rexx{'STMT'} = stmt(<<);
     SELECT name FROM sysibm.systables

sql(<<) or error("prepare");
     PREPARE s1 FROM :stmt

sql(<<) or error("declare");
     DECLARE c1 CURSOR FOR s1

sql(<<) or error("open");
     OPEN c1

while (1) {
     sql(<<) or error("fetch");
          FETCH c1 INTO :name

     last if $sqlcode == 100;

     print "Table name is $rexx{'NAME'}\n";
}
	
sql(<<) or error("close");
     CLOSE c1

sql(<<) or error("rollback");
     ROLLBACK

sql(<<) or error("disconnect");
     CONNECT RESET

exit 0;