1BEGIN {
2    chdir 't' if -d 't/lib';
3    @INC = '../lib';
4    require Config; import Config;
5    if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
6	print "1..0\n";
7	exit 0;
8    }
9}
10
11#extproc perl5 -Rx
12#! perl
13
14use REXX;
15
16$db2 = load REXX "sqlar" or die "load";
17tie $sqlcode, REXX, "SQLCA.SQLCODE";
18tie $sqlstate, REXX, "SQLCA.SQLSTATE";
19tie %rexx, REXX, "";
20
21sub stmt
22{
23	my ($s) = @_;
24	$s =~ s/\s*\n\s*/ /g;
25	$s =~ s/^\s+//;
26	$s =~ s/\s+$//;
27	return $s;
28}
29
30sub sql
31{
32	my ($stmt) = stmt(@_);
33	return 0 if $db2->SqlExec($stmt);
34	return $sqlcode >= 0;
35}
36
37sub dbs
38{
39	my ($stmt) = stmt(@_);
40	return 0 if $db2->SqlDBS($stmt);
41	return $sqlcode >= 0;
42}
43
44sub error
45{
46	my ($where) = @_;
47	print "ERROR in $where: sqlcode=$sqlcode, sqlstate=$sqlstate\n";
48	dbs("GET MESSAGE INTO :msg LINEWIDTH 75");
49	print "\n", $rexx{'MSG'};
50	exit 1;
51}
52
53sql(<<) or error("connect");
54     CONNECT TO sample IN SHARE MODE
55
56$rexx{'STMT'} = stmt(<<);
57     SELECT name FROM sysibm.systables
58
59sql(<<) or error("prepare");
60     PREPARE s1 FROM :stmt
61
62sql(<<) or error("declare");
63     DECLARE c1 CURSOR FOR s1
64
65sql(<<) or error("open");
66     OPEN c1
67
68while (1) {
69     sql(<<) or error("fetch");
70          FETCH c1 INTO :name
71
72     last if $sqlcode == 100;
73
74     print "Table name is $rexx{'NAME'}\n";
75}
76
77sql(<<) or error("close");
78     CLOSE c1
79
80sql(<<) or error("rollback");
81     ROLLBACK
82
83sql(<<) or error("disconnect");
84     CONNECT RESET
85
86exit 0;
87