OS/2 multi-architecture
Ilya Zakharevich [Mon, 23 Jul 2001 19:29:49 +0000 (15:29 -0400)]
Message-ID: <20010723192949.A14802@math.ohio-state.edu>

p4raw-id: //depot/perl@11462

MANIFEST
configpm
makedef.pl
mg.c
os2/Makefile.SHs
os2/OS2/REXX/t/rx_vrexx.t
os2/os2.c
os2/os2ish.h
os2/perlrexx.c [new file with mode: 0644]
perl.c
t/op/write.t

index cb7db4f..3d7b42f 100644 (file)
--- 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
index b98bf82..86abd6d 100755 (executable)
--- 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 {
index 6ac99f4..4c670e5 100644 (file)
@@ -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 (file)
--- 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++)
index 8140aa5..be5aad1 100644 (file)
@@ -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 </dev/tty
+perlrexx: perlrexx.dll
+       @sh -c true
+
+perlrexx.c: os2/perlrexx.c
+       @cp -f os2/$@ $@
+
+# Remove -Zexe, add -Zdll -Zso.  No stack needed
+SO_CLDFLAGS = -Zdll -Zso -Zomf -Zmt -Zsys
+
+# A callable-from-REXX DLL
+
+perlrexx.dll: perlrexx$(OBJ_EXT) perlrexx.def
+       $(SHRPENV) $(CC) $(SO_CLDFLAGS) $(CCDLFLAGS) -o $@ perlrexx$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) perlrexx.def
+
+perlrexx.def: miniperl \$(_preplibrary)
+       echo    "LIBRARY 'perlrexx' INITINSTANCE TERMINSTANCE"  > 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 </dev/tty
+test_prep_perl_: test_prep_pre miniperl_ ./perl_$(EXE_EXT)
+       PERL=./perl_ $(MAKE) _test_prep
 
-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
+test_prep_various: test_prep_pre miniperl $(dynamic_ext) $(TEST_PERL_DLL)
+
+test_prep_perl_sys: test_prep_various ./perl_sys$(EXE_EXT)
+       PERL=./perl_sys $(MAKE) _test_prep
+
+test_prep_perl___: test_prep_various ./perl___$(EXE_EXT)
+       PERL=./perl___ $(MAKE) _test_prep
+
+test_prep_perl_stat: test_prep_various ./perl_stat$(EXE_EXT)
+       PERL=./perl_stat $(MAKE) _test_prep
+
+test_prep_perl_stat_aout: test_prep_various ./perl_stat_aout$(EXE_EXT)
+       PERL=./perl_stat_aout $(MAKE) _test_prep
+
+aout_test: test_prep_perl_
+       PERL=./perl_ $(MAKE) _test
+
+aout_harness: test_prep_perl_
+       -PERL=./perl_ $(MAKE) TESTFILE=harness _test $(REDIR_TEST)
+
+sys_test: test_prep_perl_sys
+       PERL=./perl_sys $(MAKE) _test
+
+sys_harness: test_prep_perl_sys
+       -PERL=./perl_sys $(MAKE) TESTFILE=harness _test $(REDIR_TEST)
+
+stat_test: test_prep_perl_stat
+       PERL=./perl_stat $(MAKE) _test
+
+stat_harness: test_prep_perl_stat
+       -PERL=./perl_stat $(MAKE) TESTFILE=harness _test $(REDIR_TEST)
+
+stat_aout_test: test_prep_perl_stat_aout
+       PERL=./perl_stat_aout $(MAKE) _test
+
+stat_aout_harness: test_prep_perl_stat_aout
+       -PERL=./perl_stat_aout $(MAKE) TESTFILE=harness _test $(REDIR_TEST)
+
+perl___test: test_prep_perl___
+       PERL=./perl___ $(MAKE) _test
+
+perl___harness: test_prep_perl___
+       -PERL=./perl___ $(MAKE) TESTFILE=harness _test $(REDIR_TEST)
+
+all_test: test aout_test perl___test sys_test stat_test stat_aout_test
+
+all_harness: test_harness aout_harness perl___harness sys_harness stat_harness stat_aout_harness
 
 !NO!SUBS!
 
@@ -283,6 +390,10 @@ done
 $spitshell >>Makefile <<!GROK!THIS!
 .PRECIOUS : $preci
 
+# Set this to FORCE to force a rebuilt of aout extensions
+
+AOUT_EXTENSIONS_FORCE = 
+
 !GROK!THIS!
 
 for d in $ddirs
@@ -296,8 +407,8 @@ lib/auto/$p/*/%.a : $d/%/Makefile.aout
        @cd $d/\$(basename \$(notdir \$@)) ; make -f Makefile.aout config || echo "\$(MAKE) config failed, continuing anyway..."
        cd $d/\$(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 
+$d/%/Makefile.aout : miniperl_ \$(_preplibrary) \$(AOUT_EXTENSIONS_FORCE)
+       cd \$(dir \$@) ; ../../../../miniperl_ -I ../../../../lib Makefile.PL FIRST_MAKEFILE=Makefile.aout INSTALLDIRS=perl 
 
 !GROK!THIS!
 
@@ -311,19 +422,25 @@ lib/auto/$p/*/%.a : $d/%/Makefile.aout
        @cd $d/\$(basename \$(notdir \$@)) ; make -f Makefile.aout config || echo "\$(MAKE) config failed, continuing anyway..."
        cd $d/\$(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 
+$d/%/Makefile.aout : miniperl_ \$(_preplibrary) \$(AOUT_EXTENSIONS_FORCE)
+       cd \$(dir \$@) ; ../../../miniperl_ -I ../../../lib Makefile.PL FIRST_MAKEFILE=Makefile.aout INSTALLDIRS=perl 
 
 !GROK!THIS!
 
 done
 
+# We need to special-case OS2/DLL/DLL.a, since the recipe above will
+# try to find it in ext/OS2/DLL
+
 $spitshell >>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!
index b0621f4..3611894 100644 (file)
@@ -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;
     }
 }
index bfe6e9f..d22553a 100644 (file)
--- 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 <emx/startup.h>
+
+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);
index 7f3393b..ede75fb 100644 (file)
@@ -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 (file)
index 0000000..6c0ab93
--- /dev/null
@@ -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 <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;
+  }
+}
+#define INCL_DOSPROCESS
+#define INCL_DOSSEMAPHORES
+#define INCL_DOSMODULEMGR
+#define INCL_DOSMISC
+#define INCL_DOSEXCEPTIONS
+#define INCL_DOSERRORS
+#define INCL_REXXSAA
+#include &lt;os2.h&gt;
+
+/*
+ * "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-&gt;strptr, "one argument expected, got %ld", rargc);
+       retstr-&gt;strlength = strlen (retstr-&gt;strptr);
+       return 1;
+    }
+    if (rargv[0].strlength &gt;= sizeof(buf)) {
+       sprintf(retstr-&gt;strptr,
+               "length of the argument %ld exceeds the maximum %ld",
+               rargv[0].strlength, (long)sizeof(buf) - 1);
+       retstr-&gt;strlength = strlen (retstr-&gt;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-&gt;strptr, "%s", "ok");
+       retstr-&gt;strlength = strlen (retstr-&gt;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-&gt;strptr, "no arguments expected, got %ld", rargc);
+       retstr-&gt;strlength = strlen (retstr-&gt;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-&gt;strptr, "no arguments expected, got %ld", rargc);
+       retstr-&gt;strlength = strlen (retstr-&gt;strptr);
+       return 1;
+    }
+    if (!my_perl) {
+       sprintf(retstr-&gt;strptr, "no perl interpreter present");
+       retstr-&gt;strlength = strlen (retstr-&gt;strptr);
+       return 1;
+    }
+    perl_destruct(my_perl);
+    perl_free(my_perl);
+    my_perl = 0;
+
+    sprintf(retstr-&gt;strptr, "%s", "ok");
+    retstr-&gt;strlength = strlen (retstr-&gt;strptr);
+    return 0;
+}
+
+
+ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv,
+                    PCSZ queuename, PRXSTRING retstr)
+{
+    if (rargc != 0) {
+       sprintf(retstr-&gt;strptr, "no argument expected, got %ld", rargc);
+       retstr-&gt;strlength = strlen (retstr-&gt;strptr);
+       return 1;
+    }
+    if (!init_perl(1))
+       return 1;
+
+    sprintf(retstr-&gt;strptr, "%s", "ok");
+    retstr-&gt;strlength = strlen (retstr-&gt;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-&gt;strptr, "one argument expected, got %ld", rargc);
+       retstr-&gt;strlength = strlen (retstr-&gt;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 &lt;= 256                  /* Default buffer is 256-char long */
+       || !DosAllocMem((PPVOID)&amp;retstr-&gt;strptr, len,
+                       PAG_READ|PAG_WRITE|PAG_COMMIT)) {
+           memcpy(retstr-&gt;strptr, str, len);
+           retstr-&gt;strlength = len;
+    } else
+       ret = 1;
+
+    FREETMPS;
+    LEAVE;
+
+    return ret;
+  }
+}
diff --git a/perl.c b/perl.c
index 322960d..91efa0f 100644 (file)
--- 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;
index c37de85..a86b4eb 100755 (executable)
@@ -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);
 }