This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Cumulative OS/2-related patch
authorIlya Zakharevich <ilya@math.berkeley.edu>
Mon, 5 Oct 1998 02:37:43 +0000 (22:37 -0400)
committerGurusamy Sarathy <gsar@cpan.org>
Tue, 6 Oct 1998 04:01:55 +0000 (04:01 +0000)
Message-Id: <199810050637.CAA07781@monk.mps.ohio-state.edu>

p4raw-id: //depot/perl@1930

Makefile.SH
hints/os2.sh
lib/ExtUtils/MM_OS2.pm
mg.c
os2/Changes
os2/Makefile.SHs
os2/os2.c
perl_exp.SH
util.c

index be25e74..d39934f 100644 (file)
@@ -451,7 +451,7 @@ perly.h: perly.y
 
 # No compat3.sym here since and including the 5.004_50.
 # No interp.sym since 5.005_03.
-SYM  = global.sym interp.sym perlio.sym thread.sym
+SYM  = global.sym perlio.sym thread.sym
 
 SYMH = perlvars.h thrdvar.h
 
index 78d370a..58086c5 100644 (file)
@@ -113,10 +113,11 @@ aout_lib_ext='.a'
 aout_ar='ar'
 aout_plibext='.a'
 aout_lddlflags="-Zdll $ld_dll_optimize"
+# Cannot have 32000K stack: get SYS0170  ?!
 if [ $emxcrtrev -ge 50 ]; then 
-    aout_ldflags='-Zexe -Zsmall-conv -Zstack 32000'
+    aout_ldflags='-Zexe -Zsmall-conv -Zstack 16000'
 else
-    aout_ldflags='-Zexe -Zstack 32000'
+    aout_ldflags='-Zexe -Zstack 16000'
 fi
 
 # To get into config.sh:
index d34367b..5d6034c 100644 (file)
@@ -28,15 +28,46 @@ $self->{BASEEXT}.def: Makefile.PL
      Mksymlists("NAME" => "', $self->{NAME},
      '", "DLBASE" => "',$self->{DLBASE},
      '", "DL_FUNCS" => ',neatvalue($funcs),
-     '", "FUNCLIST" => ',neatvalue($funclist),
+     ', "FUNCLIST" => ',neatvalue($funclist),
      ', "IMPORTS" => ',neatvalue($imports),
      ', "VERSION" => "',$self->{VERSION},
      '", "DL_VARS" => ', neatvalue($vars), ');\'
 ');
     }
+    if (%{$self->{IMPORTS}}) {
+       # Make import files (needed for static build)
+       -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp";
+       open IMP, '>tmpimp.imp' or die "Can't open tmpimp.imp";
+       my ($name, $exp);
+       while (($name, $exp)= each %{$self->{IMPORTS}}) {
+           my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'";
+           print IMP "$name $lib $id ?\n";
+       }
+       close IMP or die "Can't close tmpimp.imp";
+       # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n";
+       system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp" 
+           and die "Cannot make import library: $!, \$?=$?";
+       unlink <tmp_imp/*>;
+       system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}" 
+           and die "Cannot extract import objects: $!, \$?=$?";      
+    }
     join('',@m);
 }
 
+sub static_lib {
+    my($self) = @_;
+    my $old = $self->ExtUtils::MM_Unix::static_lib();
+    return $old unless %{$self->{IMPORTS}};
+    
+    my @chunks = split /\n{2,}/, $old;
+    shift @chunks unless length $chunks[0]; # Empty lines at the start
+    $chunks[0] .= <<'EOC';
+
+       $(AR) $(AR_STATIC_ARGS) $@ tmp_imp/* && $(RANLIB) $@
+EOC
+    return join "\n\n". '', @chunks;
+}
+
 sub replace_manpage_separator {
     my($self,$man) = @_;
     $man =~ s,/+,.,g;
diff --git a/mg.c b/mg.c
index 1af7240..bec4b91 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -496,8 +496,11 @@ magic_get(SV *sv, MAGIC *mg)
            sv_setnv(sv, (double)errno);
            sv_setpv(sv, errno ? Strerror(errno) : "");
        } else {
-           if (errno != errno_isOS2)
-               Perl_rc = _syserrno();
+           if (errno != errno_isOS2) {
+               int tmp = _syserrno();
+               if (tmp)        /* 2nd call to _syserrno() makes it 0 */
+                   Perl_rc = tmp;
+           }
            sv_setnv(sv, (double)Perl_rc);
            sv_setpv(sv, os2error(Perl_rc));
        }
index 70370a4..c9e0a29 100644 (file)
@@ -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.
index 8223818..aaeed53 100644 (file)
@@ -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 
index 882ec2b..8ef0e37 100644 (file)
--- 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
index 1a4c8c5..07d4140 100644 (file)
@@ -99,6 +99,9 @@ perl_call_sv
 perl_eval_pv
 perl_eval_sv
 perl_require_pv
+cast_i32
+cast_iv
+cast_uv
 END
 
 case "$ccflags" in
diff --git a/util.c b/util.c
index fd99576..20b5e25 100644 (file)
--- a/util.c
+++ b/util.c
@@ -2570,7 +2570,8 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
 #endif
            DEBUG_p(PerlIO_printf(Perl_debug_log,
                                  "Looking for %s\n",cur));
-           if (PerlLIO_stat(cur,&PL_statbuf) >= 0) {
+           if (PerlLIO_stat(cur,&PL_statbuf) >= 0
+               && !S_ISDIR(PL_statbuf.st_mode)) {
                dosearch = 0;
                scriptname = cur;
 #ifdef SEARCH_EXTS
@@ -2639,6 +2640,9 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
 #endif
                DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
                retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
+               if (S_ISDIR(PL_statbuf.st_mode)) {
+                   retval = -1;
+               }
 #ifdef SEARCH_EXTS
            } while (  retval < 0               /* not there */
                    && extidx>=0 && ext[extidx] /* try an extension? */
@@ -2661,7 +2665,9 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
                xfailed = savepv(tmpbuf);
        }
 #ifndef DOSISH
-       if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_statbuf) < 0))
+       if (!xfound && !seen_dot && !xfailed &&
+           (PerlLIO_stat(scriptname,&PL_statbuf) < 0 
+            || S_ISDIR(PL_statbuf.st_mode)))
 #endif
            seen_dot = 1;                       /* Disable message. */
        if (!xfound) {