From 764df951e4265f932b70873d1d56431da2d2763f Mon Sep 17 00:00:00 2001 From: Ilya Zakharevich Date: Mon, 23 Jul 2001 15:29:49 -0400 Subject: [PATCH] OS/2 multi-architecture Message-ID: <20010723192949.A14802@math.ohio-state.edu> p4raw-id: //depot/perl@11462 --- MANIFEST | 1 + configpm | 1 + makedef.pl | 2 + mg.c | 6 +- os2/Makefile.SHs | 161 +++++++++++++--- os2/OS2/REXX/t/rx_vrexx.t | 6 +- os2/os2.c | 359 +++++++++++++++++++++++++++++++++-- os2/os2ish.h | 47 +++-- os2/perlrexx.c | 462 ++++++++++++++++++++++++++++++++++++++++++++++ perl.c | 5 +- t/op/write.t | 3 +- 11 files changed, 998 insertions(+), 55 deletions(-) create mode 100644 os2/perlrexx.c diff --git a/MANIFEST b/MANIFEST index cb7db4f..3d7b42f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1650,6 +1650,7 @@ os2/os2ish.h Header for OS/2 os2/os2thread.h pthread-like typedefs os2/os2_base.t Additional tests for builtin methods os2/perl2cmd.pl Corrects installed binaries under OS/2 +os2/perlrexx.c Support perl interpreter embedded in REXX patchlevel.h The current patch level of perl perl.c main() perl.h Global declarations diff --git a/configpm b/configpm index b98bf82..86abd6d 100755 --- a/configpm +++ b/configpm @@ -274,6 +274,7 @@ if ($OS2::is_aout) { $preconfig{$_} = $v eq 'undef' ? undef : $v; } } +$preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't sub TIEHASH { bless {%preconfig} } ENDOFSET } else { diff --git a/makedef.pl b/makedef.pl index 6ac99f4..4c670e5 100644 --- a/makedef.pl +++ b/makedef.pl @@ -296,6 +296,8 @@ elsif ($PLATFORM eq 'os2') { ctermid get_sysinfo Perl_OS2_init + Perl_OS2_init3 + Perl_OS2_term OS2_Perl_data dlopen dlsym diff --git a/mg.c b/mg.c index b9a5501..f3fc035 100644 --- a/mg.c +++ b/mg.c @@ -2120,11 +2120,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; } /* can grab env area too? */ - if (PL_origenviron && (PL_origenviron[0] == s + 1 -#ifdef OS2 - || (PL_origenviron[0] == s + 9 && (s += 8)) -#endif - )) { + if (PL_origenviron && (PL_origenviron[0] == s + 1)) { my_setenv("NoNe SuCh", Nullch); /* force copy of environment */ for (i = 0; PL_origenviron[i]; i++) diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 8140aa5..be5aad1 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -40,6 +40,9 @@ AOUT_LIBPERL_DLL = libperl_dll$aout_lib_ext AOUT_CCCMD_DLL = \$(CC) -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK AOUT_CLDFLAGS_DLL = -Zexe -Zmt -Zcrtdll -Zstack 32000 +# No -DPERL_CORE +SO_CCCMD = \$(CC) $ccflags \$(OPTIMIZE) + LD_OPT = \$(OPTIMIZE) PERL_DLL_BASE = perl$dll_post @@ -73,6 +76,12 @@ perl.imp: perl5.def echo 'emx_malloc emxlibcm 402 ?' >> $@ echo 'emx_realloc emxlibcm 403 ?' >> $@ +.PHONY: perl_dll installcmd aout_clean aout_install aout_install.perl \ + perlrexx test_prep_perl_ test_prep_perl_sys test_prep_perl_stat \ + test_prep_perl_stat_aout test_prep_various \ + stat_aout_harness aout_harness stat_harness sys_harness all_harness \ + stat_aout_test aout_test stat_test sys_test all_test + perl_dll: $(PERL_DLL) perl_dll_t: t/$(PERL_DLL) @@ -139,18 +148,28 @@ os2thread.h: os2/os2thread.h dlfcn.h: os2/dlfcn.h cp -f $< $@ -# This one is compiled OMF, so cannot fork(): +# Non-Forking dynamically loaded perl -perl___: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o perl___ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) +perl___$(EXE_EXT) perl___: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs + $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o perl___ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) -Zlinker /map/PM:VIO # This one is compiled -Zsys, so cannot do many things: +# Remove -Zcrtdll +STAT_CLDFLAGS = -Zexe -Zomf -Zmt -Zstack 32000 + +# Non-forking dynamically loaded perl with a wrong CRT library: + +perl_stat: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs + $(SHRPENV) $(CC) $(STAT_CLDFLAGS) $(CCDLFLAGS) -o $@ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) -Zlinker /map/PM:VIO + # Remove -Zcrtdll, add -Zsys -SYS_CLDFLAGS = -Zexe -Zomf -Zmt -Zsys -Zstack 32000 +SYS_CLDFLAGS = $(STAT_CLDFLAGS) -Zsys + +# Non-Forking dynamically loaded perl without EMX - so with wrong CRT library perl_sys: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - $(SHRPENV) $(CC) $(SYS_CLDFLAGS) $(CCDLFLAGS) -o perl_sys perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(CC) $(SYS_CLDFLAGS) $(CCDLFLAGS) -o $@ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) -Zlinker /map/PM:VIO installcmd : @perl -e 'die qq{Give the option INSTALLCMDDIR=... to make!} if $$ARGV[0] eq ""' $(INSTALLCMDDIR) @@ -192,20 +211,34 @@ 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) opmini$(AOUT_OBJ_EXT) +_preplibrary = miniperl lib/Config.pm lib/lib.pm lib/re.pm + +miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) opmini$(AOUT_OBJ_EXT) $(_preplibrary) $(CC) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o miniperl_ miniperlmain$(AOUT_OBJ_EXT) opmini$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(libs) -perl_: $& aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs +# Forking statically loaded perl + +perl_$(EXE_EXT) perl_: $& aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs $(CC) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o perl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER) $(aout_static_ext) $(AOUT_LIBPERL) `cat ext.libs` $(libs) +# Remove -Zcrtdll +STAT_AOUT_CLDFLAGS = -Zexe -Zmt -Zstack 32000 + +# Forking dynamically loaded perl with a wrong CRT library: + +perl_stat_aout$(EXE_EXT) perl_stat_aout: $& perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) ext.libs + $(SHRPENV) $(CC) $(STAT_AOUT_CLDFLAGS) $(CCDLFLAGS) -o $@ perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) `cat ext.libs` $(libs) + perl : perl__ perl___ -perl__: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs +# Dynamically loaded PM-application perl: + +perl__$(EXE_EXT) perl__: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o perl__ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) -Zlinker /PM:PM # Forking dynamically loaded perl: -perl: $& perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) ext.libs +perl$(EXE_EXT) perl: $& perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) ext.libs $(CC) $(AOUT_CLDFLAGS_DLL) $(CCDLFLAGS) -o perl perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) `cat ext.libs` $(libs) clean: aout_clean @@ -218,16 +251,90 @@ aout_install: perl_ aout_install.perl aout_install.perl: perl_ installperl ./perl_ installperl -aout_test: perl_ - - cd t && (rm -f perl_$(EXE_EXT); $(LNS) ../perl_$(EXE_EXT) perl$(EXE_EXT)) && ./perl TEST tmp.def + echo "DESCRIPTION '@#perl5-porters@perl.org:`miniperl -Ilib -MConfig -e 'print \$$]'`#@ REXX to Perl `miniperl -Ilib -MConfig -e 'print \$$Config{version}'` interface'" >> tmp.def + echo "EXPORTS" >> tmp.def + echo ' "PERL"' >> tmp.def + echo ' "PERLTERM"' >> tmp.def + echo ' "PERLINIT"' >> tmp.def + echo ' "PERLEXIT"' >> tmp.def + echo ' "PERLEVAL"' >> tmp.def + sh mv-if-diff tmp.def $@ + + +perlrexx$(OBJ_EXT): perlrexx.c + $(SO_CCCMD) $(PLDLFLAGS) -c perlrexx.c + +# To test with harness, one needed to HARNESS_IGNORE_EXITCODE=2 -# To test with harness, set HARNESS_BAD_EXITCODE=2 +# Define to be empty to get a TTY test +REDIR_TEST = 2>&1 | tee 00_$@ -sys_test: perl_sys - - cd t && (rm -f perl_$(EXE_EXT); $(LNS) ../perl_sys$(EXE_EXT) perl$(EXE_EXT)) && ./perl TEST >Makefile <>Makefile <<'!NO!SUBS!' +lib/auto/OS2/DLL/DLL.a : lib/auto/OS2/REXX/REXX.a + @sh -c true + 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 +ext/%/Makefile.aout : miniperl_ \$(_preplibrary) \$(AOUT_EXTENSIONS_FORCE) + cd $(dir $@) ; ../../miniperl_ -I ../../lib Makefile.PL FIRST_MAKEFILE=Makefile.aout INSTALLDIRS=perl !NO!SUBS! diff --git a/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t index b0621f4..3611894 100644 --- a/os2/OS2/REXX/t/rx_vrexx.t +++ b/os2/OS2/REXX/t/rx_vrexx.t @@ -3,7 +3,11 @@ BEGIN { @INC = '../lib' if -d 'lib'; require Config; import Config; if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; + print "1..0 # skipped: OS2::REXX not built\n"; + exit 0; + } + if (defined $ENV{PERL_TEST_NOVREXX}) { + print "1..0 # skipped: request via PERL_TEST_NOVREXX\n"; exit 0; } } diff --git a/os2/os2.c b/os2/os2.c index bfe6e9f..d22553a 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -184,6 +184,8 @@ os2_cond_wait(perl_cond *c, perl_mutex *m) } #endif +static int exe_is_aout(void); + /*****************************************************************************/ /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ #define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym)) @@ -467,6 +469,9 @@ getpriority(int which /* ignored */, int pid) /*****************************************************************************/ /* spawn */ +int emx_runtime_init; /* If 1, we need to manually init it */ +int emx_exception_init; /* If 1, we need to manually set it */ + /* There is no big sense to make it thread-specific, since signals are delivered to thread 1 only. XXXX Maybe make it into an array? */ static int spawn_pid; @@ -529,11 +534,14 @@ result(pTHX_ int flag, int pid) #endif } -#define EXECF_SPAWN 0 -#define EXECF_EXEC 1 -#define EXECF_TRUEEXEC 2 -#define EXECF_SPAWN_NOWAIT 3 -#define EXECF_SPAWN_BYFLAG 4 +enum execf_t { + EXECF_SPAWN, + EXECF_EXEC, + EXECF_TRUEEXEC, + EXECF_SPAWN_NOWAIT, + EXECF_SPAWN_BYFLAG, + EXECF_SYNC +}; /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ @@ -580,6 +588,11 @@ static ULONG os2_mytype; /* Spawn/exec a program, revert to shell if needed. */ /* global PL_Argv[] contains arguments. */ +extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, + EXCEPTIONREGISTRATIONRECORD *, + CONTEXTRECORD *, + void *); + int do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) { @@ -707,6 +720,8 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv); else if (execf == EXECF_SPAWN_NOWAIT) rc = spawnvp(flag,tmps,PL_Argv); + else if (execf == EXECF_SYNC) + rc = spawnvp(trueflag,tmps,PL_Argv); else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv)); @@ -1001,7 +1016,7 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) should be smart enough to start itself gloriously. */ doshell: if (execf == EXECF_TRUEEXEC) - rc = execl(shell,shell,copt,cmd,(char*)0); + rc = execl(shell,shell,copt,cmd,(char*)0); else if (execf == EXECF_EXEC) rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); else if (execf == EXECF_SPAWN_NOWAIT) @@ -1010,8 +1025,11 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); else { /* In the ak code internal P_NOWAIT is P_WAIT ??? */ - rc = result(aTHX_ P_WAIT, - spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); + if (execf == EXECF_SYNC) + rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0); + else + rc = result(aTHX_ P_WAIT, + spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); if (rc < 0 && ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", (execf == EXECF_SPAWN ? "spawn" : "exec"), @@ -2274,7 +2292,10 @@ Xs_OS2_init(pTHX) GvMULTI_on(gv); #ifdef PERL_IS_AOUT sv_setiv(GvSV(gv), 1); -#endif +#endif + gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), exe_is_aout()); gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); GvMULTI_on(gv); sv_setiv(GvSV(gv), _emx_rev); @@ -2295,18 +2316,330 @@ Xs_OS2_init(pTHX) OS2_Perl_data_t OS2_Perl_data; +extern void _emx_init(void*); + +static void jmp_out_of_atexit(void); + +#define FORCE_EMX_INIT_CONTRACT_ARGV 1 +#define FORCE_EMX_INIT_INSTALL_ATEXIT 2 + +static void +my_emx_init(void *layout) { + static volatile void *p = 0; /* Cannot be on stack! */ + + /* Can't just call emx_init(), since it moves the stack pointer */ + /* It also busts a lot of registers, so be extra careful */ + __asm__( "pushf\n" + "pusha\n" + "movl %%esp, %1\n" + "push %0\n" + "call __emx_init\n" + "movl %1, %%esp\n" + "popa\n" + "popf\n" : : "r" (layout), "m" (p) ); +} + +struct layout_table_t { + ULONG text_base; + ULONG text_end; + ULONG data_base; + ULONG data_end; + ULONG bss_base; + ULONG bss_end; + ULONG heap_base; + ULONG heap_end; + ULONG heap_brk; + ULONG heap_off; + ULONG os2_dll; + ULONG stack_base; + ULONG stack_end; + ULONG flags; + ULONG reserved[2]; + char options[64]; +}; + +static ULONG +my_os_version() { + static ULONG res; /* Cannot be on stack! */ + + /* Can't just call emx_init(), since it moves the stack pointer */ + /* It also busts a lot of registers, so be extra careful */ + __asm__( "pushf\n" + "pusha\n" + "call ___os_version\n" + "movl %%eax, %0\n" + "popa\n" + "popf\n" : "=m" (res) ); + + return res; +} + +static void +force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) +{ + /* Calling emx_init() will bust the top of stack: it installs an + exception handler and puts argv data there. */ + char *oldarg, *oldenv; + void *oldstackend, *oldstack; + PPIB pib; + PTIB tib; + static ULONG os2_dll; + ULONG rc, error = 0, out; + char buf[512]; + static struct layout_table_t layout_table; + struct { + char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */ + double alignment1; + EXCEPTIONREGISTRATIONRECORD xreg; + } *newstack; + char *s; + + layout_table.os2_dll = (ULONG)&os2_dll; + layout_table.flags = 0x02000002; /* flags: application, OMF */ + + DosGetInfoBlocks(&tib, &pib); + oldarg = pib->pib_pchcmd; + oldenv = pib->pib_pchenv; + oldstack = tib->tib_pstack; + oldstackend = tib->tib_pstacklimit; + + /* Minimize the damage to the stack via reducing the size of argv. */ + if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) { + pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */ + pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */ + } + + newstack = alloca(sizeof(*newstack)); + /* Emulate the stack probe */ + s = ((char*)newstack) + sizeof(*newstack); + while (s > (char*)newstack) { + s[-1] = 0; + s -= 4096; + } + + /* Reassigning stack is documented to work */ + tib->tib_pstack = (void*)newstack; + tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack)); + + /* Can't just call emx_init(), since it moves the stack pointer */ + my_emx_init((void*)&layout_table); + + /* Remove the exception handler, cannot use it - too low on the stack. + Check whether it is inside the new stack. */ + buf[0] = 0; + if (tib->tib_pexchain >= tib->tib_pstacklimit + || tib->tib_pexchain < tib->tib_pstack) { + error = 1; + sprintf(buf, + "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n", + (unsigned long)tib->tib_pstack, + (unsigned long)tib->tib_pexchain, + (unsigned long)tib->tib_pstacklimit); + goto finish; + } + if (tib->tib_pexchain != &(newstack->xreg)) { + sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n", + (unsigned long)tib->tib_pexchain, + (unsigned long)&(newstack->xreg)); + } + rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain); + if (rc) + sprintf(buf + strlen(buf), + "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc); + + if (preg) { + /* ExceptionRecords should be on stack, in a correct order. Sigh... */ + preg->prev_structure = 0; + preg->ExceptionHandler = _emx_exception; + rc = DosSetExceptionHandler(preg); + if (rc) { + sprintf(buf + strlen(buf), + "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc); + DosWrite(2, buf, strlen(buf), &out); + emx_exception_init = 1; /* Do it around spawn*() calls */ + } + } else + emx_exception_init = 1; /* Do it around spawn*() calls */ + + finish: + /* Restore the damage */ + pib->pib_pchcmd = oldarg; + pib->pib_pchcmd = oldenv; + tib->tib_pstacklimit = oldstackend; + tib->tib_pstack = oldstack; + emx_runtime_init = 1; + if (buf[0]) + DosWrite(2, buf, strlen(buf), &out); + if (error) + exit(56); +} + +jmp_buf at_exit_buf; +int longjmp_at_exit; + +static void +jmp_out_of_atexit(void) +{ + if (longjmp_at_exit) + longjmp(at_exit_buf, 1); +} + +extern void _CRT_term(void); + +int emx_runtime_secondary; + +void +Perl_OS2_term(void **p, int exitstatus, int flags) +{ + if (!emx_runtime_secondary) + return; + + /* The principal executable is not running the same CRTL, so there + is nobody to shutdown *this* CRTL except us... */ + if (flags & FORCE_EMX_DEINIT_EXIT) { + if (p && !emx_exception_init) + DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); + /* Do not run the executable's CRTL's termination routines */ + exit(exitstatus); /* Run at-exit, flush buffers, etc */ + } + /* Run at-exit list, and jump out at the end */ + if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) { + longjmp_at_exit = 1; + exit(exitstatus); /* The first pass through "if" */ + } + + /* Get here if we managed to jump out of exit(), or did not run atexit. */ + longjmp_at_exit = 0; /* Maybe exit() is called again? */ +#if 0 /* _atexit_n is not exported */ + if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT) + _atexit_n = 0; /* Remove the atexit() handlers */ +#endif + /* Will segfault on program termination if we leave this dangling... */ + if (p && !emx_exception_init) + DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); + /* Typically there is no need to do this, done from _DLL_InitTerm() */ + if (flags & FORCE_EMX_DEINIT_CRT_TERM) + _CRT_term(); /* Flush buffers, etc. */ + /* Now it is a good time to call exit() in the caller's CRTL... */ +} + +#include + +extern ULONG __os_version(); /* See system.doc */ + +static int emx_wasnt_initialized; + +void +check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) +{ + ULONG v_crt, v_emx; + + /* If _environ is not set, this code sits in a DLL which + uses a CRT DLL which not compatible with the executable's + CRT library. Some parts of the DLL are not initialized. + */ + if (_environ != NULL) + return; /* Properly initialized */ + + /* If the executable does not use EMX.DLL, EMX.DLL is not completely + initialized either. Uninitialized EMX.DLL returns 0 in the low + nibble of __os_version(). */ + v_emx = my_os_version(); + + /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL + (=>_CRT_init=>_entry2) via a call to __os_version(), then + reset when the EXE initialization code calls _text=>_init=>_entry2. + The first time they are wrongly set to 0; the second time the + EXE initialization code had already called emx_init=>initialize1 + which correctly set version_major, version_minor used by + __os_version(). */ + v_crt = (_osmajor | _osminor); + + if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */ + force_init_emx_runtime( preg, + FORCE_EMX_INIT_CONTRACT_ARGV + | FORCE_EMX_INIT_INSTALL_ATEXIT ); + emx_wasnt_initialized = 1; + /* Update CRTL data basing on now-valid EMX runtime data */ + if (!v_crt) { /* The only wrong data are the versions. */ + v_emx = my_os_version(); /* *Now* it works */ + *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */ + *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF; + } + } + emx_runtime_secondary = 1; + /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */ + atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */ + + if (!env) { /* Fetch from the process info block */ + int c = 0; + PPIB pib; + PTIB tib; + char *e, **ep; + + DosGetInfoBlocks(&tib, &pib); + e = pib->pib_pchenv; + while (*e) { /* Get count */ + c++; + e = e + strlen(e) + 1; + } + e = pib->pib_pchenv; + while (*e) { /* Get count */ + c++; + e = e + strlen(e) + 1; + } + New(1307, env, c + 1, char*); + ep = env; + e = pib->pib_pchenv; + while (c--) { + *ep++ = e; + e = e + strlen(e) + 1; + } + *ep = NULL; + } + _environ = _org_environ = env; +} + +#define ENTRY_POINT 0x10000 + +static int +exe_is_aout(void) +{ + struct layout_table_t *layout; + if (emx_wasnt_initialized) + return 0; + /* Now we know that the principal executable is an EMX application + - unless somebody did already play with delayed initialization... */ + /* With EMX applications to determine whether it is AOUT one needs + to examine the start of the executable to find "layout" */ + if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */ + || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */ + || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */ + || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */ + return 0; /* ! EMX executable */ + /* Fix alignment */ + Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*); + return !(layout->flags & 2); +} + void Perl_OS2_init(char **env) { + Perl_OS2_init3(env, 0, 0); +} + +void +Perl_OS2_init3(char **env, void **preg, int flags) +{ char *shell; + _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); MALLOC_INIT; + + check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg); + settmppath(); OS2_Perl_data.xs_init = &Xs_OS2_init; - _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); - if (environ == NULL && env) { - environ = env; - } if ( (shell = getenv("PERL_SH_DRIVE")) ) { New(1304, PL_sh_path, strlen(SH_PATH) + 1, char); strcpy(PL_sh_path, SH_PATH); diff --git a/os2/os2ish.h b/os2/os2ish.h index 7f3393b..ede75fb 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -210,31 +210,56 @@ int pthread_create(pthread_t *tid, const pthread_attr_t *attr, #endif /* USE_THREADS */ void Perl_OS2_init(char **); +void Perl_OS2_init3(char **envp, void **excH, int flags); +void Perl_OS2_term(void **excH, int exitstatus, int flags); -/* XXX This code hideously puts env inside: */ +/* The code without INIT3 hideously puts env inside: */ +/* These ones should be in the same block as PERL_SYS_TERM() */ #ifdef PERL_CORE -# define PERL_SYS_INIT3(argcp, argvp, envp) STMT_START { \ + +# define PERL_SYS_INIT3(argcp, argvp, envp) \ + { void *xreg[2]; \ _response(argcp, argvp); \ _wildcard(argcp, argvp); \ - Perl_OS2_init(*envp); } STMT_END -# define PERL_SYS_INIT(argcp, argvp) STMT_START { \ + Perl_OS2_init3(*envp, xreg, 0) + +# define PERL_SYS_INIT(argcp, argvp) { \ + { void *xreg[2]; \ _response(argcp, argvp); \ _wildcard(argcp, argvp); \ - Perl_OS2_init(NULL); } STMT_END + Perl_OS2_init3(NULL, xreg, 0) + #else /* Compiling embedded Perl or Perl extension */ -# define PERL_SYS_INIT3(argcp, argvp, envp) STMT_START { \ - Perl_OS2_init(*envp); } STMT_END -# define PERL_SYS_INIT(argcp, argvp) STMT_START { \ - Perl_OS2_init(NULL); } STMT_END + +# define PERL_SYS_INIT3(argcp, argvp, envp) \ + { void *xreg[2]; \ + Perl_OS2_init3(*envp, xreg, 0) +# define PERL_SYS_INIT(argcp, argvp) { \ + { void *xreg[2]; \ + Perl_OS2_init3(NULL, xreg, 0) #endif +#define FORCE_EMX_DEINIT_EXIT 1 +#define FORCE_EMX_DEINIT_CRT_TERM 2 +#define FORCE_EMX_DEINIT_RUN_ATEXIT 4 + +#define PERL_SYS_TERM2(xreg,flags) \ + Perl_OS2_term(xreg, 0, flags); \ + MALLOC_TERM + +#define PERL_SYS_TERM1(xreg) \ + Perl_OS2_term(xreg, 0, FORCE_EMX_DEINIT_RUN_ATEXIT) + +/* This one should come in pair with PERL_SYS_INIT() and in the same block */ +#define PERL_SYS_TERM() \ + PERL_SYS_TERM1(xreg); \ + } + #ifndef __EMX__ # define PERL_CALLCONV _System #endif -#define PERL_SYS_TERM() MALLOC_TERM - /* #define PERL_SYS_TERM() STMT_START { \ if (Perl_HAB_set) WinTerminate(Perl_hab); } STMT_END */ diff --git a/os2/perlrexx.c b/os2/perlrexx.c new file mode 100644 index 0000000..6c0ab93 --- /dev/null +++ b/os2/perlrexx.c @@ -0,0 +1,462 @@ +#define INCL_DOSPROCESS +#define INCL_DOSSEMAPHORES +#define INCL_DOSMODULEMGR +#define INCL_DOSMISC +#define INCL_DOSEXCEPTIONS +#define INCL_DOSERRORS +#define INCL_REXXSAA +#include + +/* + * "The Road goes ever on and on, down from the door where it began." + */ + +#ifdef OEMVS +#ifdef MYMALLOC +/* sbrk is limited to first heap segement so make it big */ +#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) +#else +#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) +#endif +#endif + + +#include "EXTERN.h" +#include "perl.h" + +static void xs_init (pTHX); +static PerlInterpreter *my_perl; + +#if defined (__MINT__) || defined (atarist) +/* The Atari operating system doesn't have a dynamic stack. The + stack size is determined from this value. */ +long _stksize = 64 * 1024; +#endif + +/* Register any extra external extensions */ + +/* Do not delete this line--writemain depends on it */ +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); + +static void +xs_init(pTHX) +{ + char *file = __FILE__; + dXSUB_SYS; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); +} + +int perlos2_is_inited; + +static void +init_perlos2(void) +{ +/* static char *env[1] = {NULL}; */ + + Perl_OS2_init3(0, 0, 0); +} + +static int +init_perl(int doparse) +{ + int exitstatus; + char *argv[3] = {"perl_in_REXX", "-e", ""}; + + if (!perlos2_is_inited) { + perlos2_is_inited = 1; + init_perlos2(); + } + if (my_perl) + return 1; + if (!PL_do_undump) { + my_perl = perl_alloc(); + if (!my_perl) + return 0; + perl_construct(my_perl); + PL_perl_destruct_level = 1; + } + if (!doparse) + return 1; + exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); + return !exitstatus; +} + +/* The REXX-callable entrypoints ... */ + +ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + int exitstatus; + char buf[256]; + char *argv[3] = {"perl_from_REXX", "-e", buf}; + ULONG ret; + + if (rargc != 1) { + sprintf(retstr->strptr, "one argument expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + if (rargv[0].strlength >= sizeof(buf)) { + sprintf(retstr->strptr, + "length of the argument %ld exceeds the maximum %ld", + rargv[0].strlength, (long)sizeof(buf) - 1); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + + if (!init_perl(0)) + return 1; + + memcpy(buf, rargv[0].strptr, rargv[0].strlength); + buf[rargv[0].strlength] = 0; + + exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); + if (!exitstatus) { + exitstatus = perl_run(my_perl); + } + + perl_destruct(my_perl); + perl_free(my_perl); + my_perl = 0; + + if (exitstatus) + ret = 1; + else { + ret = 0; + sprintf(retstr->strptr, "%s", "ok"); + retstr->strlength = strlen (retstr->strptr); + } + PERL_SYS_TERM1(0); + return ret; +} + +ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + if (rargc != 0) { + sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + PERL_SYS_TERM1(0); + return 0; +} + +ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + if (rargc != 0) { + sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + if (!my_perl) { + sprintf(retstr->strptr, "no perl interpreter present"); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + perl_destruct(my_perl); + perl_free(my_perl); + my_perl = 0; + + sprintf(retstr->strptr, "%s", "ok"); + retstr->strlength = strlen (retstr->strptr); + return 0; +} + + +ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + if (rargc != 0) { + sprintf(retstr->strptr, "no argument expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + if (!init_perl(1)) + return 1; + + sprintf(retstr->strptr, "%s", "ok"); + retstr->strlength = strlen (retstr->strptr); + return 0; +} + +ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + SV *res, *in; + STRLEN len; + char *str; + + if (rargc != 1) { + sprintf(retstr->strptr, "one argument expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + + if (!init_perl(1)) + return 1; + + { + dSP; + int ret; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength)); + eval_sv(in, G_SCALAR); + SPAGAIN; + res = POPs; + PUTBACK; + + ret = 0; + if (SvTRUE(ERRSV) || !SvOK(res)) + ret = 1; + str = SvPV(res, len); + if (len <= 256 /* Default buffer is 256-char long */ + || !DosAllocMem((PPVOID)&retstr->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT)) { + memcpy(retstr->strptr, str, len); + retstr->strlength = len; + } else + ret = 1; + + FREETMPS; + LEAVE; + + return ret; + } +} +#define INCL_DOSPROCESS +#define INCL_DOSSEMAPHORES +#define INCL_DOSMODULEMGR +#define INCL_DOSMISC +#define INCL_DOSEXCEPTIONS +#define INCL_DOSERRORS +#define INCL_REXXSAA +#include <os2.h> + +/* + * "The Road goes ever on and on, down from the door where it began." + */ + +#ifdef OEMVS +#ifdef MYMALLOC +/* sbrk is limited to first heap segement so make it big */ +#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) +#else +#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) +#endif +#endif + + +#include "EXTERN.h" +#include "perl.h" + +static void xs_init (pTHX); +static PerlInterpreter *my_perl; + +#if defined (__MINT__) || defined (atarist) +/* The Atari operating system doesn't have a dynamic stack. The + stack size is determined from this value. */ +long _stksize = 64 * 1024; +#endif + +/* Register any extra external extensions */ + +/* Do not delete this line--writemain depends on it */ +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); + +static void +xs_init(pTHX) +{ + char *file = __FILE__; + dXSUB_SYS; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); +} + +int perlos2_is_inited; + +static void +init_perlos2(void) +{ +/* static char *env[1] = {NULL}; */ + + Perl_OS2_init3(0, 0, 0); +} + +static int +init_perl(int doparse) +{ + int exitstatus; + char *argv[3] = {"perl_in_REXX", "-e", ""}; + + if (!perlos2_is_inited) { + perlos2_is_inited = 1; + init_perlos2(); + } + if (my_perl) + return 1; + if (!PL_do_undump) { + my_perl = perl_alloc(); + if (!my_perl) + return 0; + perl_construct(my_perl); + PL_perl_destruct_level = 1; + } + if (!doparse) + return 1; + exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); + return !exitstatus; +} + +/* The REXX-callable entrypoints ... */ + +ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + int exitstatus; + char buf[256]; + char *argv[3] = {"perl_from_REXX", "-e", buf}; + ULONG ret; + + if (rargc != 1) { + sprintf(retstr->strptr, "one argument expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + if (rargv[0].strlength >= sizeof(buf)) { + sprintf(retstr->strptr, + "length of the argument %ld exceeds the maximum %ld", + rargv[0].strlength, (long)sizeof(buf) - 1); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + + if (!init_perl(0)) + return 1; + + memcpy(buf, rargv[0].strptr, rargv[0].strlength); + buf[rargv[0].strlength] = 0; + + exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); + if (!exitstatus) { + exitstatus = perl_run(my_perl); + } + + perl_destruct(my_perl); + perl_free(my_perl); + my_perl = 0; + + if (exitstatus) + ret = 1; + else { + ret = 0; + sprintf(retstr->strptr, "%s", "ok"); + retstr->strlength = strlen (retstr->strptr); + } + PERL_SYS_TERM1(0); + return ret; +} + +ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + if (rargc != 0) { + sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + PERL_SYS_TERM1(0); + return 0; +} + +ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + if (rargc != 0) { + sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + if (!my_perl) { + sprintf(retstr->strptr, "no perl interpreter present"); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + perl_destruct(my_perl); + perl_free(my_perl); + my_perl = 0; + + sprintf(retstr->strptr, "%s", "ok"); + retstr->strlength = strlen (retstr->strptr); + return 0; +} + + +ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + if (rargc != 0) { + sprintf(retstr->strptr, "no argument expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + if (!init_perl(1)) + return 1; + + sprintf(retstr->strptr, "%s", "ok"); + retstr->strlength = strlen (retstr->strptr); + return 0; +} + +ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, + PCSZ queuename, PRXSTRING retstr) +{ + SV *res, *in; + STRLEN len; + char *str; + + if (rargc != 1) { + sprintf(retstr->strptr, "one argument expected, got %ld", rargc); + retstr->strlength = strlen (retstr->strptr); + return 1; + } + + if (!init_perl(1)) + return 1; + + { + dSP; + int ret; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength)); + eval_sv(in, G_SCALAR); + SPAGAIN; + res = POPs; + PUTBACK; + + ret = 0; + if (SvTRUE(ERRSV) || !SvOK(res)) + ret = 1; + str = SvPV(res, len); + if (len <= 256 /* Default buffer is 256-char long */ + || !DosAllocMem((PPVOID)&retstr->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT)) { + memcpy(retstr->strptr, str, len); + retstr->strlength = len; + } else + ret = 1; + + FREETMPS; + LEAVE; + + return ret; + } +} diff --git a/perl.c b/perl.c index 322960d..91efa0f 100644 --- a/perl.c +++ b/perl.c @@ -3440,7 +3440,8 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register } /* else what? */ } #endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ - for (; *env; env++) { + if (env) + for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; *s++ = '\0'; @@ -3450,7 +3451,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register sv = newSVpv(s--,0); (void)hv_store(hv, *env, s - *env, sv, 0); *s = '='; - } + } #ifdef NEED_ENVIRON_DUP_FOR_MODIFY if (dup_env_base) { char **dup_env; diff --git a/t/op/write.t b/t/op/write.t index c37de85..a86b4eb 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -273,7 +273,8 @@ else # 12..44: scary format testing from Merijn H. Brand -if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos') { +if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || + ($^O eq 'os2' and not eval '$OS2::can_fork')) { foreach (12..44) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; } exit(0); } -- 2.7.4