Re: [PATCH 5.005_62] OS/2 improvements

	Message-Id: <199910240724.DAA12230@monk.mps.ohio-state.edu>

p4raw-id: //depot/perl@4432

15 files changed, 272 insertions, 102 deletions

diff --git a/os2/OS2/REXX/Changes b/os2/OS2/REXX/Changes
index 46b38ef46c..7c19710db6 100644
--- a/os2/OS2/REXX/Changes
+++ b/os2/OS2/REXX/Changes
@@ -2,3 +2,6 @@
 	After fixpak17 a lot of other places have mismatched lengths
 returned in the REXXPool interface.
 	Also drop does not work on stems any more.
+0.22:
+	A subsystem module OS2::DLL extracted which does not link
+	with REXX runtime library.
diff --git a/os2/OS2/REXX/DLL/Changes b/os2/OS2/REXX/DLL/Changes
new file mode 100644
index 0000000000..874f7fab4a
--- /dev/null
+++ b/os2/OS2/REXX/DLL/Changes
@@ -0,0 +1,2 @@
+0.01:
+	Split out of OS2::REXX
diff --git a/os2/OS2/REXX/DLL/DLL.pm b/os2/OS2/REXX/DLL/DLL.pm
new file mode 100644
index 0000000000..7e54371973
--- /dev/null
+++ b/os2/OS2/REXX/DLL/DLL.pm
@@ -0,0 +1,136 @@
+package OS2::DLL;
+
+use Carp;
+use DynaLoader;
+
+@ISA = qw(DynaLoader);
+
+sub AUTOLOAD {
+    $AUTOLOAD =~ /^OS2::DLL::.+::(.+)$/
+      or confess("Undefined subroutine &$AUTOLOAD called");
+    return undef if $1 eq "DESTROY";
+    $_[0]->find($1)
+      or confess("Can't find entry '$1' to DLL '$_[0]->{File}': $^E");
+    goto &$AUTOLOAD;
+}
+
+@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
+%dlls = ();
+
+# Preloaded methods go here.  Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+# Cannot autoload, the autoloader is used for the REXX functions.
+
+sub load
+{
+	confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1;
+	my ($class, $file, @where) = (@_, @libs);
+	return $dlls{$file} if $dlls{$file};
+	my $handle;
+	foreach (@where) {
+		$handle = DynaLoader::dl_load_file("$_/$file.dll");
+		last if $handle;
+	}
+	$handle = DynaLoader::dl_load_file($file) unless $handle;
+	return undef unless $handle;
+	my $packs = $INC{'OS2/REXX.pm'} ? 'OS2::DLL OS2::REXX' : 'OS2::DLL';
+	eval <<EOE or die "eval package $@";
+package OS2::DLL::$file; \@ISA = qw($packs);
+sub AUTOLOAD {
+  \$OS2::DLL::AUTOLOAD = \$AUTOLOAD;
+  goto &OS2::DLL::AUTOLOAD;
+}
+1;
+EOE
+	return $dlls{$file} = 
+	  bless {Handle => $handle, File => $file, Queue => 'SESSION' },
+		"OS2::DLL::$file";
+}
+
+sub find
+{
+	my $self   = shift;
+	my $file   = $self->{File};
+	my $handle = $self->{Handle};
+	my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
+	my $queue  = $self->{Queue};
+	foreach (@_) {
+		my $name = "OS2::DLL::${file}::$_";
+		next if defined(&$name);
+		my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_)
+		        || DynaLoader::dl_find_symbol($handle, $prefix.$_)
+			or return 0;
+		eval <<EOE or die "eval sub";
+package OS2::DLL::$file;
+sub $_ {
+  shift;
+  OS2::DLL::_call('$_', $addr, '$queue', \@_);
+}
+1;
+EOE
+	}
+	return 1;
+}
+
+bootstrap OS2::DLL;
+
+1;
+__END__
+
+=head1 NAME
+
+OS2::DLL - access to DLLs with REXX calling convention.
+
+=head2 NOTE
+
+When you use this module, the REXX variable pool is not available.
+
+See documentation of L<OS2::REXX> module if you need the variable pool.
+
+=head1 SYNOPSIS
+
+	use OS2::DLL;
+	$emx_dll = OS2::DLL->load('emx');
+	$emx_version = $emx_dll->emx_revision();
+
+=head1 DESCRIPTION
+
+=head2 Load REXX DLL
+
+	$dll = load OS2::DLL NAME [, WHERE];
+
+NAME is DLL name, without path and extension.
+
+Directories are searched WHERE first (list of dirs), then environment
+paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search 
+is performed in default DLL path (without adding paths and extensions).
+
+The DLL is not unloaded when the variable dies.
+
+Returns DLL object reference, or undef on failure.
+
+=head2 Check for functions (optional):
+
+	BOOL = $dll->find(NAME [, NAME [, ...]]);
+
+Returns true if all functions are available.
+
+=head2 Call external REXX function:
+
+	$dll->function(arguments);
+
+Returns the return string if the return code is 0, else undef.
+Dies with error message if the function is not available.
+
+=head1 ENVIRONMENT
+
+If C<PERL_REXX_DEBUG> is set, emits debugging output.  Looks for DLLs
+in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
+
+=head1 AUTHOR
+
+Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L<OS2::REXX>
+written by Andreas Kaiser ak@ananke.s.bawue.de.
+
+=cut
diff --git a/os2/OS2/REXX/DLL/DLL.xs b/os2/OS2/REXX/DLL/DLL.xs
new file mode 100644
index 0000000000..c8e7c58007
--- /dev/null
+++ b/os2/OS2/REXX/DLL/DLL.xs
@@ -0,0 +1,72 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define INCL_BASE
+#define INCL_REXXSAA
+#include <os2emx.h>
+
+static RXSTRING * strs;
+static int	  nstrs;
+static char *	  trace;
+
+static void
+needstrs(int n)
+{
+    if (n > nstrs) {
+	if (strs)
+	    free(strs);
+	nstrs = 2 * n;
+	strs = malloc(nstrs * sizeof(RXSTRING));
+    }
+}
+
+MODULE = OS2::DLL		PACKAGE = OS2::DLL
+
+BOOT:
+    needstrs(8);
+    trace = getenv("PERL_REXX_DEBUG");
+
+SV *
+_call(name, address, queue="SESSION", ...)
+	char *		name
+	void *		address
+	char *		queue
+ CODE:
+   {
+       ULONG	rc;
+       int	argc, i;
+       RXSTRING	result;
+       UCHAR	resbuf[256];
+       RexxFunctionHandler *fcn = address;
+       argc = items-3;
+       needstrs(argc);
+       if (trace)
+	   fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
+       for (i = 0; i < argc; ++i) {
+	   STRLEN len;
+	   char *ptr = SvPV(ST(3+i), len);
+	   MAKERXSTRING(strs[i], ptr, len);
+	   if (trace)
+	       fprintf(stderr, " '%.*s'", len, ptr);
+       }
+       if (!*queue)
+	   queue = "SESSION";
+       if (trace)
+	   fprintf(stderr, "\n");
+       MAKERXSTRING(result, resbuf, sizeof resbuf);
+       rc = fcn(name, argc, strs, queue, &result);
+       if (trace)
+	   fprintf(stderr, "  rc=%X, result='%.*s'\n", rc,
+		   result.strlength, result.strptr);
+       ST(0) = sv_newmortal();
+       if (rc == 0) {
+	   if (result.strptr)
+	       sv_setpvn(ST(0), result.strptr, result.strlength);
+	   else
+	       sv_setpvn(ST(0), "", 0);
+       }
+       if (result.strptr && result.strptr != resbuf)
+	   DosFreeMem(result.strptr);
+   }
+
diff --git a/os2/OS2/REXX/DLL/MANIFEST b/os2/OS2/REXX/DLL/MANIFEST
new file mode 100644
index 0000000000..d7ad9b6338
--- /dev/null
+++ b/os2/OS2/REXX/DLL/MANIFEST
@@ -0,0 +1,5 @@
+Changes
+MANIFEST
+Makefile.PL
+DLL.pm
+DLL.xs
diff --git a/os2/OS2/REXX/DLL/Makefile.PL b/os2/OS2/REXX/DLL/Makefile.PL
new file mode 100644
index 0000000000..fe2403d0c2
--- /dev/null
+++ b/os2/OS2/REXX/DLL/Makefile.PL
@@ -0,0 +1,9 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+	      NAME => 'OS2::DLL',
+	      VERSION => '0.01',
+	      MAN3PODS 	=> ' ', 	# Pods will be built by installman.
+	      XSPROTOARG => '-noprototypes',
+	      PERL_MALLOC_OK => 1,
+);
diff --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL
index 5eda5a35d1..6648b2c575 100644
--- a/os2/OS2/REXX/Makefile.PL
+++ b/os2/OS2/REXX/Makefile.PL
@@ -2,7 +2,7 @@ use ExtUtils::MakeMaker;
 
 WriteMakefile(
 	      NAME => 'OS2::REXX',
-	      VERSION => '0.21',
+	      VERSION => '0.22',
 	      MAN3PODS 	=> ' ', 	# Pods will be built by installman.
 	      XSPROTOARG => '-noprototypes',
 	      PERL_MALLOC_OK => 1,
diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm
index 4580ede294..5c6dfd226f 100644
--- a/os2/OS2/REXX/REXX.pm
+++ b/os2/OS2/REXX/REXX.pm
@@ -3,6 +3,8 @@ package OS2::REXX;
 use Carp;
 require Exporter;
 require DynaLoader;
+require OS2::DLL;
+
 @ISA = qw(Exporter DynaLoader);
 # Items to export into callers namespace by default
 # (move infrequently used names to @EXPORT_OK below)
@@ -10,66 +12,18 @@ require DynaLoader;
 # Other items we are prepared to export if requested
 @EXPORT_OK = qw(drop);
 
-sub AUTOLOAD {
-    $AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/
-      or confess("Undefined subroutine &$AUTOLOAD called");
-    return undef if $1 eq "DESTROY";
-    $_[0]->find($1)
-      or confess("Can't find entry '$1' to DLL '$_[0]->{File}'");
-    goto &$AUTOLOAD;
-}
+# We cannot just put OS2::DLL in @ISA, since some scripts would use
+# function interface, not method interface...
 
-@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
-%dlls = ();
+*_call = \&OS2::DLL::_call;
+*load = \&OS2::DLL::load;
+*find = \&OS2::DLL::find;
 
 bootstrap OS2::REXX;
 
 # Preloaded methods go here.  Autoload methods go after __END__, and are
 # processed by the autosplit program.
 
-# Cannot autoload, the autoloader is used for the REXX functions.
-
-sub load
-{
-	confess 'Usage: load OS2::REXX <file> [<dirs>]' unless $#_ >= 1;
-	my ($class, $file, @where) = (@_, @libs);
-	return $dlls{$file} if $dlls{$file};
-	my $handle;
-	foreach (@where) {
-		$handle = DynaLoader::dl_load_file("$_/$file.dll");
-		last if $handle;
-	}
-	$handle = DynaLoader::dl_load_file($file) unless $handle;
-	return undef unless $handle;
-	eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');"
-	   . "sub AUTOLOAD {"
-	   . "  \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;"
-	   . "  goto &OS2::REXX::AUTOLOAD;"
-	   . "} 1;" or die "eval package $@";
-	return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file";
-}
-
-sub find
-{
-	my $self   = shift;
-	my $file   = $self->{File};
-	my $handle = $self->{Handle};
-	my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
-	my $queue  = $self->{Queue};
-	foreach (@_) {
-		my $name = "OS2::REXX::${file}::$_";
-		next if defined(&$name);
-		my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_)
-		        || DynaLoader::dl_find_symbol($handle, $prefix.$_)
-			or return 0;
-		eval "package OS2::REXX::$file; sub $_".
-		     "{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }".
-		     "1;"
-			or die "eval sub";
-	}
-	return 1;
-}
-
 sub prefix
 {
 	my $self = shift;
@@ -386,4 +340,8 @@ See C<t/rx*.t> for examples.
 Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich
 ilya@math.ohio-state.edu.
 
+=head1 SEE ALSO
+
+L<OS2::DLL>.
+
 =cut
diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs
index 9f2371488c..8a8e5f2da0 100644
--- a/os2/OS2/REXX/REXX.xs
+++ b/os2/OS2/REXX/REXX.xs
@@ -236,49 +236,6 @@ constant(name,arg)
 	char *		name
 	int		arg
 
-SV *
-_call(name, address, queue="SESSION", ...)
-	char *		name
-	void *		address
-	char *		queue
- CODE:
-   {
-       ULONG	rc;
-       int	argc, i;
-       RXSTRING	result;
-       UCHAR	resbuf[256];
-       RexxFunctionHandler *fcn = address;
-       argc = items-3;
-       needstrs(argc);
-       if (trace)
-	   fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
-       for (i = 0; i < argc; ++i) {
-	   STRLEN len;
-	   char *ptr = SvPV(ST(3+i), len);
-	   MAKERXSTRING(strs[i], ptr, len);
-	   if (trace)
-	       fprintf(stderr, " '%.*s'", len, ptr);
-       }
-       if (!*queue)
-	   queue = "SESSION";
-       if (trace)
-	   fprintf(stderr, "\n");
-       MAKERXSTRING(result, resbuf, sizeof resbuf);
-       rc = fcn(name, argc, strs, queue, &result);
-       if (trace)
-	   fprintf(stderr, "  rc=%X, result='%.*s'\n", rc,
-		   result.strlength, result.strptr);
-       ST(0) = sv_newmortal();
-       if (rc == 0) {
-	   if (result.strptr)
-	       sv_setpvn(ST(0), result.strptr, result.strlength);
-	   else
-	       sv_setpvn(ST(0), "", 0);
-       }
-       if (result.strptr && result.strptr != resbuf)
-	   DosFreeMem(result.strptr);
-   }
-
 int
 _set(name,value,...)
 	char *		name
diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t
index 9d81bf3e56..15362d78e9 100644
--- a/os2/OS2/REXX/t/rx_dllld.t
+++ b/os2/OS2/REXX/t/rx_dllld.t
@@ -16,7 +16,7 @@ foreach $dir (split(';', $path)) {
   $found = "$dir/YDBAUTIL.DLL";
   last;
 }
-$found or die "1..0\n#Cannot find YDBAUTIL.DLL\n";
+$found or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
 
 print "1..5\n";
 
diff --git a/os2/OS2/REXX/t/rx_emxrv.t b/os2/OS2/REXX/t/rx_emxrv.t
new file mode 100644
index 0000000000..d51e1b0e32
--- /dev/null
+++ b/os2/OS2/REXX/t/rx_emxrv.t
@@ -0,0 +1,24 @@
+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..5\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";
diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t
index cb3c52a8b6..8bdf90564d 100644
--- a/os2/OS2/REXX/t/rx_objcall.t
+++ b/os2/OS2/REXX/t/rx_objcall.t
@@ -13,7 +13,8 @@ use OS2::REXX;
 #
 # DLL
 #
-$ydba = load OS2::REXX "ydbautil" or die "1..0\n# load\n";
+$ydba = load OS2::REXX "ydbautil" 
+  or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
 print "1..5\n", "ok 1\n";
 
 #
diff --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t
index 77f90c2f59..5f43f4e5fc 100644
--- a/os2/OS2/REXX/t/rx_tievar.t
+++ b/os2/OS2/REXX/t/rx_tievar.t
@@ -13,7 +13,8 @@ use OS2::REXX;
 #
 # DLL
 #
-load OS2::REXX "ydbautil" or die "1..0\n# load\n";
+load OS2::REXX "ydbautil"
+  or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
 
 print "1..19\n";
 
diff --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t
index 30a2dafb62..1653a2081c 100644
--- a/os2/OS2/REXX/t/rx_tieydb.t
+++ b/os2/OS2/REXX/t/rx_tieydb.t
@@ -9,7 +9,9 @@ BEGIN {
 }
 
 use OS2::REXX;
-$rx = load OS2::REXX "ydbautil" or die "1..0\n# load\n";    # from RXU17.ZIP
+$rx = load OS2::REXX "ydbautil"     # from RXU17.ZIP
+  or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
+
 print "1..7\n", "ok 1\n";
 
 $rx->prefix("Rx");                         # implicit function prefix
diff --git a/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t
index 04ca6636db..b0621f4e22 100644
--- a/os2/OS2/REXX/t/rx_vrexx.t
+++ b/os2/OS2/REXX/t/rx_vrexx.t
@@ -18,7 +18,7 @@ foreach $dir (split(';', $path)) {
   print "# found at `$found'\n";
   last;
 }
-$found or die "1..0\n#Cannot find $name.DLL\n";
+$found or print "1..0 # skipped: cannot find $name.DLL\n" and exit;
 
 print "1..10\n";