Front page | perl.perl5.porters |
Postings from July 2001
[PATCH 5.7.2] OS/2 multi-architecture
From:
Ilya Zakharevich
Date:
July 23, 2001 16:29
Subject:
[PATCH 5.7.2] OS/2 multi-architecture
Message ID:
20010723192949.A14802@math.ohio-state.edu
This patch allows using OS/2 Perl's DLL from any process, not
necessarily from the process using exactly the same CRT DLL. This
requires a lot of voodoo, since the CRT DLL is initialized from the
executable, so Perl DLL needs to "mock the initialization" (similarly
with termination, including longjmp'ing out of exit() to run atexit()
stuff ;-).
All the voodoo is performed only if the CRT is judged to be
uninitialized (environ == NULL). I used the occasion to add a similar
workaround to perl.c, so that Perl would never dump core with environ
== NULL (though this is no more possible under OS/2).
To test the stuff, we build 6 different flavors of perl*.exe with
different (and differently statically/dynamically linked) CRL
components libraries. Test targets in Makefile are updated to easily
batch-test all these flavors (modulo the test engine bugs I reported
yesterday), as in
env PERL_TEST_NOVREXX=1 make all_harness
(PERL_TEST_NOVREXX controls testing VREXX library, which creates
windows with buttons to press - not very convenient if you need to do
it 6 times with intervals of several minutes ;-).
Now, when Perl's DLL *may* be called from any executable, I provide a
tool so that Perl's DLL *can* be called from any well-designed OS/2
application. The idea is that OS/2 has a standard scripting language
(REXX), and most of "nice" application allows REXX scripting.
Additionally, REXX allows installation of functions (with "REXX
calling conventions") from an arbitrary DLL.
A new file is added (os2/perlrexx.c) and new targets to build
perlrexx.dll - which exports interpreter-creation/termination and
eval-a-string functions with the REXX calling conventions. Due to the
current (mis)design of PerlIO, to flush the buffers one needs to call
PERLTERM(). Since this has an unfortunate side effect of closing all
stdin/stdout/stderr, this should be done the last thing in a REXX
script.
File-by-file (os2/perlrexx.c is a new file!):
mg.c Remove an OS/2 "optimization" which was
too optimistic - and no longer valid;
perl.c Allow environ == NULL
configpm Unset $Config{d_fork} unless executable can fork;
t/op/write.t Does not use $Config{d_fork}, so manually
check OS/2 forking;
makedef.pl Export new OS/2 symbols;
MANIFEST new file added;
os2/os2.c Allow EMX initialization and CRT DLL
initialization if needed;
Allow running atexit() without exiting
(atexit list is not cleared, so do
this only once!);
Set $OS2::can_fork on startup;
os2/os2ish.h Allocate space near top of the stack, and
call the new initialization routines
via PERL_SYS_INIT() PERL_SYS_TERM();
[PERL_SYS_INIT/TERM() assumed to be in
the same block];
os2/Makefile.SHs New targets for testing and perlrexx.dll
Use FIRST_MAKEFILE= insteadof MAKEFILE=
for AOUT build;
Put Config.pm etc dependencies for AOUT build;
AOUT biuld was not handling OS2::DLL
which is inside OS2::REXX directory
os2/perlrexx.c REXX-callable embedded Perl;
[RxLoadFunc for PERLEVAL PERLTERM from perlrexx]
os2/OS2/REXX/t/rx_vrexx.t Skip the test if PERL_TEST_NOVREXX is set;
Enjoy,
Ilya
--- ./mg.c-pre-system Mon Jun 25 01:58:08 2001
+++ ./mg.c Mon Jul 23 01:58:08 2001
@@ -2109,11 +2109,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++)
--- ./perl.c-pre-system Sun Jun 24 06:09:04 2001
+++ ./perl.c Fri Jul 20 18:19:52 2001
@@ -3429,7 +3429,8 @@ S_init_postdump_symbols(pTHX_ register i
} /* else what? */
}
#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
- for (; *env; env++) {
+ if (env)
+ for (; *env; env++) {
if (!(s = strchr(*env,'=')))
continue;
*s++ = '\0';
@@ -3439,7 +3440,7 @@ S_init_postdump_symbols(pTHX_ register i
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;
--- ./configpm-pre-system Sat Jun 2 09:09:06 2001
+++ ./configpm Sun Jul 22 23:52:20 2001
@@ -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 {
--- ./t/op/write.t-pre-system Fri Jun 22 14:32:44 2001
+++ ./t/op/write.t Mon Jul 23 00:36:12 2001
@@ -273,7 +273,8 @@ else
# 12..44: scary format testing from Merijn H. Brand
-if ($^O eq 'VMS' || $^O eq 'MSWin32') {
+if ($^O eq 'VMS' || $^O eq 'MSWin32' ||
+ ($^O eq 'os2' and not eval '$OS2::can_fork')) {
foreach (12..44) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; }
exit(0);
}
--- ./makedef.pl-pre-system Wed Jun 27 23:36:58 2001
+++ ./makedef.pl Thu Jul 19 17:00:36 2001
@@ -294,6 +294,8 @@ elsif ($PLATFORM eq 'os2') {
ctermid
get_sysinfo
Perl_OS2_init
+ Perl_OS2_init3
+ Perl_OS2_term
OS2_Perl_data
dlopen
dlsym
--- ./MANIFEST-pre-system Mon Jun 25 15:09:50 2001
+++ ./MANIFEST Mon Jul 23 13:54:04 2001
@@ -1567,6 +1567,7 @@ os2/os2add.sym Overriding symbols to e
os2/os2ish.h Header for OS/2
os2/os2thread.h pthread-like typedefs
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
--- ./os2/os2.c-pre-system Mon Jul 2 12:45:12 2001
+++ ./os2/os2.c Sun Jul 22 23:48:04 2001
@@ -184,6 +184,8 @@ os2_cond_wait(perl_cond *c, perl_mutex *
}
#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
/*****************************************************************************/
/* 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,
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));
@@ -1002,7 +1017,7 @@ do_spawn3(pTHX_ char *cmd, int execf, in
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)
@@ -1011,8 +1026,11 @@ do_spawn3(pTHX_ char *cmd, int execf, in
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"),
@@ -2275,7 +2293,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);
@@ -2296,18 +2317,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);
--- ./os2/os2ish.h-pre-system Wed Jun 27 23:37:32 2001
+++ ./os2/os2ish.h Fri Jul 20 16:18:24 2001
@@ -210,30 +210,55 @@ int pthread_create(pthread_t *tid, const
#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 */
--- ./os2/Makefile.SHs-pre-system Tue Jun 26 10:55:58 2001
+++ ./os2/Makefile.SHs Mon Jul 23 14:23:30 2001
@@ -40,6 +40,9 @@ AOUT_LIBPERL_DLL = libperl_dll$aout_lib_
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.s
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!
--- ./os2/perlrexx.c-pre-system Sat Jul 21 03:23:10 2001
+++ ./os2/perlrexx.c Sat Jul 21 15:27:12 2001
@@ -0,0 +1,231 @@
+#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;
+ }
+}
--- ./os2/OS2/REXX/t/rx_vrexx.t-pre-system Mon Jun 25 01:33:44 2001
+++ ./os2/OS2/REXX/t/rx_vrexx.t Mon Jul 23 02:55:48 2001
@@ -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;
}
}
-
[PATCH 5.7.2] OS/2 multi-architecture
by Ilya Zakharevich