dslinux/user/perl/os2/OS2/REXX/t rx_cmprt.t rx_dllld.t rx_emxrv.t rx_objcall.t rx_sql.test rx_tiesql.test rx_tievar.t rx_tieydb.t rx_varset.t rx_vrexx.t

[cayenne]

Update of /cvsroot/dslinux/dslinux/user/perl/os2/OS2/REXX/t
In directory antilope:/tmp/cvs-serv17422/os2/OS2/REXX/t

Added Files:
	rx_cmprt.t rx_dllld.t rx_emxrv.t rx_objcall.t rx_sql.test 
	rx_tiesql.test rx_tievar.t rx_tieydb.t rx_varset.t rx_vrexx.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: rx_tiesql.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;
    }
}

#extproc perl5 -Rx
#! perl

use REXX;

$db2 = load REXX "sqlar" or die "load";
tie $sqlcode, REXX, "SQLCA.SQLCODE";
tie $sqlstate, REXX, "SQLCA.SQLSTATE";
tie %rexx, REXX, "";

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

sub sql
{
	my ($stmt) = stmt(@_);
	return 0 if $db2->SqlExec($stmt);
	return $sqlcode >= 0;
}

sub dbs
{
	my ($stmt) = stmt(@_);
	return 0 if $db2->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");
	print "\n", $rexx{'MSG'};
	exit 1;
}

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

$rexx{'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 $rexx{'NAME'}\n";
}
	
sql(<<) or error("close");
     CLOSE c1

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

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

exit 0;

--- NEW FILE: rx_vrexx.t ---
BEGIN {
    chdir 't' if -d 't/lib';
    @INC = '../lib' if -d 'lib';
    require Config; import Config;
    if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
	print "1..0 # skipped: OS2::REXX not built\n";
	exit 0;
    }
    if (defined $ENV{PERL_TEST_NOVREXX}) {
	print "1..0 # skipped: request via PERL_TEST_NOVREXX\n";
	exit 0;
    }
}

use OS2::REXX;

$name = "VREXX";
$path = $ENV{LIBPATH} || $ENV{PATH} or die;
foreach $dir (split(';', $path)) {
  next unless -f "$dir/$name.DLL";
  $found = "$dir/$name.DLL";
  print "# found at `$found'\n";
  last;
}
$found or print "1..0 # skipped: cannot find $name.DLL\n" and exit;

print "1..10\n";

REXX_call {
  $vrexx = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n";
  print "ok 1\n";
  $vinit   = DynaLoader::dl_find_symbol($vrexx, "VINIT")   or die "find vinit";
  print "ok 2\n";
  $vexit   = DynaLoader::dl_find_symbol($vrexx, "VEXIT")   or die "find vexit";
  print "ok 3\n";
  $vmsgbox = DynaLoader::dl_find_symbol($vrexx, "VMSGBOX") or die "find vmsgbox";
  print "ok 4\n";
  $vversion= DynaLoader::dl_find_symbol($vrexx, "VGETVERSION") or die "find vgetversion";
  print "ok 5\n";
  
  $result = OS2::REXX::_call("VInit", $vinit) or die "VInit";
  print "ok 6\n";
  print "# VInit: $result\n";
  
  OS2::REXX::_set("MBOX.0" => 4,
  	        "MBOX.1" => "Perl VREXX Access Test",
  	        "MBOX.2" => "",
  	        "MBOX.3" => "(C) Andreas Kaiser",
  	        "MBOX.4" => "December 1994")
  	or die "set var";
  print "ok 7\n";
  
  $result = OS2::REXX::_call("VGetVersion", $vversion) or die "VMsgBox";
  print "ok 8\n";
  print "# VGetVersion: $result\n";
  
  $result = OS2::REXX::_call("VMsgBox", $vmsgbox, "", "Perl", "MBOX", 1) or die "VMsgBox";
  print "ok 9\n";
  print "# VMsgBox: $result\n";
  
  OS2::REXX::_call("VExit", $vexit);
  print "ok 10\n";
};

--- NEW FILE: rx_objcall.t ---
BEGIN {
    chdir 't' if -d 't/lib';
    @INC = '../lib' if -d 'lib';
    require Config; import Config;
    if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
	print "1..0\n";
	exit 0;
    }
}

use OS2::REXX;

#
# DLL
#
$rxu = load OS2::REXX "rxu" 
  or print "1..0 # skipped: cannot find RXU.DLL\n" and exit;
print "1..5\n", "ok 1\n";

#
# function
#
@pid = $rxu->RxProcId();
@pid == 1 ? print "ok 2\n" : print "not ok 2\n";
@res = split " ", $pid[0];
print "ok 3\n" if $res[0] == $$;
@pid = $rxu->RxProcId();
@res = split " ", $pid[0];
print "ok 4\n" if $res[0] == $$;
print "# @pid\n";

eval { $rxu->nixda(); };
my $err = $@;
if ($err) {
  $err =~ s/\n/\n#\t/g;
  print "# \$\@ = '$err'\n";
}
print "ok 5\n" if $@ =~ /^Can't find symbol `nixda\'/;

--- NEW FILE: rx_tievar.t ---
BEGIN {
    chdir 't' if -d 't/lib';
    @INC = '../lib' if -d 'lib';
    require Config; import Config;
    if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
	print "1..0\n";
	exit 0;
    }
}

use OS2::REXX;

#
# DLL
#
load OS2::REXX "rxu"
  or print "1..0 # skipped: cannot find RXU.DLL\n" and exit;

print "1..19\n";

REXX_call {
  print "ok 1\n";

  #
  # scalar
  #
  tie $s, OS2::REXX, "TEST";
  print "ok 2\n";
  $s = 1;
  print "ok 3\n" if $s eq 1;
  print "not ok 3\n# `$s'\n" unless $s eq 1;
  untie $s;

  #
  # hash
  #

  tie %all, OS2::REXX, "";	# all REXX vars
  print "ok 4\n";

  sub show {
	# show all REXX vars
	print "-- at _--\n";
	foreach (keys %all) {
		$v = $all{$_};
		print "$_ => $v\n";
	}
  }

  sub check {
	# check all REXX vars
	my ($test, @arr) = @_;
	my @rx;
	foreach $key (sort keys %all) { push @rx, $key, $all{$key} }
	if ("@rx" eq "@arr") {print "ok $test\n"}
	else { print "not ok $test\n# expect `@arr', got `@rx'\n" }
  }


  tie %h, OS2::REXX, "TEST.";
  print "ok 5\n";
  check(6);

  $h{"one"} = 1;
  check(7, "TEST.one", 1);

  $h{"two"} = 2;
  check(8, "TEST.one", 1, "TEST.two", 2);

  $h{"one"} = "";
  check(9, "TEST.one", "", "TEST.two", 2);
  print "ok 10\n" if exists $h{"one"};
  print "ok 11\n" if exists $h{"two"};

  delete $h{"one"};
  check(12, "TEST.two", 2);
  print "ok 13\n" if not exists $h{"one"};
  print "ok 14\n" if exists $h{"two"};

  OS2::REXX::dropall("TEST.");
  print "ok 15\n";
  check(16);
  print "ok 17\n" if not exists $h{"one"};
  print "ok 18\n" if not exists $h{"two"};

  untie %h;
  print "ok 19";

};

--- NEW FILE: 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;

--- NEW FILE: rx_emxrv.t ---
BEGIN {
    chdir 't' if -d 't/lib';
    @INC = '../lib' if -d 'lib';
    require Config; import Config;
    if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
	print "1..0\n";
	exit 0;
    }
}

print "1..20\n";

require OS2::DLL;
print "ok 1\n";
$emx_dll = OS2::DLL->load('emx');
print "ok 2\n";
$emx_version = $emx_dll->emx_revision();
print "ok 3\n";
$emx_version >= 40 or print "not ";	# We cannot work with old EMXs
print "ok 4\n";

$reason = '';
$emx_version >= 99 and $reason = ' # skipped: version of EMX 100 or more';	# Be safe
print "ok 5$reason\n";

$emx_fullname = OS2::DLLname 0x202, $emx_dll->{Handle};	# Handle ==> fullname
print "ok 6\n";
$emx_dll1 = OS2::DLL->module($emx_fullname);
print "ok 7\n";
$emx_dll->{Handle} == $emx_dll1->{Handle} or print "not ";
print "ok 8\n";

$emx_version1 = $emx_dll1->emx_revision();
print "ok 9\n";
$emx_version1 eq $emx_version or print "not ";
print "ok 10\n";

$emx_revision = $emx_dll->wrapper_REXX('emx_revision');
print "ok 11\n";
$emx_version2 = $emx_revision->();
print "ok 12\n";
$emx_version2 eq $emx_version or print "not ";
print "ok 13\n";

$emx_revision1 = $emx_dll1->wrapper_REXX('#128');
print "ok 14\n";
$emx_version3 = $emx_revision1->();
print "ok 15\n";
$emx_version3 eq $emx_version or print "not ";
print "ok 16\n";

($emx_fullname1 = $emx_fullname) =~ s,/,\\,g;
$emx_dll2 = OS2::DLL->new($emx_fullname1);
print "ok 17\n";
$emx_dll->{Handle} == $emx_dll2->{Handle} or print "not ";
print "ok 18\n";

$emx_version4 = $emx_dll2->emx_revision();
print "ok 19\n";
$emx_version4 eq $emx_version or print "not ";
print "ok 20\n";

--- NEW FILE: rx_cmprt.t ---
BEGIN {
    chdir 't' if -d 't/lib';
    @INC = '../lib' if -d 'lib';
    require Config; import Config;
    if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
	print "1..0\n";
	exit 0;
    }
}

use OS2::REXX qw(:DEFAULT register);

$| = 1;				# Otherwise data from REXX may come first

print "1..18\n";

$n = 1;
sub do_me {
  print "ok $n\n";
  "OK";
}

@res = REXX_call(\&do_me);
print "ok 2\n";
@res == 1 ? print "ok 3\n" : print "not ok 3\n";
$res[0] eq "OK" ? print "ok 4\n" : print "not ok 4\n# `$res[0]'\n";

# Try again
$n = 5;
@res = REXX_call(\&do_me);
print "ok 6\n";
@res == 1 ? print "ok 7\n" : print "not ok 7\n";
$res[0] eq "OK" ? print "ok 8\n" : print "not ok 8\n# `$res[0]'\n";

REXX_call { print "ok 9\n" };
REXX_eval 'say "ok 10"';
# Try again
REXX_eval 'say "ok 11"';
print "ok 12\n" if REXX_eval("return 2 + 3") eq 5;
REXX_eval_with 'say myfunc()', myfunc => sub {"ok 13"};
REXX_eval_with "call myout 'ok'  14", myout => sub {print shift, "\n"};
REXX_eval_with "say 'ok 'myfunc(3,5)", myfunc => sub {shift() * shift()};

sub MYFUNC1 {shift}
sub MYFUNC2 {3 * shift}
REXX_eval_with "call myfunc
		say 'ok 'myfunc1(1)myfunc2(2)",
  myfunc => sub { register qw(myfunc1 myfunc2) };

REXX_eval_with "say 'ok 'myfunc(10,7)",
  myfunc => sub { REXX_eval "return $_[0] + $_[1]" };

sub MyFunc3 {print 'ok ', shift() + shift(), "\n"}
REXX_eval "address perleval\n'MyFunc3(10,8)'";

--- NEW FILE: rx_varset.t ---
BEGIN {
    chdir 't' if -d 't/lib';
    @INC = '../lib' if -d 'lib';
    require Config; import Config;
    if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
	print "1..0\n";
	exit 0;
    }
}

use OS2::REXX;

print "1..9\n";

REXX_call {
  OS2::REXX::_set("X" => sqrt(2)) and print "ok 1\n";
  $x = OS2::REXX::_fetch("X") and print "ok 2\n";
  if (abs($x - sqrt(2)) < 5e-15) {
    print "ok 3\n";
  } else {  print "not ok 3\n# sqrt(2) = @{[sqrt(2)]} != `$x'\n" }
  OS2::REXX::_set("Y" => sqrt(3)) and print "ok 4\n";
  $i = 0;
  $n = 4;
  while (($name, $value) = OS2::REXX::_next("")) {
	$i++; $n++;
	if ($i <= 2 and $name eq "Y" ) {
	  if ($value eq sqrt(3)) {
	    print "ok $n\n";
	  } else {
	    print "not ok $n\n# `$name' => `$value'\n" ;
	  }
	} elsif ($i <= 2 and $name eq "X") {
	  print "ok $n\n" if $value eq sqrt(2);
	} else { print "not ok 7\n# name `$name', value `$value'\n" }
  }
  print "ok 7\n" if $i == 2;
  OS2::REXX::_drop("X") and print "ok 8\n";
  $x = OS2::REXX::_fetch("X") or print "ok 9\n";
};

--- NEW FILE: rx_dllld.t ---
BEGIN {
    chdir 't' if -d 't/lib';
    @INC = '../lib' if -d 'lib';
    require Config; import Config;
    if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
	print "1..0\n";
	exit 0;
    }
}

use OS2::REXX;

$path = $ENV{LIBPATH} || $ENV{PATH} or die;
foreach $dir (split(';', $path)) {
  next unless -f "$dir/RXU.DLL";
  $found = "$dir/RXU.DLL";
  last;
}
$found or print "1..0 # skipped: cannot find RXU.DLL\n" and exit;

print "1..5\n";

$module = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n";
print "ok 1\n";

$address = DynaLoader::dl_find_symbol($module, "RXPROCID") 
  or die "not ok 2\n# find\n";
print "ok 2\n";

$result = OS2::REXX::_call("RxProcId", $address) or die "not ok 3\n# REXX";
print "ok 3\n";

($pid, $ppid, $ssid) = split(/\s+/, $result);
$pid == $$ ? print "ok 4\n" : print "not ok 4\n# pid\n";
$ssid == 1 ? print "ok 5\n" : print "not ok 5\n# pid\n";
print "# pid=$pid, ppid=$ppid, ssid=$ssid\n";

--- NEW FILE: rx_tieydb.t ---
BEGIN {
    chdir 't' if -d 't/lib';
    @INC = '../lib' if -d 'lib';
    require Config; import Config;
    if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
	print "1..0\n";
	exit 0;
    }
}

use OS2::REXX;
$rx = load OS2::REXX "RXU"     # from RXU1a.ZIP
  or print "1..0 # skipped: cannot find RXU.DLL\n" and exit;

print "1..7\n", "ok 1\n";

$rx->prefix("Rx");                         # implicit function prefix
print "ok 2\n";

REXX_call {
  tie @pib, OS2::REXX, "IB.P";       # bind array to REXX stem variable
  print "ok 3\n";
  tie %tib, OS2::REXX, "IB.T.";      # bind associative array to REXX stem var
  print "ok 4\n";

  $rx->GetInfoBlocks("IB.");    # call REXX function
  print "ok 5\n";
  defined $pib[6] ? print "ok 6\n" : print "not ok 6\n# pib\n";
  defined $tib{7} && $tib{7} =~ /^\d+$/ ? print "ok 7\n"
    : print "not ok 7\n# tib\n";
  print "# Process status is ", unpack("I", $pib[6]),
        ", thread ordinal is $tib{7}\n";
};