dll.xs

来自「Altera recommends the following system c」· XS 代码 · 共 73 行

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define INCL_BASE
#define INCL_REXXSAA
#include <os2emx.h>

static RXSTRING * strs;
static int	  nstrs;
static char *	  trace;

static void
needstrs(int n)
{
    if (n > nstrs) {
	if (strs)
	    free(strs);
	nstrs = 2 * n;
	strs = malloc(nstrs * sizeof(RXSTRING));
    }
}

MODULE = OS2::DLL		PACKAGE = OS2::DLL

BOOT:
    needstrs(8);
    trace = getenv("PERL_REXX_DEBUG");

SV *
_call(name, address, queue="SESSION", ...)
	char *		name
	void *		address
	char *		queue
 CODE:
   {
       ULONG	rc;
       int	argc, i;
       RXSTRING	result;
       UCHAR	resbuf[256];
       RexxFunctionHandler *fcn = address;
       argc = items-3;
       needstrs(argc);
       if (trace)
	   fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
       for (i = 0; i < argc; ++i) {
	   STRLEN len;
	   char *ptr = SvPV(ST(3+i), len);
	   MAKERXSTRING(strs[i], ptr, len);
	   if (trace)
	       fprintf(stderr, " '%.*s'", len, ptr);
       }
       if (!*queue)
	   queue = "SESSION";
       if (trace)
	   fprintf(stderr, "\n");
       MAKERXSTRING(result, resbuf, sizeof resbuf);
       rc = fcn(name, argc, strs, queue, &result);
       if (trace)
	   fprintf(stderr, "  rc=%X, result='%.*s'\n", rc,
		   result.strlength, result.strptr);
       ST(0) = sv_newmortal();
       if (rc == 0) {
	   if (result.strptr)
	       sv_setpvn(ST(0), result.strptr, result.strlength);
	   else
	       sv_setpvn(ST(0), "", 0);
       }
       if (result.strptr && result.strptr != resbuf)
	   DosFreeMem(result.strptr);
   }