fixes for bugs in change#4586 and OS/2 pod tweak, from Ilya

[p5sagit/p5-mst-13.2.git] / os2 / OS2 / REXX / t / rx_sql.test

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;
    }
}

use OS2::REXX;

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

sub sqlcode
{
	OS2::REXX::_fetch("SQLCA.SQLCODE");
}

sub sqlstate
{
	OS2::REXX::_fetch("SQLCA.SQLSTATE");
}

sub sql
{
	my ($stmt) = stmt(@_);
	return 0 if OS2::REXX::_call("sqlexec", $sqlexec, "", $stmt);
	return sqlcode() >= 0;
}

sub dbs
{
	my ($stmt) = stmt(@_);
	return 0 if OS2::REXX::_call("sqldbs", $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");
	my $msg = OS2::REXX::_fetch("MSG");
	print "\n", $msg;
	exit 1;
}

REXX_call {

  $sqlar   = DynaLoader::dl_load_file("h:/sqllib/dll/sqlar.dll") or die "load";
  $sqldbs  = DynaLoader::dl_find_symbol($sqlar, "SQLDBS")  or die "find sqldbs"; 
  $sqlexec = DynaLoader::dl_find_symbol($sqlar, "SQLEXEC") or die "find sqlexec";

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

  OS2::REXX::_set("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 ", OS2::REXX::_fetch("NAME"), "\n";
  }
	
  sql(<<) or error("close");
     CLOSE c1

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

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

};

exit 0;