Integrate change #9030 from maintperl into mainline.

Subject: [PATCH 5.6.1] OS/2 cleanup

p4raw-link: @9030 on //depot/maint-5.6/perl: 2105755b4e61318e9489b9a118af8e270a8bc735

p4raw-id: //depot/perl@9031
p4raw-branched: from //depot/maint-5.6/perl@9029 'branch in'
	os2/os2add.sym
p4raw-integrated: from //depot/maint-5.6/perl@9029 'copy in'
	os2/Changes os2/OS2/REXX/REXX.pm os2/OS2/REXX/t/rx_cmprt.t
	os2/os2.sym (@5902..) os2/Makefile.SHs (@8153..)
	os2/OS2/REXX/REXX.xs os2/os2ish.h (@8606..) 'merge in'
	lib/ExtUtils/MM_OS2.pm os2/OS2/REXX/Makefile.PL (@5902..)
	MANIFEST (@8986..) makedef.pl (@8987..) os2/os2.c (@9016..)
	lib/ExtUtils/MM_Unix.pm (@9028..)

1 files changed, 164 insertions, 22 deletions

diff --git a/os2/os2.c b/os2/os2.c
index 50f0e1d45e..4ce933d81b 100644
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -8,6 +8,7 @@
 #define SPU_DISABLESUPPRESSION          0
 #define SPU_ENABLESUPPRESSION           1
 #include <os2.h>
+#include "dlfcn.h"
 
 #include <sys/uflags.h>
 
@@ -189,6 +190,16 @@ static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
 #define ORD_SET_ELP	1
 struct PMWIN_entries_t PMWIN_entries;
 
+HMODULE
+loadModule(char *modname)
+{
+    HMODULE h = (HMODULE)dlopen(modname, 0);
+    if (!h)
+	Perl_croak_nocontext("Error loading module '%s': %s", 
+			     modname, dlerror());
+    return h;
+}
+
 APIRET
 loadByOrd(char *modname, ULONG ord)
 {
@@ -198,11 +209,14 @@ loadByOrd(char *modname, ULONG ord)
 	PFN fcn;
 	APIRET rc;
 
-	if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, 
-						  modname, &hdosc)))
-	    || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
-	    Perl_croak_nocontext("This version of OS/2 does not support %s.%i", 
-		  modname, loadOrd[ord]);
+	
+	if (!hdosc) {
+	    hdosc = loadModule(modname);
+	    if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
+		Perl_croak_nocontext(
+			"This version of OS/2 does not support %s.%i", 
+			modname, loadOrd[ord]);	    
+	}
 	ExtFCN[ord] = fcn;
     } 
     if ((long)ExtFCN[ord] == -1) 
@@ -220,6 +234,8 @@ init_PMWIN_entries(void)
 	918,				/* PeekMsg */
 	915,				/* GetMsg */
 	912,				/* DispatchMsg */
+	753,				/* GetLastError */
+	705,				/* CancelShutdown */
     };
     BYTE buf[20];
     int i = 0;
@@ -228,9 +244,8 @@ init_PMWIN_entries(void)
     if (hpmwin)
 	return;
 
-    if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
-	Perl_croak_nocontext("This version of OS/2 does not support pmwin: error in %s", buf);
-    while (i <= 5) {
+    hpmwin = loadModule("pmwin");
+    while (i < sizeof(ords)/sizeof(int)) {
 	if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL, 
 					  ((PFN*)&PMWIN_entries)+i)))
 	    Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
@@ -1138,12 +1153,11 @@ static HMODULE htcp = 0;
 static void *
 tcp0(char *name)
 {
-    static BYTE buf[20];
     PFN fcn;
 
     if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
     if (!htcp)
-	DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
+	htcp = loadModule("tcp32dll");
     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
 	return (void *) ((void * (*)(void)) fcn) ();
     return 0;
@@ -1367,15 +1381,30 @@ os2error(int rc)
 char *
 os2_execname(pTHX)
 {
-  char buf[300], *p;
+  char buf[300], *p, *o = PL_origargv[0], ok = 1;
 
   if (_execname(buf, sizeof buf) != 0)
-	return PL_origargv[0];
+	return o;
   p = buf;
   while (*p) {
     if (*p == '\\')
 	*p = '/';
+    if (*p == '/') {
+	if (ok && *o != '/' && *o != '\\')
+	    ok = 0;
+    } else if (ok && tolower(*o) != tolower(*p))
+	ok = 0;	
     p++;
+    o++;
+  }
+  if (ok) { /* PL_origargv[0] matches the real name.  Use PL_origargv[0]: */
+     strcpy(buf, PL_origargv[0]);	/* _execname() is always uppercased */
+     p = buf;
+     while (*p) {
+       if (*p == '\\')
+           *p = '/';
+       p++;
+     }     
   }
   p = savepv(buf);
   SAVEFREEPV(p);
@@ -1447,7 +1476,6 @@ Perl_Register_MQ(int serve)
 	return Perl_hmq;
     DosGetInfoBlocks(&tib, &pib);
     Perl_os2_initial_mode = pib->pib_ultype;
-    Perl_hmq_refcnt = 1;
     /* Try morphing into a PM application. */
     if (pib->pib_ultype != 3)		/* 2 is VIO */
 	pib->pib_ultype = 3;		/* 3 is PM */
@@ -1456,10 +1484,20 @@ Perl_Register_MQ(int serve)
     Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); 
     if (!Perl_hmq) {
 	static int cnt;
+
+	SAVEINT(cnt);			/* Allow catch()ing. */
 	if (cnt++)
 	    _exit(188);			/* Panic can try to create a window. */
 	Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
     }
+    if (serve) {
+	if ( Perl_hmq_servers <= 0	/* Safe to inform us on shutdown, */
+	     && Perl_hmq_refcnt > 0 )	/* this was switched off before... */
+	    (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
+	Perl_hmq_servers++;
+    } else if (!Perl_hmq_servers)	/* Do not inform us on shutdown */
+	(*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
+    Perl_hmq_refcnt++;
     return Perl_hmq;
 }
 
@@ -1469,9 +1507,9 @@ Perl_Serve_Messages(int force)
     int cnt = 0;
     QMSG msg;
 
-    if (Perl_hmq_servers && !force)
+    if (Perl_hmq_servers > 0 && !force)
 	return 0;
-    if (!Perl_hmq_refcnt)
+    if (Perl_hmq_refcnt <= 0)
 	Perl_croak_nocontext("No message queue");
     while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
 	cnt++;
@@ -1487,9 +1525,9 @@ Perl_Process_Messages(int force, I32 *cntp)
 {
     QMSG msg;
 
-    if (Perl_hmq_servers && !force)
+    if (Perl_hmq_servers > 0 && !force)
 	return 0;
-    if (!Perl_hmq_refcnt)
+    if (Perl_hmq_refcnt <= 0)
 	Perl_croak_nocontext("No message queue");
     while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
 	if (cntp)
@@ -1509,21 +1547,23 @@ Perl_Deregister_MQ(int serve)
     PPIB pib;
     PTIB tib;
 
-    if (--Perl_hmq_refcnt == 0) {
+    if (serve)
+	Perl_hmq_servers--;
+    if (--Perl_hmq_refcnt <= 0) {
+	init_PMWIN_entries();			/* To be extra safe */
 	(*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
 	Perl_hmq = 0;
 	/* Try morphing back from a PM application. */
+	DosGetInfoBlocks(&tib, &pib);
 	if (pib->pib_ultype == 3)		/* 3 is PM */
 	    pib->pib_ultype = Perl_os2_initial_mode;
 	else
 	    Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
 		 pib->pib_ultype);
-    }
+    } else if (serve && Perl_hmq_servers <= 0)	/* Last server exited */
+	(*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
 }
 
-extern void dlopen();
-void *fakedl = &dlopen;		/* Pull in dynaloading part. */
-
 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
 				&& ((path)[2] == '/' || (path)[2] == '\\'))
 #define sys_is_rooted _fnisabs
@@ -2026,6 +2066,71 @@ XS(XS_Cwd_extLibpath_set)
     XSRETURN(1);
 }
 
+#define get_control87()		_control87(0,0)
+#define set_control87		_control87
+
+XS(XS_OS2__control87)
+{
+    dXSARGS;
+    if (items != 2)
+	croak("Usage: OS2::_control87(new,mask)");
+    {
+	unsigned	new = (unsigned)SvIV(ST(0));
+	unsigned	mask = (unsigned)SvIV(ST(1));
+	unsigned	RETVAL;
+
+	RETVAL = _control87(new, mask);
+	ST(0) = sv_newmortal();
+	sv_setiv(ST(0), (IV)RETVAL);
+    }
+    XSRETURN(1);
+}
+
+XS(XS_OS2_get_control87)
+{
+    dXSARGS;
+    if (items != 0)
+	croak("Usage: OS2::get_control87()");
+    {
+	unsigned	RETVAL;
+
+	RETVAL = get_control87();
+	ST(0) = sv_newmortal();
+	sv_setiv(ST(0), (IV)RETVAL);
+    }
+    XSRETURN(1);
+}
+
+
+XS(XS_OS2_set_control87)
+{
+    dXSARGS;
+    if (items < 0 || items > 2)
+	croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
+    {
+	unsigned	new;
+	unsigned	mask;
+	unsigned	RETVAL;
+
+	if (items < 1)
+	    new = MCW_EM;
+	else {
+	    new = (unsigned)SvIV(ST(0));
+	}
+
+	if (items < 2)
+	    mask = MCW_EM;
+	else {
+	    mask = (unsigned)SvIV(ST(1));
+	}
+
+	RETVAL = set_control87(new, mask);
+	ST(0) = sv_newmortal();
+	sv_setiv(ST(0), (IV)RETVAL);
+    }
+    XSRETURN(1);
+}
+
 int
 Xs_OS2_init(pTHX)
 {
@@ -2055,6 +2160,9 @@ Xs_OS2_init(pTHX)
         newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
         newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
         newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
+        newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
+        newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
+        newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
 	gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
 	GvMULTI_on(gv);
 #ifdef PERL_IS_AOUT
@@ -2106,6 +2214,8 @@ Perl_OS2_init(char **env)
     }
     MUTEX_INIT(&start_thread_mutex);
     os2_mytype = my_type();		/* Do it before morphing.  Needed? */
+    /* Some DLLs reset FP flags on load.  We may have been linked with them */
+    _control87(MCW_EM, MCW_EM);
 }
 
 #undef tmpnam
@@ -2139,6 +2249,38 @@ my_tmpfile ()
 					     grants TMP. */
 }
 
+#undef rmdir
+
+int
+my_rmdir (__const__ char *s)
+{
+    char buf[MAXPATHLEN];
+    STRLEN l = strlen(s);
+
+    if (s[l-1] == '/' || s[l-1] == '\\') {	/* EMX rmdir fails... */
+	strcpy(buf,s);
+	buf[l - 1] = 0;
+	s = buf;
+    }
+    return rmdir(s);
+}
+
+#undef mkdir
+
+int
+my_mkdir (__const__ char *s, long perm)
+{
+    char buf[MAXPATHLEN];
+    STRLEN l = strlen(s);
+
+    if (s[l-1] == '/' || s[l-1] == '\\') {	/* EMX mkdir fails... */
+	strcpy(buf,s);
+	buf[l - 1] = 0;
+	s = buf;
+    }
+    return mkdir(s, perm);
+}
+
 #undef flock
 
 /* This code was contributed by Rocco Caputo. */