Re: [PATCH 5.005_62] OS/2 improvements

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

p4raw-id: //depot/perl@4432

19 files changed, 387 insertions, 131 deletions

diff --git a/os2/Changes b/os2/Changes
index 910ec467f4..e56b7081ff 100644
--- a/os2/Changes
+++ b/os2/Changes
@@ -296,3 +296,29 @@ after 5.005_54:
  
  	If the only shell-metachars of a command are ' 2>&1' at the
  	end of a command, it is executed without calling the external shell.
+
+after 5.005_57:
+	Make UDP sockets return correct caller address (OS2 API bug);
+	Enable TCPIPV4 defines (works with Warp 3 IAK too?!);
+	Force Unix-domain sockets to start with "/socket", convert
+	  '/' to '\' in the calls;
+	Make C<system 1, $cmd> to treat $cmd as in C<system $cmd>;
+	Autopatch Configure;
+	Find name and location of g[nu]patch.exe;
+	Autocopy perl????.dll to t/ when testing;
+
+after 5.005_62:
+	Extract a lightweight DLL access module OS2::DLL from OS2::REXX
+	   which would not load REXX runtime system;
+	Allow compile with os2.h which loads os2tk.h instead of os2emx.h;
+	Put the version of EMX CRTL into -D define;
+	Use _setsyserror() to store last error of OS/2 API for $^E;
+	New macro PERL_SYS_INIT3(argvp, argcp, envp);
+	Make Dynaloader return info on the failing module after failed dl_open();
+	OS2::REXX test were done for interactive testing (were writing
+	  "ok" to stderr);
+	system() and friends return -1 on failure (was 0xFF00);
+	Put the full name of executable into $^X
+	  (alas, uppercased - but with /);
+	t/io/fs.t was failing on HPFS386;
+	Remove extra ';' from defines for MQ operations.
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";
 
diff --git a/os2/dl_os2.c b/os2/dl_os2.c
index 19f36f6aa7..4a9688cb59 100644
--- a/os2/dl_os2.c
+++ b/os2/dl_os2.c
@@ -4,15 +4,16 @@
 #include <os2.h>
 
 static ULONG retcode;
+static char fail[300];
 
 void *
 dlopen(char *path, int mode)
 {
 	HMODULE handle;
 	char tmp[260], *beg, *dot;
-	char fail[300];
 	ULONG rc;
 
+	fail[0] = 0;
 	if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
 		return (void *)handle;
 
@@ -42,6 +43,7 @@ dlsym(void *handle, char *symbol)
 	ULONG rc, type;
 	PFN addr;
 
+	fail[0] = 0;
 	rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
 	if (rc == 0) {
 		rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
@@ -56,15 +58,31 @@ dlsym(void *handle, char *symbol)
 char *
 dlerror(void)
 {
-	static char buf[300];
+	static char buf[700];
 	ULONG len;
 
 	if (retcode == 0)
 		return NULL;
-	if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
-		sprintf(buf, "OS/2 system error code %d", retcode);
-	else
+	if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode,
+			  "OSO001.MSG", &len)) {
+		if (fail[0])
+		  sprintf(buf, 
+"OS/2 system error code %d, possible problematic module: '%s'",
+			  retcode, fail);
+		else
+		  sprintf(buf, "OS/2 system error code %d", retcode);
+	} else {
 		buf[len] = '\0';
+		if (len && buf[len - 1] == '\n')
+			buf[--len] = 0;
+		if (len && buf[len - 1] == '\r')
+			buf[--len] = 0;
+		if (len && buf[len - 1] == '.')
+			buf[--len] = 0;
+		if (fail[0] && len < 300)
+		  sprintf(buf + len, ", possible problematic module: '%s'",
+			  fail);
+	}
 	retcode = 0;
 	return buf;
 }
diff --git a/os2/os2.c b/os2/os2.c
index 7c23200633..8a17ae714e 100644
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -3,6 +3,10 @@
 #define INCL_DOSFILEMGR
 #define INCL_DOSMEMMGR
 #define INCL_DOSERRORS
+/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
+#define INCL_DOSPROCESS
+#define SPU_DISABLESUPPRESSION          0
+#define SPU_ENABLESUPPRESSION           1
 #include <os2.h>
 
 #include <sys/uflags.h>
@@ -802,7 +806,7 @@ U32 addflag;
 		 PL_Argv[0], Strerror(errno));
 	if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) 
 	    && ((trueflag & 0xFF) == P_WAIT)) 
-	    rc = 255 << 8; /* Emulate the fork(). */
+	    rc = -1;
 
   finish:
     if (new_stderr != -1) {	/* How can we use error codes? */
@@ -907,7 +911,8 @@ do_spawn3(char *cmd, int execf, int flag)
 		    Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", 
 			 (execf == EXECF_SPAWN ? "spawn" : "exec"),
 			 shell, Strerror(errno));
-		if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
+		if (rc < 0)
+		    rc = -1;
 	    }
 	    if (news)
 		Safefree(news);
@@ -1356,18 +1361,37 @@ os2error(int rc)
 		return NULL;
 	if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
 		sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
-	else
+	else {
 		buf[len] = '\0';
-	if (len > 0 && buf[len - 1] == '\n')
-	    buf[len - 1] = '\0';
-	if (len > 1 && buf[len - 2] == '\r')
-	    buf[len - 2] = '\0';
-	if (len > 2 && buf[len - 3] == '.')
-	    buf[len - 3] = '\0';
+		if (len && buf[len - 1] == '\n')
+			buf[--len] = 0;
+		if (len && buf[len - 1] == '\r')
+			buf[--len] = 0;
+		if (len && buf[len - 1] == '.')
+			buf[--len] = 0;
+	}
 	return buf;
 }
 
 char *
+os2_execname(void)
+{
+  char buf[300], *p;
+
+  if (_execname(buf, sizeof buf) != 0)
+	return PL_origargv[0];
+  p = buf;
+  while (*p) {
+    if (*p == '\\')
+	*p = '/';
+    p++;
+  }
+  p = savepv(buf);
+  SAVEFREEPV(p);
+  return p;
+}
+
+char *
 perllib_mangle(char *s, unsigned int l)
 {
     static char *newp, *oldp;
@@ -2067,7 +2091,7 @@ Perl_OS2_init(char **env)
     settmppath();
     OS2_Perl_data.xs_init = &Xs_OS2_init;
     _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
-    if (environ == NULL) {
+    if (environ == NULL && env) {
 	environ = env;
     }
     if ( (shell = getenv("PERL_SH_DRIVE")) ) {
diff --git a/os2/os2ish.h b/os2/os2ish.h
index 6993dfca5d..23b109670f 100644
--- a/os2/os2ish.h
+++ b/os2/os2ish.h
@@ -183,16 +183,26 @@ void Perl_OS2_init(char **);
 
 /* XXX This code hideously puts env inside: */
 
-#ifdef __EMX__
+#ifdef PERL_CORE
+#  define PERL_SYS_INIT3(argcp, argvp, envp) STMT_START {	\
+    _response(argcp, argvp);			\
+    _wildcard(argcp, argvp);			\
+    Perl_OS2_init(*envp);	} STMT_END
 #  define PERL_SYS_INIT(argcp, argvp) STMT_START {	\
     _response(argcp, argvp);			\
     _wildcard(argcp, argvp);			\
-    Perl_OS2_init(env);	} STMT_END
-#else  /* Compiling embedded Perl with non-EMX compiler */
+    Perl_OS2_init(NULL);	} STMT_END
+#else  /* Compiling embedded Perl or Perl extension */
+#  define PERL_SYS_INIT3(argcp, argvp, envp) STMT_START {	\
+    Perl_OS2_init(*envp);	} STMT_END
 #  define PERL_SYS_INIT(argcp, argvp) STMT_START {	\
-    Perl_OS2_init(env);	} STMT_END
+    Perl_OS2_init(NULL);	} STMT_END
+#endif
+
+#ifndef __EMX__
 #  define PERL_CALLCONV _System
 #endif
+
 #define PERL_SYS_TERM()		MALLOC_TERM
 
 /* #define PERL_SYS_TERM() STMT_START {	\
@@ -318,6 +328,7 @@ extern OS2_Perl_data_t OS2_Perl_data;
 #define Perl_rc			(OS2_Perl_data.rc)
 #define Perl_severity		(OS2_Perl_data.severity)
 #define errno_isOS2		12345678
+#define errno_isOS2_set		12345679
 #define OS2_Perl_flags	(OS2_Perl_data.flags)
 #define Perl_HAB_set_f	1
 #define Perl_HAB_set	(OS2_Perl_flags & Perl_HAB_set_f)
@@ -339,6 +350,7 @@ void	Perl_Deregister_MQ(int serve);
 int	Perl_Serve_Messages(int force);
 /* Cannot prototype with I32 at this point. */
 int	Perl_Process_Messages(int force, long *cntp);
+char	*os2_execname(void);
 
 struct _QMSG;
 struct PMWIN_entries_t {
@@ -356,23 +368,29 @@ struct PMWIN_entries_t {
 extern struct PMWIN_entries_t PMWIN_entries;
 void init_PMWIN_entries(void);
 
-#define perl_hmq_GET(serve)	Perl_Register_MQ(serve);
-#define perl_hmq_UNSET(serve)	Perl_Deregister_MQ(serve);
+#define perl_hmq_GET(serve)	Perl_Register_MQ(serve)
+#define perl_hmq_UNSET(serve)	Perl_Deregister_MQ(serve)
 
 #define OS2_XS_init() (*OS2_Perl_data.xs_init)()
+
+#if _EMX_CRT_REV_ >= 60
+# define os2_setsyserrno(rc)	(Perl_rc = rc, errno = errno_isOS2_set, \
+				_setsyserrno(rc))
+#else
+# define os2_setsyserrno(rc)	(Perl_rc = rc, errno = errno_isOS2)
+#endif
+
 /* The expressions below return true on error. */
 /* INCL_DOSERRORS needed. rc should be declared outside. */
 #define CheckOSError(expr) (!(rc = (expr)) ? 0 : (FillOSError(rc), 1))
 /* INCL_WINERRORS needed. */
 #define SaveWinError(expr) ((expr) ? : (FillWinError, 0))
 #define CheckWinError(expr) ((expr) ? 0: (FillWinError, 1))
-#define FillOSError(rc) (Perl_rc = rc,					\
-			errno = errno_isOS2,				\
+#define FillOSError(rc) (os2_setsyserrno(rc),				\
 			Perl_severity = SEVERITY_ERROR) 
-#define FillWinError (Perl_rc = WinGetLastError(Perl_hab),		\
-			errno = errno_isOS2,				\
-			Perl_severity = ERRORIDSEV(Perl_rc),		\
-			Perl_rc = ERRORIDERROR(Perl_rc)) 
+#define FillWinError (Perl_severity = ERRORIDSEV(Perl_rc),		\
+			Perl_rc = ERRORIDERROR(Perl_rc)),		\
+			os2_setsyserrno(Perl_rc)
 
 #define STATIC_FILE_LENGTH 127
 
@@ -392,7 +410,7 @@ char *os2error(int rc);
 #define QSS_FILE	8		/* Buggy until fixpack18 */
 #define QSS_SHARED	16
 
-#ifdef _OS2EMX_H
+#ifdef _OS2_H
 
 APIRET APIENTRY Dos32QuerySysState(ULONG func,ULONG arg1,ULONG pid,
 			ULONG _res_,PVOID buf,ULONG bufsz);
@@ -550,5 +568,5 @@ typedef struct {
 
 PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags);
 
-#endif /* _OS2EMX_H */
+#endif /* _OS2_H */