perl 5.003_02: [no incremental changelog available]

9 files changed, 509 insertions, 0 deletions

diff --git a/os2/OS2/REXX/t/rx_cmprt.t b/os2/OS2/REXX/t/rx_cmprt.t
new file mode 100644
index 0000000000..a73e43e36e
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_cmprt.t
@@ -0,0 +1,40 @@
+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;
+
+$| = 1;				# Otherwise data from REXX may come first
+
+print "1..13\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"};
diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t
new file mode 100644
index 0000000000..317743f3cb
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_dllld.t
@@ -0,0 +1,36 @@
+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/YDBAUTIL.DLL";
+  $found = "$dir/YDBAUTIL.DLL";
+  last;
+}
+$found or die "1..0\n#Cannot find YDBAUTIL.DLL\n";
+
+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";
diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t
new file mode 100644
index 0000000000..b4f04c308a
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_objcall.t
@@ -0,0 +1,33 @@
+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
+#
+$ydba = load OS2::REXX "ydbautil" or die "1..0\n# load\n";
+print "1..5\n", "ok 1\n";
+
+#
+# function
+#
+@pid = $ydba->RxProcId();
+@pid == 1 ? print "ok 2\n" : print "not ok 2\n";
+@res = split " ", $pid[0];
+print "ok 3\n" if $res[0] == $$;
+@pid = $ydba->RxProcId();
+@res = split " ", $pid[0];
+print "ok 4\n" if $res[0] == $$;
+print "# @pid\n";
+
+eval { $ydba->nixda(); };
+print "ok 5\n" if $@ =~ /^Can't find entry 'nixda\'/;
+
diff --git a/os2/OS2/REXX/t/rx_sql.test b/os2/OS2/REXX/t/rx_sql.test
new file mode 100644
index 0000000000..4f984250a3
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_sql.test
@@ -0,0 +1,97 @@
+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;
diff --git a/os2/OS2/REXX/t/rx_tiesql.test b/os2/OS2/REXX/t/rx_tiesql.test
new file mode 100644
index 0000000000..2947516755
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_tiesql.test
@@ -0,0 +1,86 @@
+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;
diff --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t
new file mode 100644
index 0000000000..6132e23f80
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_tievar.t
@@ -0,0 +1,88 @@
+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 "ydbautil" or die "1..0\n# load\n";
+
+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 "--@_--\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";
+
+};
diff --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t
new file mode 100644
index 0000000000..8251051265
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_tieydb.t
@@ -0,0 +1,31 @@
+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 "ydbautil" or die "1..0\n# load\n";    # from RXU17.ZIP
+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";
+};
diff --git a/os2/OS2/REXX/t/rx_varset.t b/os2/OS2/REXX/t/rx_varset.t
new file mode 100644
index 0000000000..9d4f3b2e56
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_varset.t
@@ -0,0 +1,39 @@
+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";
+};
diff --git a/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t
new file mode 100644
index 0000000000..a40749f55f
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_vrexx.t
@@ -0,0 +1,59 @@
+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;
+
+$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 die "1..0\n#Cannot find $name.DLL\n";
+
+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";
+};