--- perl-5.8.7-patched/os2/os2ish.h	Mon Nov 27 20:59:10 2006
+++ perl-5.8.7/os2/os2ish.h	Sun Nov 19 00:43:12 2006
@@ -514,6 +514,12 @@ int	Perl_Serve_Messages(int force);
 /* Cannot prototype with I32 at this point. */
 int	Perl_Process_Messages(int force, long *cntp);
 char	*os2_execname(pTHX);
+char *  getenv_4perl_buf(char *b, int len, char *beg, char *mid, char *end, char *pre_v, char *int_v, char *post_v);
+
+#define getenv_4perl(beg, mid, end, pre_v, int_v, post_v) \
+	getenv_4perl_buf(NULL, 0, beg, mid, end, pre_v, int_v, post_v)
+
+#define getenv_v(beg, mid, end)	getenv_4perl(beg, mid, end, "_", "_", "_")
 
 struct _QMSG;
 struct PMWIN_entries_t {
@@ -699,6 +705,9 @@ enum entries_ordinals {
     ORD_DosReplaceModule,
     ORD_DosPerfSysCall,
     ORD_RexxRegisterSubcomExe,
+    ORD_WinQueryClassInfo,
+    ORD_WinQuerySysModalWindow,
+    ORD_WinSetSysModalWindow,
     ORD_NENTRIES
 };
 
@@ -812,11 +821,11 @@ void croak_with_os2error(char *s) __attr
 
 /* propagates rc */
 #define os2win_croak(rc,msg)						\
-	SaveCroakWinError((expr), 1 /* die */, /* no prefix */, (msg))
+	SaveCroakWinError((rc), 1 /* die */, /* no prefix */, (msg))
 
 /* propagates rc; use with functions which may return 0 on success */
 #define os2win_croak_0OK(rc,msg)					\
-	SaveCroakWinError((ResetWinError, (expr)),			\
+	SaveCroakWinError((ResetWinError, (rc)),			\
 			  1 /* die */, /* no prefix */, (msg))
 
 #ifdef PERL_CORE
--- perl-5.8.7-patched/os2/os2.c	Mon Nov 27 20:59:10 2006
+++ perl-5.8.7/os2/os2.c	Sat Oct 21 15:37:24 2006
@@ -638,6 +638,9 @@ static const struct {
   {&doscalls_handle, NULL, 417},	/* DosReplaceModule */
   {&doscalls_handle, NULL, 976},	/* DosPerfSysCall */
   {&rexxapi_handle, "RexxRegisterSubcomExe", 0},
+  {&pmwin_handle, NULL, 925},		/* WinQueryClassInfo */
+  {&pmwin_handle, NULL, 827},		/* WinQuerySysModalWindow */
+  {&pmwin_handle, NULL, 872},		/* WinSetSysModalWindow */
 };
 
 HMODULE
@@ -694,7 +697,7 @@ loadByOrdinal(enum entries_ordinals ord,
 
 	if (!loadOrdinals[ord].dll->handle) {
 	    if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
-		char *s = getenv("PERL_ASIF_PM");
+		char *s = getenv_v("PERL", "_", "ASIF_PM");
 		
 		if (!s || !atoi(s)) {
 		    /* The module will not function well without PM.
@@ -2097,6 +2100,9 @@ os2error(int rc)
 	    case PMERR_INVALID_HMQ:
 		name = "PMERR_INVALID_HMQ";
 		break;
+	    case PMERR_PARAMETER_OUT_OF_RANGE:
+		name = "PMERR_PARAMETER_OUT_OF_RANGE";
+		break;
 	    case PMERR_CALL_FROM_WRONG_THREAD:
 		name = "PMERR_CALL_FROM_WRONG_THREAD";
 		break;
@@ -2140,6 +2146,34 @@ os2error(int rc)
 	return os2error_buf;
 }
 
+XS(XS_OS2_getMessage); /* prototype to pass -Wmissing-prototypes */
+XS(XS_OS2_getMessage)
+{
+    dXSARGS;
+    if (items < 2)
+	Perl_croak(aTHX_ "Usage: OS2::getMessage(f, num, ...)");
+    if (items > 11)
+	Perl_croak(aTHX_ "OS2::getMessage() with more than 9 insertion strings");
+    {
+	char *ins[9];
+	char buf[4096];
+	dXSTARG;
+	char *	f = (char *)SvPV_nolen(ST(0));
+	int	num = (int)SvIV(ST(1)), c = 0;
+	STRLEN  n_a;
+	ULONG len, rc;
+
+	while (c < items - 2) {
+	    ins[c] = SvPV(ST(c + 1), n_a);
+	    c++;
+	}
+	os2cp_croak(DosGetMessage(ins, c, buf, sizeof(buf), num, f, &len),
+		    "DosGetMessage");
+	sv_setpvn(TARG, buf, len); XSprePUSH; PUSHTARG;
+    }
+    XSRETURN(1);
+}
+
 void
 ResetWinError(void)
 {
@@ -2390,23 +2424,47 @@ perllib_mangle_with(char *s, unsigned in
 }
 
 char *
+getenv_4perl_buf(char *buf, int len, char *beg, char *mid, char *end, char *pre_v, char *int_v, char *post_v)
+{
+    char *ret;
+    char b[256];
+    int l;
+
+    if (!buf) {
+	buf = b;
+	len = sizeof(b);
+    }
+    l = snprintf(buf, len, "%s%s%s%s%s%s%s%s%s",
+		 beg, pre_v, STRINGIFY(PERL_REVISION), int_v,
+		 STRINGIFY(PERL_VERSION), int_v,
+		 STRINGIFY(PERL_SUBVERSION), post_v, end);
+    if (l >= 0 && (ret = getenv(buf)))
+	return ret;
+    l = snprintf(buf, len, "%s%s%s%s%s%s%s",
+		 beg, pre_v, STRINGIFY(PERL_REVISION), int_v,
+		 STRINGIFY(PERL_VERSION), post_v, end);
+    if (l >= 0 && (ret = getenv(buf)))
+	return ret;
+    l = snprintf(buf, len, "%s%s%s%s%s",
+		 beg, pre_v, STRINGIFY(PERL_REVISION), post_v, end);
+    if (l >= 0 && (ret = getenv(buf)))
+	return ret;
+    l = snprintf(buf, len, "%s%s%s", beg, mid, end);
+    if (l < 0)
+	return NULL;
+    return getenv(buf);
+}
+
+char *
 perllib_mangle(char *s, unsigned int l)
 {
-    char *name;
+    char name[256], *nm;
 
-    if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l)))
-	return name;
+    if (perllib_mangle_installed && (nm = perllib_mangle_installed(s,l)))
+	return nm;
     if (!newp && !notfound) {
-	newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
-		      STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
-		      "_PREFIX");
-	if (!newp)
-	    newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
-			  STRINGIFY(PERL_VERSION) "_PREFIX");
-	if (!newp)
-	    newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
-	if (!newp)
-	    newp = getenv(name = "PERLLIB_PREFIX");
+	newp = getenv_4perl_buf(name, sizeof(name), "PERLLIB", "_", "PREFIX",
+				"_", "_", "_");
 	if (newp) {
 	    char *s, b[300];
 	    
@@ -3630,7 +3688,7 @@ ExtLIBPATH(ULONG ord, PSZ path, IV type,
     (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) )
 
 #define extLibpath_set(p,type, fatal) 					\
-    (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal)))
+    (CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal)))
 
 static void
 early_error(char *msg1, char *msg2, char *msg3)
@@ -3694,7 +3752,7 @@ XS(XS_Cwd_extLibpath_set)
 	    type = SvIV(ST(1));
 	}
 
-	RETVAL = extLibpath_set(s, type, 1);	/* Make errors fatal */
+	RETVAL = !extLibpath_set(s, type, 1);	/* Make errors fatal */
 	ST(0) = boolSV(RETVAL);
 	if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
     }
@@ -3883,8 +3941,9 @@ XS(XS_OS2_libPath)
     {
 	ULONG	size;
 	STRLEN	n_a;
+	char   *s;
 
-	if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size), 
+	if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
 				   DQHI_QUERYLIBPATHSIZE)) 
 	    Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
 		       DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
@@ -3892,14 +3951,16 @@ XS(XS_OS2_libPath)
 	ST(0) = newSVpvn("",0);
 	SvGROW(ST(0), size + 1);
 	sv_2mortal(ST(0));
+	s = SvPV(ST(0), n_a);
 
 	/* We should be careful: apparently, this entry point does not
 	   pay attention to the size argument, so may overwrite
 	   unrelated data! */
-	if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
-				   DQHI_QUERYLIBPATH)) 
+	if (!_Dos32QueryHeaderInfo(0, 0, s, size, DQHI_QUERYLIBPATH)) 
 	    Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
 		       DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
+	if (size && s[size-1] == 0)
+	    size--;
 	SvCUR_set(ST(0), size);
 	*SvEND(ST(0)) = 0;
     }
@@ -4255,7 +4316,7 @@ XS(XS_OS2_pipe)
 
 	if (connect)
 	    connectNPipe(hpipe, connect, 1, 0);	/* XXXX wait, retval */
-	hpipe = __imphandle(hpipe);
+	hpipe = _imphandle(hpipe);	/* Register with EMX */
 
 	perlio = PerlIO_fdopen(hpipe, buf);
 	ST(0) = sv_newmortal();
@@ -4274,7 +4335,7 @@ XS(XS_OS2_pipeCntl); /* prototype to pas
 XS(XS_OS2_pipeCntl)
 {
     dXSARGS;
-    if (items < 2 || items > 3)
+    if (items < 2 || items > 4)
 	Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
     {
 	ULONG	rc;
@@ -4284,7 +4345,7 @@ XS(XS_OS2_pipeCntl)
 	STRLEN	len;
 	char	*s = SvPV(ST(1), len);
 	int	wait = 0, disconnect = 0, connect = 0, message = -1, query = 0;
-	int	peek = 0, state = 0, info = 0;
+	int	peek = 0, state = 0, info = 0, transact = 0, resetbuffer = 0;
 
 	if (fn < 0)
 	    Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe");	
@@ -4297,6 +4358,8 @@ XS(XS_OS2_pipeCntl)
 		message = 0;
 	    else if (strEQ(s, "peek"))
 		peek = 1;
+	    else if (strEQ(s, "call"))
+		transact = 1;
 	    else if (strEQ(s, "info"))
 		info = 1;
 	    else
@@ -4328,13 +4391,20 @@ XS(XS_OS2_pipeCntl)
 		goto unknown;
 	    disconnect = 1;
 	    break;
+	case 11:
+	    if (!strEQ(s, "resetbuffer"))
+		goto unknown;
+	    resetbuffer = 1;
+	    break;
 	default:
 	  unknown:
 	    Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s);
 	    break;
 	}
 
-	if (items == 3 && !connect)
+	if (items > 3 && !transact)
+	    Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
+	if (items == 3 && !connect && !transact)
 	    Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s);
 
 	XSprePUSH;		/* Do not need arguments any more */
@@ -4342,10 +4412,8 @@ XS(XS_OS2_pipeCntl)
 	    os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()");
 	    PerlIO_clearerr(perlio);
 	}
-	if (connect) {
-	    if (!connectNPipe(hpipe, wait , 1, 0))
+	if (connect && !connectNPipe(hpipe, wait , 1, 0))
 		XSRETURN_IV(-1);
-	}
 	if (query) {
 	    ULONG flags;
 
@@ -4424,6 +4492,32 @@ XS(XS_OS2_pipeCntl)
 	    if (flags != oflags)
 		os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
 	}
+	if (transact) {			/* Needs to be duplex + message mode */
+	    ULONG got;
+	    STRLEN l;
+	    char *s;
+	    char buf[8192];
+	    STRLEN ll = sizeof(buf);
+	    char *b = buf;
+
+	    if (items < 3 || items > 4)
+		Perl_croak(aTHX_ "usage: OS2::pipeCntl(handle, 'call', write [, readbuffsize = 8192])");
+	    s = SvPV(ST(2), l);
+	    if (items >= 4) {
+		STRLEN lll = SvUV(ST(3));
+		SV *sv = NEWSV(914, lll);
+
+		sv_2mortal(sv);
+		ll = lll;
+		b = SvPVX(sv);
+	    }	    
+
+	    os2cp_croak(DosTransactNPipe(hpipe, s, l, b, ll, &got),
+			"DosTransactNPipe()");
+	    XSRETURN_PVN(b, got);
+	}
+	if (resetbuffer)
+	    os2cp_croak(DosResetBuffer(hpipe), "DosResetBuffer");
     }
     XSRETURN_YES;
 }
@@ -4467,25 +4561,23 @@ XS(XS_OS2_open)
 
 	if (items < 4)
 	    ulAttribute = FILE_NORMAL;
-	else {
+	else
 	    ulAttribute = (ULONG)SvUV(ST(3));
-	}
 
 	if (items < 5)
 	    ulFileSize = 0;
-	else {
+	else
 	    ulFileSize = (ULONG)SvUV(ST(4));
-	}
 
 	if (items < 6)
 	    pEABuf = NULL;
-	else {
+	else
 	    pEABuf = (PEAOP2)SvUV(ST(5));
-	}
 
 	RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf);
 	if (CheckOSError(RETVAL))
 	    croak_with_os2error("OS2::open() error");
+	hFile = _imphandle(hFile);	/* Register with EMX */
 	XSprePUSH;	EXTEND(SP,2);
 	PUSHs(sv_newmortal());
 	sv_setuv(ST(0), (UV)hFile);
@@ -4547,8 +4639,9 @@ Xs_OS2_init(pTHX)
         newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
         newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
         newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$");
-        newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$");
+        newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$$");
         newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$");
+        newXSproto("OS2::getMessage", XS_OS2_getMessage, file, "$$;@");
 	gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
 	GvMULTI_on(gv);
 #ifdef PERL_IS_AOUT
@@ -4946,11 +5039,11 @@ Perl_OS2_init3(char **env, void **preg, 
 
 	New(1304, PL_sh_path, l + 1, char);
 	memcpy(PL_sh_path, perl_sh_installed, l + 1);
-    } else if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+    } else if ( (shell = getenv("PERL_SH_DRIVE")) ) { /* OBSOLETE */
 	New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
 	strcpy(PL_sh_path, SH_PATH);
 	PL_sh_path[0] = shell[0];
-    } else if ( (shell = getenv("PERL_SH_DIR")) ) {
+    } else if ( (shell = getenv_v("PERL", "_", "SH_DIR")) ) {
 	int l = strlen(shell), i;
 
 	while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
@@ -4970,22 +5063,31 @@ Perl_OS2_init3(char **env, void **preg, 
     os2_mytype_ini = os2_mytype;
     Perl_os2_initial_mode = -1;		/* Uninit */
 
-    s = getenv("PERL_BEGINLIBPATH");
+    s = getenv_v("PERL", "_", "BEGINLIBPATH");
     if (s)
       rc = fill_extLibpath(0, s, NULL, 1, "PERL_BEGINLIBPATH");
     else
-      rc = fill_extLibpath(0, getenv("PERL_PRE_BEGINLIBPATH"), getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH");
+      rc = fill_extLibpath(0, getenv_v("PERL", "_", "PRE_BEGINLIBPATH"),
+			   getenv_v("PERL", "_", "POST_BEGINLIBPATH"),
+			   0, "PERL_(PRE/POST)_BEGINLIBPATH");
     if (!rc) {
-	s = getenv("PERL_ENDLIBPATH");
+	s = getenv_v("PERL", "_", "ENDLIBPATH");
 	if (s)
 	    rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH");
 	else
-	    rc = fill_extLibpath(1, getenv("PERL_PRE_ENDLIBPATH"), getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH");
+	    rc = fill_extLibpath(1, getenv_v("PERL", "_", "PRE_ENDLIBPATH"),
+				 getenv_v("PERL", "_", "POST_ENDLIBPATH"),
+				 0, "PERL_(PRE/POST)_ENDLIBPATH");
+	if (!rc) {
+	    s = getenv_v("PERL", "_", "LIBPATHSTRICT");
+	    if (s)
+		rc = extLibpath_set(s, -1, 0);
+	}
     }
     if (rc) {
 	char buf[1024];
 
-	snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n",
+	snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH/STRICT: %s\n",
 		 os2error(rc));
 	DosWrite(2, buf, strlen(buf), &rc);
 	exit(2);
@@ -5128,7 +5230,7 @@ my_flock(int handle, int o)
   if (use_my_flock == -1) {
    MUTEX_LOCK(&perlos2_state_mutex);
    if (use_my_flock == -1) {
-    char *s = getenv("USE_PERL_FLOCK");
+    char *s = getenv_v("USE_PERL", "_", "FLOCK");
     if (s)
 	use_my_flock = atoi(s);
     else 
@@ -5234,7 +5336,7 @@ static int
 use_my_pwent(void)
 {
   if (_my_pwent == -1) {
-    char *s = getenv("USE_PERL_PWENT");
+    char *s = getenv_v("USE", "_", "PERL_PWENT");
     if (s)
 	_my_pwent = atoi(s);
     else 
--- perl-5.8.7-patched/os2/os2_pipe.t	Mon Nov 27 20:59:10 2006
+++ perl-5.8.7/os2/os2_pipe.t	Sun Oct  8 02:48:42 2006
@@ -148,18 +148,23 @@ is "@in", "@exp", 'expected data';
 # Can't switch to message mode if created in byte mode...
 ok close $server_pipe, 'server close';
 ok $server_pipe = OS2::pipe($pname, 'RW'), 'create pipe in message mode';
+
 ok OS2::pipeCntl($server_pipe, 'byte'),    'can switch to byte mode';
 ok OS2::pipeCntl($server_pipe, 'message'), 'can switch to message mode';
 
 $pid = system 4|0x40000, $^X, '-wle', <<'EOS', $pname, $$; # SESSION|INDEPENDENT
-END {sleep 2}
-my ($name, $ppid) = (shift, shift);
-$name =~ s,/,\\,g;
-$name = uc $name;
-warn "OS2::pipe $name, 'call', ...\n";
-my $got = OS2::pipe $name, 'call', "Is your pid $ppid?\n";
-my $ok = $got eq 'Yes';
-OS2::pipe $name, 'call', $ok ? "fine\n" : "bad\n";
+  END {sleep 2}
+  my ($name, $ppid) = (shift, shift);
+  $name =~ s,/,\\,g;
+  $name = uc $name;
+  warn "OS2::pipe $name, 'call', ...\n";
+  my $got = OS2::pipe $name, 'call', "Is your pid $ppid?\n";
+  my $ok = $got eq 'Yes';
+  warn "OS2::pipe $name, 'wait'\n";
+  OS2::pipe $name, 'wait';
+  my $ok1 = open my $fh, '+<', $name or (warn "open `$name': $!");
+  warn "OS2::pipeCntl fileno($name), 'call', ...\n";
+  OS2::pipeCntl $fh, 'call', ($ok && $ok1) ? "fine\n" : "bad\n";
 EOS
 
 ok $pid, 'kid started';
