X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/764df951e4265f932b70873d1d56431da2d2763f..308d26d578ee2df470607dca403b28c61f26c974:/os2/perlrexx.c diff --git a/os2/perlrexx.c b/os2/perlrexx.c index 6c0ab93..fbeb493 100644 --- a/os2/perlrexx.c +++ b/os2/perlrexx.c @@ -27,6 +27,10 @@ static void xs_init (pTHX); static PerlInterpreter *my_perl; +ULONG PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr); +ULONG PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr); +ULONG PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr); + #if defined (__MINT__) || defined (atarist) /* The Atari operating system doesn't have a dynamic stack. The stack size is determined from this value. */ @@ -81,6 +85,26 @@ init_perl(int doparse) return !exitstatus; } +static char last_error[4096]; + +static int +seterr(char *format, ...) +{ + va_list va; + char *s = last_error; + + va_start(va, format); + if (s[0]) { + s += strlen(s); + if (s[-1] != '\n') { + snprintf(s, sizeof(last_error) - (s - last_error), "\n"); + s += strlen(s); + } + } + vsnprintf(s, sizeof(last_error) - (s - last_error), format, va); + return 1; +} + /* The REXX-callable entrypoints ... */ ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, @@ -91,18 +115,11 @@ ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, 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 (rargc != 1) + return seterr("one argument expected, got %ld", rargc); + if (rargv[0].strlength >= sizeof(buf)) + return seterr("length of the argument %ld exceeds the maximum %ld", + rargv[0].strlength, (long)sizeof(buf) - 1); if (!init_perl(0)) return 1; @@ -133,11 +150,8 @@ ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, 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; - } + if (rargc != 0) + return seterr("no arguments expected, got %ld", rargc); PERL_SYS_TERM1(0); return 0; } @@ -145,16 +159,10 @@ ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, 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; - } + if (rargc != 0) + return seterr("no arguments expected, got %ld", rargc); + if (!my_perl) + return seterr("no perl interpreter present"); perl_destruct(my_perl); perl_free(my_perl); my_perl = 0; @@ -168,11 +176,8 @@ ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, 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 (rargc != 0) + return seterr("no argument expected, got %ld", rargc); if (!init_perl(1)) return 1; @@ -181,21 +186,36 @@ ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, return 0; } -ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) +ULONG +PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) +{ + int len = strlen(last_error); + + if (len <= 256 /* Default buffer is 256-char long */ + || !DosAllocMem((PPVOID)&retstr->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT)) { + memcpy(retstr->strptr, last_error, len); + retstr->strlength = len; + } else { + strcpy(retstr->strptr, "[Not enough memory to copy the errortext]"); + 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; + STRLEN len, n_a; char *str; - if (rargc != 1) { - sprintf(retstr->strptr, "one argument expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } + last_error[0] = 0; + if (rargc != 1) + return seterr("one argument expected, got %ld", rargc); if (!init_perl(1)) - return 1; + return seterr("error initializing perl"); { dSP; @@ -212,8 +232,10 @@ ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PUTBACK; ret = 0; - if (SvTRUE(ERRSV) || !SvOK(res)) - ret = 1; + if (SvTRUE(ERRSV)) + ret = seterr(SvPV(ERRSV, n_a)); + if (!SvOK(res)) + ret = seterr("undefined value returned by Perl-in-REXX"); str = SvPV(res, len); if (len <= 256 /* Default buffer is 256-char long */ || !DosAllocMem((PPVOID)&retstr->strptr, len, @@ -221,7 +243,7 @@ ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, memcpy(retstr->strptr, str, len); retstr->strlength = len; } else - ret = 1; + ret = seterr("Not enough memory for the return string of Perl-in-REXX"); FREETMPS; LEAVE; @@ -229,234 +251,72 @@ ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, 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) +ULONG +PERLEVALSUBCOMMAND( + const RXSTRING *command, /* command to issue */ + PUSHORT flags, /* error/failure flags */ + PRXSTRING retstr ) /* return code */ { - int exitstatus; - char buf[256]; - char *argv[3] = {"perl_from_REXX", "-e", buf}; - ULONG ret; + ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr); - 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; + if (rc) + *flags = RXSUBCOM_ERROR; /* raise error condition */ - 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; + return 0; /* finished */ } -ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) +#define ArrLength(a) (sizeof(a)/sizeof(*(a))) + +static const struct { + char *name; + RexxFunctionHandler *f; +} funcs[] = { + {"PERL", (RexxFunctionHandler *)&PERL}, + {"PERLTERM", (RexxFunctionHandler *)&PERLTERM}, + {"PERLINIT", (RexxFunctionHandler *)&PERLINIT}, + {"PERLEXIT", (RexxFunctionHandler *)&PERLEXIT}, + {"PERLEVAL", (RexxFunctionHandler *)&PERLEVAL}, + {"PERLLASTERROR", (RexxFunctionHandler *)&PERLLASTERROR}, + {"PERLDROPALL", (RexxFunctionHandler *)&PERLDROPALL}, + {"PERLDROPALLEXIT", (RexxFunctionHandler *)&PERLDROPALLEXIT}, + /* Should be the last entry */ + {"PERLEXPORTALL", (RexxFunctionHandler *)&PERLEXPORTALL} + }; + +ULONG +PERLEXPORTALL(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; + int i = -1; - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); - return 0; + while (++i < ArrLength(funcs) - 1) + RexxRegisterFunctionExe(funcs[i].name, funcs[i].f); + RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL); + retstr->strlength = 0; + return 0; } - -ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) +ULONG +PERLDROPALL(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; + int i = -1; - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); - return 0; + while (++i < ArrLength(funcs)) + RexxDeregisterFunction(funcs[i].name); + RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); + retstr->strlength = 0; + return 0; } -ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) +ULONG +PERLDROPALLEXIT(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; - } + int i = -1; + + while (++i < ArrLength(funcs)) + RexxDeregisterFunction(funcs[i].name); + RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); + PERL_SYS_TERM1(0); + retstr->strlength = 0; + return 0; }