Commit | Line | Data |
760ac839 |
1 | BEGIN { |
2 | chdir 't' if -d 't/lib'; |
3 | @INC = '../lib'; |
4 | require Config; import Config; |
bbad3607 |
5 | if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { |
760ac839 |
6 | print "1..0\n"; |
7 | exit 0; |
8 | } |
9 | } |
10 | |
11 | #extproc perl5 -Rx |
12 | #! perl |
13 | |
14 | use REXX; |
15 | |
16 | $db2 = load REXX "sqlar" or die "load"; |
17 | tie $sqlcode, REXX, "SQLCA.SQLCODE"; |
18 | tie $sqlstate, REXX, "SQLCA.SQLSTATE"; |
19 | tie %rexx, REXX, ""; |
20 | |
21 | sub 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 | |
30 | sub sql |
31 | { |
32 | my ($stmt) = stmt(@_); |
33 | return 0 if $db2->SqlExec($stmt); |
34 | return $sqlcode >= 0; |
35 | } |
36 | |
37 | sub dbs |
38 | { |
39 | my ($stmt) = stmt(@_); |
40 | return 0 if $db2->SqlDBS($stmt); |
41 | return $sqlcode >= 0; |
42 | } |
43 | |
44 | sub 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 | |
53 | sql(<<) or error("connect"); |
54 | CONNECT TO sample IN SHARE MODE |
55 | |
56 | $rexx{'STMT'} = stmt(<<); |
57 | SELECT name FROM sysibm.systables |
58 | |
59 | sql(<<) or error("prepare"); |
60 | PREPARE s1 FROM :stmt |
61 | |
62 | sql(<<) or error("declare"); |
63 | DECLARE c1 CURSOR FOR s1 |
64 | |
65 | sql(<<) or error("open"); |
66 | OPEN c1 |
67 | |
68 | while (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 | |
77 | sql(<<) or error("close"); |
78 | CLOSE c1 |
79 | |
80 | sql(<<) or error("rollback"); |
81 | ROLLBACK |
82 | |
83 | sql(<<) or error("disconnect"); |
84 | CONNECT RESET |
85 | |
86 | exit 0; |