diff options
| -rw-r--r-- | Makefile.SH | 2 | ||||
| -rw-r--r-- | hints/os2.sh | 5 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_OS2.pm | 33 | ||||
| -rw-r--r-- | mg.c | 7 | ||||
| -rw-r--r-- | os2/Changes | 14 | ||||
| -rw-r--r-- | os2/Makefile.SHs | 63 | ||||
| -rw-r--r-- | os2/os2.c | 154 | ||||
| -rw-r--r-- | perl_exp.SH | 3 | ||||
| -rw-r--r-- | util.c | 10 |
9 files changed, 262 insertions, 29 deletions
diff --git a/Makefile.SH b/Makefile.SH index be25e74ea2..d39934ffe0 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -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 diff --git a/hints/os2.sh b/hints/os2.sh index 78d370a1e9..58086c5bf6 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -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: diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index d34367b959..5d6034ce34 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -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; @@ -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)); } 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 @@ -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 diff --git a/perl_exp.SH b/perl_exp.SH index 1a4c8c5e0f..07d41408d4 100644 --- a/perl_exp.SH +++ b/perl_exp.SH @@ -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 @@ -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) { |