OS/2 multi-architecture

Message-ID: <20010723192949.A14802@math.ohio-state.edu>

p4raw-id: //depot/perl@11462

1 files changed, 462 insertions, 0 deletions

diff --git a/os2/perlrexx.c b/os2/perlrexx.c
new file mode 100644
index 0000000000..6c0ab93e88
--- /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 <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;
+  }
+}