dslinux/user/perl/os2/OS2/REXX Changes MANIFEST Makefile.PL REXX.pm REXX.xs
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:26 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/os2/OS2/REXX
In directory antilope:/tmp/cvs-serv17422/os2/OS2/REXX
Added Files:
Changes MANIFEST Makefile.PL REXX.pm REXX.xs
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: MANIFEST ---
Changes
MANIFEST
Makefile.PL
REXX.pm
REXX.xs
t/rx_cmprt.t
t/rx_dllld.t
t/rx_objcall.t
t/rx_sql.test
t/rx_tiesql.test
t/rx_tievar.t
t/rx_tieydb.t
t/rx_varset.t
t/rx_vrexx.t
--- NEW FILE: REXX.xs ---
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define INCL_BASE
#define INCL_REXXSAA
#include <os2emx.h>
#if 0
#define INCL_REXXSAA
#pragma pack(1)
#define _Packed
#include <rexxsaa.h>
#pragma pack()
#endif
extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
EXCEPTIONREGISTRATIONRECORD *,
CONTEXTRECORD *,
void *);
static RXSTRING * strs;
static int nstrs;
static SHVBLOCK * vars;
static int nvars;
static char * trace;
/*
static RXSTRING rxcommand = { 9, "RXCOMMAND" };
static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" };
static RXSTRING rxfunction = { 11, "RXFUNCTION" };
*/
static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
static ULONG PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
static ULONG PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret);
static RexxSubcomHandler SubCommandPerlEval;
#if 1
#define Set RXSHV_SET
#define Fetch RXSHV_FETCH
#define Drop RXSHV_DROPV
#else
#define Set RXSHV_SYSET
#define Fetch RXSHV_SYFET
#define Drop RXSHV_SYDRO
#endif
static long incompartment; /* May be used to unload the REXX */
static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
RexxFunctionHandler *);
static APIRET APIENTRY (*pRexxRegisterSubcomExe) (PCSZ pszEnvName, PFN pfnEntryPoint,
PUCHAR pUserArea);
static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest);
static SV* exec_cv;
/* Create a REXX compartment,
register `n' callbacks `handlers' with the REXX names `handlerNames',
evaluate the REXX expression `cmd'.
*/
static SV*
exec_in_REXX_with(pTHX_ char *cmd, int c, char **handlerNames, RexxFunctionHandler **handlers)
{
RXSTRING args[1];
RXSTRING inst[2];
RXSTRING result;
USHORT retcode;
LONG rc;
SV *res;
char *subs = 0;
int n = c, have_nl = 0;
char *ocmd = cmd, *s, *t;
incompartment++;
if (c)
Newxz(subs, c, char);
while (n--) {
rc = pRexxRegisterFunctionExe(handlerNames[n], handlers[n]);
if (rc == RXFUNC_DEFINED)
subs[n] = 1;
}
s = cmd;
while (*s) {
if (*s == '\n') { /* Is not preceeded by \r! */
Newx(cmd, 2*strlen(cmd)+1, char);
s = ocmd;
t = cmd;
while (*s) {
if (*s == '\n')
*t++ = '\r';
*t++ = *s++;
}
*t = 0;
break;
} else if (*s == '\r')
s++;
s++;
}
MAKERXSTRING(args[0], NULL, 0);
MAKERXSTRING(inst[0], cmd, strlen(cmd));
MAKERXSTRING(inst[1], NULL, 0);
MAKERXSTRING(result, NULL, 0);
rc = pRexxStart(0, args, /* No arguments */
"REXX_in_Perl", /* Returned on REXX' PARSE SOURCE,
and the "macrospace function name" */
inst, /* inst[0] - the code to execute,
inst[1] will contain tokens. */
"Perl", /* Pass string-cmds to this callback */
RXSUBROUTINE, /* Many arguments, maybe result */
NULL, /* No callbacks/exits to register */
&retcode, &result);
incompartment--;
n = c;
while (n--)
if (!subs[n])
pRexxDeregisterFunction(handlerNames[n]);
if (c)
Safefree(subs);
if (cmd != ocmd)
Safefree(cmd);
#if 0 /* Do we want to restore these? */
DosFreeModule(hRexxAPI);
DosFreeModule(hRexx);
#endif
if (RXSTRPTR(inst[1])) /* Free the tokenized version */
DosFreeMem(RXSTRPTR(inst[1]));
if (!RXNULLSTRING(result)) {
res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
DosFreeMem(RXSTRPTR(result));
} else {
res = NEWSV(729,0);
}
if (rc || SvTRUE(GvSV(PL_errgv))) {
if (SvTRUE(GvSV(PL_errgv))) {
STRLEN n_a;
Perl_croak(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
}
Perl_croak(aTHX_ "REXX compartment returned non-zero status %li", rc);
}
return res;
}
/* Call the Perl function given by name, or if name=0, by cv,
with the given arguments. Return the stringified result to REXX. */
static ULONG
PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
{
dTHX;
EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
int i, rc;
unsigned long len;
char *str;
SV *res;
dSP;
DosSetExceptionHandler(&xreg);
ENTER;
SAVETMPS;
PUSHMARK(SP);
#if 0
if (!my_perl) {
DosUnsetExceptionHandler(&xreg);
return 1;
}
#endif
for (i = 0; i < argc; ++i)
XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength)));
PUTBACK;
if (name)
rc = perl_call_pv(name, G_SCALAR | G_EVAL);
else if (cv)
rc = perl_call_sv(cv, G_SCALAR | G_EVAL);
else
rc = -1;
SPAGAIN;
if (rc == 1) /* must be! */
res = POPs;
if (rc == 1 && SvOK(res)) {
str = SvPVx(res, len);
if (len <= 256 /* Default buffer is 256-char long */
|| !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len,
PAG_READ|PAG_WRITE|PAG_COMMIT))) {
memcpy(ret->strptr, str, len);
ret->strlength = len;
} else
rc = 0;
} else
rc = 0;
PUTBACK ;
FREETMPS ;
LEAVE ;
DosUnsetExceptionHandler(&xreg);
return rc == 1 ? 0 : 1; /* 0 means SUCCESS */
}
static ULONG
PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
{
SV *cv = exec_cv;
exec_cv = NULL;
return PERLCALLcv(NULL, cv, argc, argv, queue, ret);
}
static ULONG
PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret)
{
return PERLCALLcv(name, Nullsv, argc, argv, queue, ret);
}
RexxFunctionHandler* PF = &PERLSTART;
char* PF_name = "StartPerl";
#define REXX_eval_with(cmd,name,cv) \
( exec_cv = cv, exec_in_REXX_with(aTHX_ (cmd),1, &(name), &PF))
#define REXX_call(cv) REXX_eval_with("return StartPerl()\r\n", PF_name, (cv))
#define REXX_eval(cmd) ( exec_in_REXX_with(aTHX_ (cmd), 0, NULL, NULL))
static ULONG
SubCommandPerlEval(
PRXSTRING command, /* command to issue */
PUSHORT flags, /* error/failure flags */
PRXSTRING retstr ) /* return code */
{
dSP;
STRLEN len;
int ret;
char *str = 0;
SV *in, *res;
ENTER;
SAVETMPS;
PUSHMARK(SP);
in = sv_2mortal(newSVpvn(command->strptr, command->strlength));
eval_sv(in, G_SCALAR);
SPAGAIN;
res = POPs;
PUTBACK;
ret = 0;
if (SvTRUE(ERRSV)) {
*flags = RXSUBCOM_ERROR; /* raise error condition */
str = SvPV(ERRSV, len);
} else if (!SvOK(res)) {
*flags = RXSUBCOM_ERROR; /* raise error condition */
str = "undefined value returned by Perl-in-REXX";
len = strlen(str);
} else
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 {
*flags = RXSUBCOM_ERROR; /* raise error condition */
strcpy(retstr->strptr, "Not enough memory for the return string of Perl-in-REXX");
retstr->strlength = strlen(retstr->strptr);
}
FREETMPS;
LEAVE;
return 0; /* finished */
}
static void
needstrs(int n)
{
if (n > nstrs) {
if (strs)
free(strs);
nstrs = 2 * n;
strs = malloc(nstrs * sizeof(RXSTRING));
}
}
static void
needvars(int n)
{
if (n > nvars) {
if (vars)
free(vars);
nvars = 2 * n;
vars = malloc(nvars * sizeof(SHVBLOCK));
}
}
static void
initialize(void)
{
ULONG rc;
*(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1);
*(PFN *)&pRexxRegisterFunctionExe
= loadByOrdinal(ORD_RexxRegisterFunctionExe, 1);
*(PFN *)&pRexxDeregisterFunction
= loadByOrdinal(ORD_RexxDeregisterFunction, 1);
*(PFN *)&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1);
*(PFN *)&pRexxRegisterSubcomExe
= loadByOrdinal(ORD_RexxRegisterSubcomExe, 1);
needstrs(8);
needvars(8);
trace = getenv("PERL_REXX_DEBUG");
rc = pRexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL);
}
static int
constant(char *name, int arg)
{
errno = EINVAL;
return 0;
}
MODULE = OS2::REXX PACKAGE = OS2::REXX
BOOT:
initialize();
int
constant(name,arg)
char * name
int arg
int
_set(name,value,...)
char * name
char * value
CODE:
{
int i;
int n = (items + 1) / 2;
ULONG rc;
needvars(n);
if (trace)
fprintf(stderr, "REXXCALL::_set");
for (i = 0; i < n; ++i) {
SHVBLOCK * var = &vars[i];
STRLEN namelen;
STRLEN valuelen;
name = SvPV(ST(2*i+0),namelen);
if (2*i+1 < items) {
value = SvPV(ST(2*i+1),valuelen);
}
else {
value = "";
valuelen = 0;
}
var->shvcode = RXSHV_SET;
var->shvnext = &vars[i+1];
var->shvnamelen = namelen;
var->shvvaluelen = valuelen;
MAKERXSTRING(var->shvname, name, namelen);
MAKERXSTRING(var->shvvalue, value, valuelen);
if (trace)
fprintf(stderr, " %.*s='%.*s'",
(int)var->shvname.strlength, var->shvname.strptr,
(int)var->shvvalue.strlength, var->shvvalue.strptr);
}
if (trace)
fprintf(stderr, "\n");
vars[n-1].shvnext = NULL;
rc = pRexxVariablePool(vars);
if (trace)
fprintf(stderr, " rc=%#lX\n", rc);
RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
}
OUTPUT:
RETVAL
void
_fetch(name, ...)
char * name
PPCODE:
{
int i;
ULONG rc;
EXTEND(SP, items);
needvars(items);
if (trace)
fprintf(stderr, "REXXCALL::_fetch");
for (i = 0; i < items; ++i) {
SHVBLOCK * var = &vars[i];
STRLEN namelen;
name = SvPV(ST(i),namelen);
var->shvcode = RXSHV_FETCH;
var->shvnext = &vars[i+1];
var->shvnamelen = namelen;
var->shvvaluelen = 0;
MAKERXSTRING(var->shvname, name, namelen);
MAKERXSTRING(var->shvvalue, NULL, 0);
if (trace)
fprintf(stderr, " '%s'", name);
}
if (trace)
fprintf(stderr, "\n");
vars[items-1].shvnext = NULL;
rc = pRexxVariablePool(vars);
if (!(rc & ~RXSHV_NEWV)) {
for (i = 0; i < items; ++i) {
int namelen;
SHVBLOCK * var = &vars[i];
/* returned lengths appear to be swapped */
/* but beware of "future bug fixes" */
namelen = var->shvvalue.strlength; /* should be */
if (var->shvvaluelen < var->shvvalue.strlength)
namelen = var->shvvaluelen; /* is */
if (trace)
fprintf(stderr, " %.*s='%.*s'\n",
(int)var->shvname.strlength, var->shvname.strptr,
namelen, var->shvvalue.strptr);
if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
PUSHs(&PL_sv_undef);
else
PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
namelen)));
}
} else {
if (trace)
fprintf(stderr, " rc=%#lX\n", rc);
}
}
void
_next(stem)
char * stem
PPCODE:
{
SHVBLOCK sv;
BYTE name[4096];
ULONG rc;
int len = strlen(stem), namelen, valuelen;
if (trace)
fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
sv.shvcode = RXSHV_NEXTV;
sv.shvnext = NULL;
MAKERXSTRING(sv.shvvalue, NULL, 0);
do {
sv.shvnamelen = sizeof name;
sv.shvvaluelen = 0;
MAKERXSTRING(sv.shvname, name, sizeof name);
if (sv.shvvalue.strptr) {
DosFreeMem(sv.shvvalue.strptr);
MAKERXSTRING(sv.shvvalue, NULL, 0);
}
rc = pRexxVariablePool(&sv);
} while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
if (!rc) {
EXTEND(SP, 2);
/* returned lengths appear to be swapped */
/* but beware of "future bug fixes" */
namelen = sv.shvname.strlength; /* should be */
if (sv.shvnamelen < sv.shvname.strlength)
namelen = sv.shvnamelen; /* is */
valuelen = sv.shvvalue.strlength; /* should be */
if (sv.shvvaluelen < sv.shvvalue.strlength)
valuelen = sv.shvvaluelen; /* is */
if (trace)
fprintf(stderr, " %.*s='%.*s'\n",
namelen, sv.shvname.strptr,
valuelen, sv.shvvalue.strptr);
PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
if (sv.shvvalue.strptr) {
PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
DosFreeMem(sv.shvvalue.strptr);
} else
PUSHs(&PL_sv_undef);
} else if (rc != RXSHV_LVAR) {
die("Error %i when in _next", rc);
} else {
if (trace)
fprintf(stderr, " rc=%#lX\n", rc);
}
}
int
_drop(name,...)
char * name
CODE:
{
int i;
needvars(items);
for (i = 0; i < items; ++i) {
SHVBLOCK * var = &vars[i];
STRLEN namelen;
name = SvPV(ST(i),namelen);
var->shvcode = RXSHV_DROPV;
var->shvnext = &vars[i+1];
var->shvnamelen = namelen;
var->shvvaluelen = 0;
MAKERXSTRING(var->shvname, name, var->shvnamelen);
MAKERXSTRING(var->shvvalue, NULL, 0);
}
vars[items-1].shvnext = NULL;
RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
}
OUTPUT:
RETVAL
int
_register(name)
char * name
CODE:
RETVAL = pRexxRegisterFunctionExe(name, PERLCALL);
OUTPUT:
RETVAL
SV*
REXX_call(cv)
SV *cv
PROTOTYPE: &
SV*
REXX_eval(cmd)
char *cmd
SV*
REXX_eval_with(cmd,name,cv)
char *cmd
char *name
SV *cv
#ifdef THIS_IS_NOT_FINISHED
SV*
_REXX_eval_with(cmd,...)
char *cmd
CODE:
{
int n = (items - 1)/2;
char **names;
SV **cvs;
if ((items % 2) == 0)
Perl_croak(aTHX_ "Name/values should come in pairs in REXX_eval_with()");
Newx(names, n, char*);
Newx(cvs, n, SV*);
/* XXX Unfinished... */
RETVAL = Nullsv;
Safefree(names);
Safefree(cvs);
}
OUTPUT:
RETVAL
#endif
--- NEW FILE: Changes ---
0.2:
After fixpak17 a lot of other places have mismatched lengths
returned in the REXXPool interface.
Also drop does not work on stems any more.
0.22:
A subsystem module OS2::DLL extracted which does not link
with REXX runtime library.
--- NEW FILE: REXX.pm ---
package OS2::REXX;
require Exporter;
use XSLoader;
require OS2::DLL;
@ISA = qw(Exporter);
# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)
@EXPORT = qw(REXX_call REXX_eval REXX_eval_with);
# Other items we are prepared to export if requested
@EXPORT_OK = qw(drop register);
$VERSION = '1.03';
# We cannot just put OS2::DLL in @ISA, since some scripts would use
# function interface, not method interface...
*_call = \&OS2::DLL::_call;
*load = \&OS2::DLL::load;
*find = \&OS2::DLL::find;
XSLoader::load 'OS2::REXX';
# Preloaded methods go here. Autoload methods go after __END__, and are
# processed by the autosplit program.
sub register {_register($_) for @_}
sub prefix
{
my $self = shift;
$self->{Prefix} = shift;
}
sub queue
{
my $self = shift;
$self->{Queue} = shift;
}
sub drop
{ # Supposedly should drop anything with
# the given prefix. Unfortunately a
# loop is needed after fixpack17.
&OS2::REXX::_drop(@_);
}
sub dropall
{ # Supposedly should drop anything with
# the given prefix. Unfortunately a
# loop is needed after fixpack17.
&OS2::REXX::_drop(@_); # Try to drop them all.
my $name;
for (@_) {
if (/\.$/) {
OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator
while (($name) = OS2::REXX::_next($_)) {
OS2::REXX::_drop($_ . $name);
}
}
}
}
sub TIESCALAR
{
my ($obj, $name) = @_;
$name =~ s/^([\w!?]+)/\U$1\E/;
return bless \$name, OS2::REXX::_SCALAR;
}
sub TIEARRAY
{
my ($obj, $name) = @_;
$name =~ s/^([\w!?]+)/\U$1\E/;
return bless [$name, 0], OS2::REXX::_ARRAY;
}
sub TIEHASH
{
my ($obj, $name) = @_;
$name =~ s/^([\w!?]+)/\U$1\E/;
return bless {Stem => $name}, OS2::REXX::_HASH;
}
#############################################################################
package OS2::REXX::_SCALAR;
sub FETCH
{
return OS2::REXX::_fetch(${$_[0]});
}
sub STORE
{
return OS2::REXX::_set(${$_[0]}, $_[1]);
}
sub DESTROY
{
return OS2::REXX::_drop(${$_[0]});
}
#############################################################################
package OS2::REXX::_ARRAY;
sub FETCH
{
$_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1]));
}
sub STORE
{
$_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]);
}
#############################################################################
package OS2::REXX::_HASH;
require Tie::Hash;
@ISA = ('Tie::Hash');
sub FIRSTKEY
{
my ($self) = @_;
my $stem = $self->{Stem};
delete $self->{List} if exists $self->{List};
my @list = ();
my ($name, $value);
OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator
while (($name) = OS2::REXX::_next($stem)) {
push @list, $name;
}
my $key = pop @list;
$self->{List} = \@list;
return $key;
}
sub NEXTKEY
{
return pop @{$_[0]->{List}};
}
sub EXISTS
{
return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
}
sub FETCH
{
return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
}
sub STORE
{
return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]);
}
sub DELETE
{
OS2::REXX::_drop($_[0]->{Stem}.$_[1]);
}
#############################################################################
package OS2::REXX;
1;
__END__
=head1 NAME
OS2::REXX - access to DLLs with REXX calling convention and REXX runtime.
=head2 NOTE
By default, the REXX variable pool is not available, neither
to Perl, nor to external REXX functions. To enable it, you need to put
your code inside C<REXX_call> function. REXX functions which do not use
variables may be usable even without C<REXX_call> though.
=head1 SYNOPSIS
use OS2::REXX;
$ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!";
@pid = $ydb->RxProcId();
REXX_call {
tie $s, OS2::REXX, "TEST";
$s = 1;
};
=head1 DESCRIPTION
=head2 Load REXX DLL
$dll = load OS2::REXX NAME [, WHERE];
NAME is DLL name, without path and extension.
Directories are searched WHERE first (list of dirs), then environment
paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search
is performed in default DLL path (without adding paths and extensions).
The DLL is not unloaded when the variable dies.
Returns DLL object reference, or undef on failure.
=head2 Define function prefix:
$dll->prefix(NAME);
Define the prefix of external functions, prepended to the function
names used within your program, when looking for the entries in the
DLL.
=head2 Example
$dll = load OS2::REXX "RexxBase";
$dll->prefix("RexxBase_");
$dll->Init();
is the same as
$dll = load OS2::REXX "RexxBase";
$dll->RexxBase_Init();
=head2 Define queue:
$dll->queue(NAME);
Define the name of the REXX queue passed to all external
functions of this module. Defaults to "SESSION".
Check for functions (optional):
BOOL = $dll->find(NAME [, NAME [, ...]]);
Returns true if all functions are available.
=head2 Call external REXX function:
$dll->function(arguments);
Returns the return string if the return code is 0, else undef.
Dies with error message if the function is not available.
=head1 Accessing REXX-runtime
While calling functions with REXX signature does not require the presence
of the system REXX DLL, there are some actions which require REXX-runtime
present. Among them is the access to REXX variables by name.
One enables REXX runtime by bracketing your code by
REXX_call BLOCK;
(trailing semicolon required!) or
REXX_call \&subroutine_name;
Inside such a call one has access to REXX variables (see below).
An alternative way to execute code inside a REXX compartment is
REXX_eval EXPR;
REXX_eval_with EXPR,
subroutine_name_in_REXX => \&Perl_subroutine
Here C<EXPR> is a REXX code to run; to execute Perl code one needs to put
it inside Perl_subroutine(), and call this subroutine from REXX, as in
REXX_eval_with <<EOE, foo => sub { 123 * shift };
say foo(2)
EOE
If one needs more Perl subroutines available, one can "import" them into
REXX from inside Perl_subroutine(); since REXX is not case-sensitive,
the names should be uppercased.
use OS2::REXX 'register';
sub BAR { 123 + shift}
sub BAZ { 789 }
sub importer { register qw(BAR BAZ) }
REXX_eval_with <<'EOE', importer => \&importer;
call importer
say bar(34)
say baz()
EOE
=head2 Bind scalar variable to REXX variable:
tie $var, OS2::REXX, "NAME";
=head2 Bind array variable to REXX stem variable:
tie @var, OS2::REXX, "NAME.";
Only scalar operations work so far. No array assignments, no array
operations, ... FORGET IT.
=head2 Bind hash array variable to REXX stem variable:
tie %var, OS2::REXX, "NAME.";
To access all visible REXX variables via hash array, bind to "";
No array assignments. No array operations, other than hash array
operations. Just like the *dbm based implementations.
For the usual REXX stem variables, append a "." to the name,
as shown above. If the hash key is part of the stem name, for
example if you bind to "", you cannot use lower case in the stem
part of the key and it is subject to character set restrictions.
=head2 Erase individual REXX variables (bound or not):
OS2::REXX::drop("NAME" [, "NAME" [, ...]]);
=head2 Erase REXX variables with given stem (bound or not):
OS2::REXX::dropall("STEM" [, "STEM" [, ...]]);
=head2 Make Perl functions available in REXX:
OS2::REXX::register("NAME" [, "NAME" [, ...]]);
Since REXX is not case-sensitive, the names should be uppercase.
=head1 Subcommand handlers
By default, the executed REXX code runs without any default subcommand
handler present. A subcommand handler named C<PERLEVAL> is defined, but
not made a default. Use C<ADDRESS PERLEVAL> REXX command to make it a default
handler; alternatively, use C<ADDRESS Handler WhatToDo> to direct a command
to the handler you like.
Experiments show that the handler C<CMD> is also available; probably it is
provided by the REXX runtime.
=head1 Interfacing from REXX to Perl
This module provides an interface from Perl to REXX, and from REXX-inside-Perl
back to Perl. There is an alternative scenario which allows usage of Perl
from inside REXX.
A DLL F<PerlRexx> provides an API to Perl as REXX functions
PERL
PERLTERM
PERLINIT
PERLEXIT
PERLEVAL
PERLLASTERROR
PERLEXPORTALL
PERLDROPALL
PERLDROPALLEXIT
A subcommand handler C<PERLEVALSUBCOMMAND> can also be registered. Calling
the function PERLEXPORTALL() exports all these functions, as well as
exports this subcommand handler under the name C<EVALPERL>. PERLDROPALL()
inverts this action (and unloads PERLEXPORTALL() as well). In particular
rc = RxFuncAdd("PerlExportAll", 'PerlRexx', "PERLEXPORTALL")
rc = PerlExportAll()
res = PERLEVAL(perlarg)
ADDRESS EVALPERL perlarg1
rc = PerlDropAllExit()
loads all the functions above, evals the Perl code in the REXX variable
C<perlarg>, putting the result into the REXX variable C<res>,
then evals the Perl code in the REXX variable C<perlarg1>, and, finally,
drops the loaded functions and the subcommand handler, deinitializes
the Perl interpreter, and exits the Perl's C runtime library.
PERLEXIT() or PERLDROPALLEXIT() should be called as the last command of
the REXX program. (This is considered as a bug.) Their purpose is to flush
all the output buffers of the Perl's C runtime library.
C<PERLLASTERROR> gives the reason for the failure of the last PERLEVAL().
It is useful inside C<signal on syntax> handler. PERLINIT() and PERLTERM()
initialize and deinitialize the Perl interpreter.
C<PERLEVAL(string)> initializes the Perl interpreter (if needed), and
evaluates C<string> as Perl code. The result is returned to REXX stringified,
undefined result is considered as failure.
C<PERL(string)> does the same as C<PERLEVAL(string)> wrapped by calls to
PERLINIT() and PERLEXIT().
=head1 NOTES
Note that while function and variable names are case insensitive in the
REXX language, function names exported by a DLL and the REXX variables
(as seen by Perl through the chosen API) are all case sensitive!
Most REXX DLLs export function names all upper case, but there are a
few which export mixed case names (such as RxExtras). When trying to
find the entry point, both exact case and all upper case are searched.
If the DLL exports "RxNap", you have to specify the exact case, if it
exports "RXOPEN", you can use any case.
To avoid interfering with subroutine names defined by Perl (DESTROY)
or used within the REXX module (prefix, find), it is best to use mixed
case and to avoid lowercase only or uppercase only names when calling
REXX functions. Be consistent. The same function written in different
ways results in different Perl stubs.
There is no REXX interpolation on variable names, so the REXX variable
name TEST.ONE is not affected by some other REXX variable ONE. And it
is not the same variable as TEST.one!
You cannot call REXX functions which are not exported by the DLL.
While most DLLs export all their functions, some, like RxFTP, export
only "...LoadFuncs", which registers the functions within REXX only.
You cannot call 16-bit DLLs. The few interesting ones I found
(FTP,NETB,APPC) do not export their functions.
I do not know whether the REXX API is reentrant with respect to
exceptions (signals) when the REXX top-level exception handler is
overridden. So unless you know better than I do, do not access REXX
variables (probably tied to Perl variables) or call REXX functions
which access REXX queues or REXX variables in signal handlers.
See C<t/rx*.t> and the next section for examples.
=head1 EXAMPLE
use OS2::REXX;
sub Ender::DESTROY { $vrexx->VExit; print "Exiting...\n" }
$vrexx = OS2::REXX->load('VREXX');
REXX_call { # VOpenWindow takes a stem
local $SIG{TERM} = sub {die}; # enable Ender::DESTROY
local $SIG{INT} = sub {die}; # enable Ender::DESTROY
$code = $vrexx->VInit;
print "Init code = `$code'\n";
die "error initializing VREXX" if $code eq 'ERROR';
my $ender = bless [], 'Ender'; # Call Ender::DESTROY on exit
print "VREXX Version ", $vrexx->VGetVersion, "\n";
tie %pos, 'OS2::REXX', 'POS.' or die;
%pos = ( LEFT => 0, RIGHT => 7, TOP => 5, BOTTOM => 0 );
$id = $vrexx->VOpenWindow('To disconnect:', 'WHITE', 'POS');
$vrexx->VForeColor($id, 'BLACK');
$vrexx->VSetFont($id, 'TIME', '30');
$tlim = time + 60;
while ( ($r = $tlim - time) >= 0 ) {
$vrexx->VClearWindow($id);
$vrexx->VSay($id, 100, 50, (sprintf "%02i:%02i", int($r/60), $r % 60));
sleep 1;
}
print "Close code = `$res'\n" if $res = $vrexx->VCloseWindow($id);
};
=head1 ENVIRONMENT
If C<PERL_REXX_DEBUG> is set, prints trace info on calls to REXX runtime
environment.
=head1 AUTHOR
Andreas Kaiser ak at ananke.s.bawue.de, with additions by Ilya Zakharevich
ilya at math.ohio-state.edu.
=head1 SEE ALSO
L<OS2::DLL>.
=cut
--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'OS2::REXX',
VERSION_FROM => 'REXX.pm',
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes',
PERL_MALLOC_OK => 1,
);
More information about the dslinux-commit
mailing list