 | Chapter 20 Perl Internals |  |
We have learned enough (and more) to implement the convenience API introduced in Chapter 19. They are perl_call_va, perl_eval_va, and the set of functions for accessing or modifying scalar values: get_int, set_int, and so on. We'll implement only perl_call_va in this section. perl_eval_va is a shorter form of this procedure since it doesn't expect any input parameters (the string to be eval'd contains all the information). The API functions to modify scalars are simple wrappers over sv_set*, av_store, and hv_store, and are left as an exercise to the reader.[12]
[12] I've always wanted to say that! (See the Preface for the FTP site where you can download this code and other examples in this book.)
Recall that perl_call_va takes a NULL-terminated list of typed arguments. This list contains both input and output parameters. The following implementation processes the entire list by XPUSH'ing the input parameters and storing the output parameters in an array of Out_Param structures. Knowing the number of output parameters expected by the caller allows us to specify G_SCALAR, G_ARRAY, or G_DISCARD. The full code is shown in Example 20.3.
#define MAX_PARAMS 20
typedef struct {
char type;
void *pdata;
} Out_Param; /* To remember the "Out" section */
int perl_call_va (char *subname, ...)
{
char *p = NULL;
char *str = NULL; int i = 0; double d = 0;
int nret = 0; /* number of return params expected*/
int ii = 0;
va_list vl;
int out = 0;
int result = 0;
Out_Param op[MAX_PARAMS];
dSP; /* Standard ... */
ENTER; /* ... Prologue */
SAVETMPS;
PUSHMARK(sp);
va_start (vl, subname);
while (p = va_arg(vl, char *)) { /* Fetch next argument */
switch (*p) {
case 's' : /* String */
if (out) {
/* Comes here if we are processing the "Out" section */
op[nret].pdata = (void*) va_arg(vl, char *);
op[nret++].type = 's';
} else {
str = va_arg(vl, char *);
ii = strlen(str);
XPUSHs(sv_2mortal(newSVpv(str,ii)));
}
break;
case 'i' : /* Integer */
if (out) {
op[nret].pdata = (void*) va_arg(vl, int *);
op[nret++].type = 'i';
} else {
ii = va_arg(vl, int);
XPUSHs(sv_2mortal(newSViv(ii)));
}
break;
case 'd' : /* Double */
if (out) {
op[nret].pdata = (void*) va_arg(vl, double *);
op[nret++].type = 'd';
} else {
d = va_arg(vl, double);
XPUSHs(sv_2mortal(newSVnv(d)));
}
break;
case 'O':
out = 1; /* Out parameters starting */
break;
default:
fprintf (stderr, "perl_eval_va: Unknown option \'%c\'.\n"
"Did you forget a trailing NULL ?\n", *p);
return 0;
}
if (nret > MAX_PARAMS) {
printf (stderr, "Can't accept more than %d return params\n",
MAX_PARAMS);
return -1;
}
}
va_end(vl);
PUTBACK;
/* All input parameters have been pushed on stack, and "nret" contains
* the number of values expected back from the Perl function */
result = perl_call_pv(subname, (nret == 0) ? G_DISCARD :
(nret == 1) ? G_SCALAR :
G_ARRAY );
/* Process output arguments */
SPAGAIN;
if (nret > result)
nret = result;
for (i = --nret; i >= 0; i--) {
switch (op[i].type) {
case 's':
str = POPp;
strcpy((char *)op[i].pdata, str);
break;
case 'i':
*((int *)(op[i].pdata)) = POPi;
break;
case 'd':
*((double *) (op[i].pdata)) = POPd;
break;
}
}
FREETMPS ;
LEAVE ;
return result;
} |  | |
| 20.5 Meaty Extensions |  | 20.7 A Peek into the Future |