os2/OS2/REXX/t/rx_tiesql.test

   1 BEGIN {
   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
  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;