Cumulative OS/2-related patch

	Message-Id: <199810050637.CAA07781@monk.mps.ohio-state.edu>

p4raw-id: //depot/perl@1930

3 files changed, 210 insertions, 21 deletions

diff --git a/os2/Changes b/os2/Changes
index 70370a4ad6..c9e0a2991a 100644
--- a/os2/Changes
+++ b/os2/Changes
@@ -198,3 +198,17 @@ after 5.004_73:
 	metachars, or if magic-line asks for sh, or there is no magic
 	line and EXECSHELL is set to sh.
 	Shell is supplied the original command line if possible.
+
+after 5.005_02:
+	Can start PM programs from non-PM sessions by plain system()
+		and friends.  Can start DOS/Win programs.  Can start
+		fullscreen programs from non-fullscreen sessions too.
+	In fact system(P_PM,...) was broken.
+	We mangle the name of perl*.DLL, to allow coexistence of different
+		versions of Perl executables on the system.  Mangling of
+		names of extension DLL is also changed, thus running two
+		different versions of the executable with loaded
+		extensions should not lead to conflicts (since 
+		extension-full-name and Perl-version mangling work in the 
+		same set ot 576 possible keys, this may lead to clashes).
+	$^E was reset on the second read, and contained ".\r\n" at the end.
diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs
index 8223818133..aaeed530c2 100644
--- a/os2/Makefile.SHs
+++ b/os2/Makefile.SHs
@@ -8,11 +8,12 @@
 
 perl_version="5.00${PATCHLEVEL}_$SUBVERSION"
 case "$archname" in
- *-thread)	dll_post=_thr 
-		perl_version="${perl_version}-threaded";;
- *)		dll_post='' ;;
+ *-thread*)	perl_version="${perl_version}-threaded";;
 esac
 
+dll_post="`echo $perl_version | sum | awk '{print $1}'`"
+dll_post="`printf '%x' $dll_post | tr '[a-z]' '[A-Z]'`"
+
 $spitshell >>Makefile <<!GROK!THIS!
 
 PERL_VERSION = $perl_version
@@ -33,6 +34,7 @@ LD_OPT		= $optimize
 
 PERL_DLL_BASE	= perl$dll_post
 PERL_DLL	= \$(PERL_DLL_BASE)\$(DLSUFFIX)
+CONFIG_ARGS	= $config_args
 
 !GROK!THIS!
 
@@ -50,12 +52,14 @@ perl.imp: perl5.def
 	echo	'emx_malloc		emxlibcm	402	?' >> $@
 	echo	'emx_realloc		emxlibcm	403	?' >> $@
 
+perl_dll: $(PERL_DLL)
+
 $(PERL_DLL): $(obj) perl5.def perl$(OBJ_EXT)
 	$(LD) $(LD_OPT) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def
 
 perl5.def: perl.linkexp
 	echo "LIBRARY '$(PERL_DLL_BASE)' INITINSTANCE TERMINSTANCE"	> $@
-	echo DESCRIPTION "'Perl interpreter v$(PERL_VERSION), export autogenerated'"	>>$@
+	echo DESCRIPTION "'Perl interpreter v$(PERL_VERSION), export autogenerated, built with $(CONFIG_ARGS)'"	>>$@
 	echo STACKSIZE 32768				>>$@
 	echo CODE LOADONCALL				>>$@
 	echo DATA LOADONCALL NONSHARED MULTIPLE		>>$@
@@ -160,8 +164,8 @@ aout_perlmain.c: miniperlmain.c config.sh makefile $(static_ext_autoinit)
 	sh writemain $(DYNALOADER) $(aout_static_lib) > tmp
 	sh mv-if-diff tmp aout_perlmain.c
 
-miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) ext.libs
-	$(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o miniperl_ miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) `cat ext.libs` $(libs)
+miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL)
+	$(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o miniperl_ miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(libs)
 
 perl_: $& aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs
 	$(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o perl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER) $(aout_static_ext) $(AOUT_LIBPERL) `cat ext.libs` $(libs)
@@ -197,18 +201,47 @@ sys_test: perl_sys
 sys_harness: perl_sys
 	- cd t && (rm -f perl_$(EXE_EXT); $(LNS) ../perl_sys$(EXE_EXT) perl$(EXE_EXT)) && env HARNESS_BAD_EXITCODE=2 ./perl harness </dev/tty
 
-lib/auto/OS2/*/%.a : ext/OS2/%/Makefile.aout
-	cd ext/OS2/$(basename $(notdir $@)) ; make -f Makefile.aout config || echo "$make config failed, continuing anyway..."
-	cd ext/OS2/$(basename $(notdir $@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS=
+!NO!SUBS!
 
-lib/auto/*/%.a : ext/%/Makefile.aout
-	cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout config || echo "$make config failed, continuing anyway..."
-	cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS=
+# Now we need to find directories in ./ext/ which are two level deep
+
+dirs=''
+preci='ext/%/Makefile.aout '
+for d in ext/*
+do
+	# echo "Checking '$d'..."
+	f="`echo $d/*/Makefile.PL`"
+	# SDBFile/sdbm, skip kid makefile
+	if test ! -e "$d/Makefile.PL" -a ! "$f" = ""; then
+	    dirs="$dirs $d"
+	    preci="$preci $d/%/Makefile.aout"
+	fi
+done
+
+$spitshell >>Makefile <<!GROK!THIS!
+.PRECIOUS : $preci
+
+!GROK!THIS!
+
+for d in $dirs
+do
+    p=`basename $d`
+    $spitshell >>Makefile <<!GROK!THIS!
+lib/auto/$p/*/%.a : ext/$p/%/Makefile.aout
+	@cd ext/$p/\$(basename \$(notdir \$@)) ; make -f Makefile.aout config || echo "\$(MAKE) config failed, continuing anyway..."
+	cd ext/$p/\$(basename \$(notdir \$@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS=
+
+$d/%/Makefile.aout : miniperl_
+	cd \$(dir \$@) ; ../../../miniperl_ -I ../../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl 
+
+!GROK!THIS!
 
-.PRECIOUS : ext/%/Makefile.aout ext/OS2/%/Makefile.aout
+done
 
-ext/OS2/%/Makefile.aout : miniperl_
-	cd $(dir $@) ; ../../../miniperl_ -I ../../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl 
+$spitshell >>Makefile <<'!NO!SUBS!'
+lib/auto/*/%.a : ext/%/Makefile.aout
+	@cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout config || echo "\$(MAKE) config failed, continuing anyway..."
+	cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS=
 
 ext/%/Makefile.aout : miniperl_
 	cd $(dir $@) ; ../../miniperl_ -I ../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl 
diff --git a/os2/os2.c b/os2/os2.c
index 882ec2b416..8ef0e37ca5 100644
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -378,6 +378,48 @@ result(int flag, int pid)
 #define EXECF_TRUEEXEC 2
 #define EXECF_SPAWN_NOWAIT 3
 
+/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
+
+static int
+my_type()
+{
+    int rc;
+    TIB *tib;
+    PIB *pib;
+    
+    if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
+    if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) 
+	return -1; 
+    
+    return (pib->pib_ultype);
+}
+
+static ULONG
+file_type(char *path)
+{
+    int rc;
+    ULONG apptype;
+    
+    if (!(_emx_env & 0x200)) 
+	croak("file_type not implemented on DOS"); /* not OS/2. */
+    if (CheckOSError(DosQueryAppType(path, &apptype))) {
+	switch (rc) {
+	case ERROR_FILE_NOT_FOUND:
+	case ERROR_PATH_NOT_FOUND:
+	    return -1;
+	case ERROR_ACCESS_DENIED:	/* Directory with this name found? */
+	    return -3;
+	default:			/* Found, but not an
+					   executable, or some other
+					   read error. */
+	    return -2;
+	}
+    }    
+    return apptype;
+}
+
+static ULONG os2_mytype;
+
 /* Spawn/exec a program, revert to shell if needed. */
 /* global PL_Argv[] contains arguments. */
 
@@ -398,6 +440,7 @@ char *inicmd;
 	    = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
 	char **argsp = fargs;
 	char nargs = 4;
+	int force_shell;
 	
 	if (flag == P_WAIT)
 		flag = P_NOWAIT;
@@ -414,6 +457,71 @@ char *inicmd;
 	/* We should check PERL_SH* and PERLLIB_* as well? */
 	if (!really || !*(tmps = SvPV(really, PL_na)))
 	    tmps = PL_Argv[0];
+
+      reread:
+	force_shell = 0;
+	if (_emx_env & 0x200) { /* OS/2. */ 
+	    int type = file_type(tmps);
+	  type_again:
+	    if (type == -1) {		/* Not found */
+		errno = ENOENT;
+		rc = -1;
+		goto do_script;
+	    }
+	    else if (type == -2) {		/* Not an EXE */
+		errno = ENOEXEC;
+		rc = -1;
+		goto do_script;
+	    }
+	    else if (type == -3) {		/* Is a directory? */
+		/* Special-case this */
+		char tbuf[512];
+		int l = strlen(tmps);
+
+		if (l + 5 <= sizeof tbuf) {
+		    strcpy(tbuf, tmps);
+		    strcpy(tbuf + l, ".exe");
+		    type = file_type(tbuf);
+		    if (type >= -3)
+			goto type_again;
+		}
+		
+		errno = ENOEXEC;
+		rc = -1;
+		goto do_script;
+	    }
+	    switch (type & 7) {
+		/* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
+	    case FAPPTYP_WINDOWAPI: 
+	    {
+		if (os2_mytype != 3) {	/* not PM */
+		    if (flag == P_NOWAIT)
+			flag = P_PM;
+		    else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
+			warn("Starting PM process with flag=%d, mytype=%d",
+			     flag, os2_mytype);
+		}
+	    }
+	    break;
+	    case FAPPTYP_NOTWINDOWCOMPAT: 
+	    {
+		if (os2_mytype != 0) {	/* not full screen */
+		    if (flag == P_NOWAIT)
+			flag = P_SESSION;
+		    else if ((flag & 7) != P_SESSION)
+			warn("Starting Full Screen process with flag=%d, mytype=%d",
+			     flag, os2_mytype);
+		}
+	    }
+	    break;
+	    case FAPPTYP_NOTSPEC: 
+		/* Let the shell handle this... */
+		force_shell = 1;
+		goto doshell_args;
+		break;
+	    }
+	}
+
 #if 0
 	rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
 #else
@@ -422,13 +530,15 @@ char *inicmd;
 	else if (execf == EXECF_EXEC)
 	    rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
 	else if (execf == EXECF_SPAWN_NOWAIT)
-	    rc = spawnvp(trueflag | P_NOWAIT,tmps,PL_Argv);
+	    rc = spawnvp(flag,tmps,PL_Argv);
         else				/* EXECF_SPAWN */
 	    rc = result(trueflag, 
-			spawnvp(trueflag | P_NOWAIT,tmps,PL_Argv));
+			spawnvp(flag,tmps,PL_Argv));
 #endif 
 	if (rc < 0 && pass == 1
 	    && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
+	      do_script:
+	    {
 	    int err = errno;
 
 	    if (err == ENOENT || err == ENOEXEC) {
@@ -444,9 +554,28 @@ char *inicmd;
 		    PL_Argv[0] = scr;
 		    if (!file)
 			goto panic_file;
-		    if (!fgets(buf, sizeof buf, file)) {
+		    if (!fgets(buf, sizeof buf, file)) { /* Empty... */
+			int l = strlen(scr);
+
+			buf[0] = 0;
 			fclose(file);
-			goto panic_file;
+			/* Special case: maybe from -Zexe build, so
+			   there is an executable around (contrary to
+			   documentation, DosQueryAppType sometimes (?)
+			   does not append ".exe", so we could have
+			   reached this place). */
+			if (l + 5 < 512) { /* size of buffer in find_script */
+			    strcpy(scr + l, ".exe");
+			    if (PerlLIO_stat(scr,&PL_statbuf) >= 0
+				&& !S_ISDIR(PL_statbuf.st_mode)) {
+				/* Found */
+				tmps = scr;
+				pass++;
+				goto reread;
+			    } else {
+				scr[l] = 0;
+			    }
+			}
 		    }
 		    if (fclose(file) != 0) { /* Failure */
 		      panic_file:
@@ -504,7 +633,8 @@ char *inicmd;
 			char **a = PL_Argv;
 			char *exec_args[2];
 
-			if (!buf[0] && file) { /* File without magic */
+			if (force_shell 
+			    || (!buf[0] && file)) { /* File without magic */
 			    /* In fact we tried all what pdksh would
 			       try.  There is no point in calling
 			       pdksh, we may just emulate its logic. */
@@ -582,6 +712,7 @@ char *inicmd;
 		/* Not found: restore errno */
 		errno = err;
 	    }
+	  }
 	} else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
 	    char *no_dir = strrchr(PL_Argv[0], '/');
 
@@ -774,7 +905,8 @@ bool
 do_exec(cmd)
 char *cmd;
 {
-    return do_spawn2(cmd, EXECF_EXEC);
+    do_spawn2(cmd, EXECF_EXEC);
+    return FALSE;
 }
 
 bool
@@ -1023,6 +1155,8 @@ XS(XS_File__Copy_syscopy)
     XSRETURN(1);
 }
 
+#include "patchlevel.h"
+
 char *
 mod2fname(sv)
      SV   *sv;
@@ -1062,6 +1196,7 @@ mod2fname(sv)
 #ifdef USE_THREADS
     sum++;				/* Avoid conflict of DLLs in memory. */
 #endif 
+    sum += PATCHLEVEL * 200 + SUBVERSION * 2;  /*  */
     fname[pos] = 'A' + (sum % 26);
     fname[pos + 1] = 'A' + (sum / 26 % 26);
     fname[pos + 2] = '\0';
@@ -1097,6 +1232,12 @@ os2error(int rc)
 		sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
 	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';
 	return buf;
 }
 
@@ -1503,6 +1644,7 @@ Perl_OS2_init(char **env)
 	}
     }
     MUTEX_INIT(&start_thread_mutex);
+    os2_mytype = my_type();		/* Do it before morphing.  Needed? */
 }
 
 #undef tmpnam