home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / os2 / OS2 / REXX / t / rx_sql.test < prev    next >
Encoding:
Text File  |  1999-07-20  |  1.7 KB  |  98 lines
  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. use OS2::REXX;
  12.  
  13. sub stmt
  14. {
  15.     my ($s) = @_;
  16.     $s =~ s/\s*\n\s*/ /g;
  17.     $s =~ s/^\s+//;
  18.     $s =~ s/\s+$//;
  19.     return $s;
  20. }
  21.  
  22. sub sqlcode
  23. {
  24.     OS2::REXX::_fetch("SQLCA.SQLCODE");
  25. }
  26.  
  27. sub sqlstate
  28. {
  29.     OS2::REXX::_fetch("SQLCA.SQLSTATE");
  30. }
  31.  
  32. sub sql
  33. {
  34.     my ($stmt) = stmt(@_);
  35.     return 0 if OS2::REXX::_call("sqlexec", $sqlexec, "", $stmt);
  36.     return sqlcode() >= 0;
  37. }
  38.  
  39. sub dbs
  40. {
  41.     my ($stmt) = stmt(@_);
  42.     return 0 if OS2::REXX::_call("sqldbs", $sqldbs, "", $stmt);
  43.     return sqlcode() >= 0;
  44. }
  45.  
  46. sub error
  47. {
  48.     my ($where) = @_;
  49.     print "ERROR in $where: sqlcode=", sqlcode(), " sqlstate=", sqlstate(), "\n";
  50.     dbs("GET MESSAGE INTO :MSG LINEWIDTH 75");
  51.     my $msg = OS2::REXX::_fetch("MSG");
  52.     print "\n", $msg;
  53.     exit 1;
  54. }
  55.  
  56. REXX_call {
  57.  
  58.   $sqlar   = DynaLoader::dl_load_file("h:/sqllib/dll/sqlar.dll") or die "load";
  59.   $sqldbs  = DynaLoader::dl_find_symbol($sqlar, "SQLDBS")  or die "find sqldbs"; 
  60.   $sqlexec = DynaLoader::dl_find_symbol($sqlar, "SQLEXEC") or die "find sqlexec";
  61.  
  62.   sql(<<) or error("connect");
  63.      CONNECT TO sample IN SHARE MODE
  64.  
  65.   OS2::REXX::_set("STMT" => stmt(<<));
  66.      SELECT name FROM sysibm.systables
  67.  
  68.   sql(<<) or error("prepare");
  69.      PREPARE s1 FROM :stmt
  70.  
  71.   sql(<<) or error("declare");
  72.      DECLARE c1 CURSOR FOR s1
  73.  
  74.   sql(<<) or error("open");
  75.      OPEN c1
  76.  
  77.   while (1) {
  78.      sql(<<) or error("fetch");
  79.           FETCH c1 INTO :name
  80.  
  81.      last if sqlcode() == 100;
  82.  
  83.      print "Table name is ", OS2::REXX::_fetch("NAME"), "\n";
  84.   }
  85.     
  86.   sql(<<) or error("close");
  87.      CLOSE c1
  88.  
  89.   sql(<<) or error("rollback");
  90.      ROLLBACK
  91.  
  92.   sql(<<) or error("disconnect");
  93.      CONNECT RESET
  94.  
  95. };
  96.  
  97. exit 0;
  98.