summaryrefslogtreecommitdiff
path: root/dlperl
diff options
context:
space:
mode:
Diffstat (limited to 'dlperl')
-rw-r--r--dlperl/Makefile51
-rw-r--r--dlperl/dlperl.c1037
-rw-r--r--dlperl/dlperl.doc264
-rw-r--r--dlperl/dlperl.man219
-rw-r--r--dlperl/usersub.c72
5 files changed, 1643 insertions, 0 deletions
diff --git a/dlperl/Makefile b/dlperl/Makefile
new file mode 100644
index 0000000000..64cfc76f06
--- /dev/null
+++ b/dlperl/Makefile
@@ -0,0 +1,51 @@
+
+# perl
+# - location of uperl.o and include files
+PERL = ../perl-lib
+# - libraries required by perl - from config.sh
+PERL_LIBS = -ldbm -lm -lposix
+
+UPERL = $(PERL)/uperl4.035.o
+UPERL = ../sybperl/uperl2.o
+
+DP_C = \
+ dlperl.c \
+ usersub.c
+
+DP_H =
+
+
+CC = gcc-2.2.2
+CPPFLAGS= -I$(PERL)
+#CFLAGS = -g
+
+ALL = \
+ dlperl
+
+
+all: $(ALL) tags
+
+dlperl: $(UPERL) $(DP_C:.c=.o)
+ $(LINK.c) -o dlperl $(UPERL) $(DP_C:.c=.o) \
+ $(PERL_LIBS) \
+ -ldl -lc.1.6
+ ld-rules -clobber dlperl
+
+dlperl.s: dlperl.c
+ $(COMPILE.c) -S $(OUTPUT_OPTION) dlperl.c
+
+tags: $(DP_C) $(DP_H)
+ ctags $(DP_C) $(DP_H)
+
+lint:
+ $(LINT.c) $(DP_C) $(LINT_LN)
+
+clean:
+ rm -f core *.o
+
+clobber: clean
+ rm -f $(ALL) tags
+
+install:
+
+.KEEP_STATE:
diff --git a/dlperl/dlperl.c b/dlperl/dlperl.c
new file mode 100644
index 0000000000..49d48bb197
--- /dev/null
+++ b/dlperl/dlperl.c
@@ -0,0 +1,1037 @@
+static char sccsid[] = "@(#)dlperl.c 1.2 10/12/92 (DLPERL)";
+
+/*
+ * name: dlperl.c
+ * synopsis: dlperl - perl interface to dynamically linked usubs
+ * sccsid: @(#)dlperl.c 1.2 10/12/92
+ */
+
+/*
+ * NOTE: this code is *not* portable
+ * - uses SPARC assembler with gcc asm extensions
+ * - is SPARC ABI specific
+ * - uses SunOS 4.x dlopen
+ *
+ * NOTE: not all types are currently implemented
+ * - multiple indirections (pointers to pointers, etc.)
+ * - structures
+ * - quad-precison (long double)
+ */
+
+#include <dlfcn.h>
+#include <alloca.h>
+#include <ctype.h>
+
+/* perl */
+#include "EXTERN.h"
+#include "perl.h"
+
+/* globals */
+int Dl_warn = 1;
+int Dl_errno;
+#define DL_ERRSTR_SIZ 256
+char Dl_errstr[DL_ERRSTR_SIZ];
+#define WORD_SIZE (sizeof(int))
+
+static int userval();
+static int userset();
+static int usersub();
+
+
+/*
+ * glue perl subroutines and variables to dlperl functions
+ */
+enum usersubs {
+ US_dl_open,
+ US_dl_sym,
+ US_dl_call,
+ US_dl_close,
+};
+
+enum uservars {
+ UV_DL_VERSION,
+ UV_DL_WARN,
+ UV_dl_errno,
+ UV_dl_errstr,
+};
+
+
+int
+dlperl_init()
+{
+ struct ufuncs uf;
+ char *file = "dlperl.c";
+
+ uf.uf_val = userval;
+ uf.uf_set = userset;
+
+#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
+
+ /* subroutines */
+ make_usub("dl_open", US_dl_open, usersub, file);
+ make_usub("dl_sym", US_dl_sym, usersub, file);
+ make_usub("dl_call", US_dl_call, usersub, file);
+ make_usub("dl_close", US_dl_close, usersub, file);
+
+ /* variables */
+ MAGICVAR("DL_VERSION", (int) UV_DL_VERSION);
+ MAGICVAR("DL_WARN", (int) UV_DL_WARN);
+ MAGICVAR("dl_errno", (int) UV_dl_errno);
+ MAGICVAR("dl_errstr", (int) UV_dl_errstr);
+
+ return 0;
+}
+
+
+/*
+ * USERVAL AND USERSET
+ */
+
+/*
+ * assign dlperl variables to perl variables
+ */
+/*ARGSUSED*/
+static int
+userval(ix, str)
+int ix;
+STR *str;
+{
+ switch(ix) {
+ case UV_DL_VERSION:
+ str_set(str, sccsid);
+ break;
+ case UV_DL_WARN:
+ str_numset(str, (double) Dl_warn);
+ break;
+ case UV_dl_errno:
+ str_numset(str, (double) Dl_errno);
+ break;
+ case UV_dl_errstr:
+ str_set(str, Dl_errstr);
+ break;
+ default:
+ fatal("dlperl: unimplemented userval");
+ break;
+ }
+ return 0;
+}
+
+/*
+ * assign perl variables to dlperl variables
+ */
+static int
+userset(ix, str)
+int ix;
+STR *str;
+{
+ switch(ix) {
+ case UV_DL_WARN:
+ Dl_warn = (int) str_gnum(str);
+ break;
+ default:
+ fatal("dlperl: unimplemented userset");
+ break;
+ }
+ return 0;
+}
+
+
+/*
+ * USERSUBS
+ */
+static int
+usersub(ix, sp, items)
+int ix;
+register int sp;
+register int items;
+{
+ int oldsp = sp;
+ STR **st = stack->ary_array + sp;
+ register STR *Str; /* used in str_get and str_gnum macros */
+
+ Dl_errno = 0;
+ *Dl_errstr = '\0';
+
+ switch(ix) {
+ case US_dl_open:
+ {
+ char *file;
+ void *dl_so;
+
+ if(items != 1) {
+ fatal("Usage: $dl_so = &dl_open($file)");
+ return oldsp;
+ }
+
+ file = str_get(st[1]);
+ dl_so = dlopen(file, 1);
+
+ --sp;
+ if(dl_so == NULL) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_open: %s", dlerror());
+ if(Dl_warn) warn(Dl_errstr);
+
+ astore(stack, ++sp, str_mortal(&str_undef));
+ } else {
+ astore(stack, ++sp, str_2mortal(str_make(
+ (char *) &dl_so, sizeof(void *))));
+ }
+ break;
+ }
+ case US_dl_sym:
+ {
+ void *dl_so;
+ char *symbol;
+ void *dl_func;
+
+ if(items != 2) {
+ fatal("Usage: $dl_func = &dl_sym($dl_so, $symbol)");
+ return oldsp;
+ }
+
+ dl_so = *(void **) str_get(st[1]);
+ symbol = str_get(st[2]);
+ dl_func = dlsym(dl_so, symbol);
+
+ --sp;
+ if(dl_func == NULL) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_sym: %s", dlerror());
+ if(Dl_warn) warn(Dl_errstr);
+
+ astore(stack, ++sp, str_mortal(&str_undef));
+ } else {
+ astore(stack, ++sp, str_2mortal(str_make(
+ (char *) &dl_func, sizeof(void *))));
+ }
+ break;
+ }
+ case US_dl_call:
+ {
+ void *dl_func;
+ char *parms_desc, *return_desc;
+ int nstack, nparm, narr, nlen, nrep;
+ int f_indirect, f_no_parm, f_result;
+ char c, *c_p; int c_pn = 0;
+ unsigned char C, *C_p; int C_pn = 0;
+ short s, *s_p; int s_pn = 0;
+ unsigned short S, *S_p; int S_pn = 0;
+ int i, *i_p; int i_pn = 0;
+ unsigned int I, *I_p; int I_pn = 0;
+ long l, *l_p; int l_pn = 0;
+ unsigned long L, *L_p; int L_pn = 0;
+ float f, *f_p; int f_pn = 0;
+ double d, *d_p; int d_pn = 0;
+ char *a, **a_p; int a_pn = 0;
+ char *p, **p_p; int p_pn = 0;
+ unsigned int *stack_base, *stack_p;
+ unsigned int *xp;
+ void (*func)();
+ unsigned int ret_o;
+ double ret_fd;
+ float ret_f;
+ char *c1;
+ int n1, n2;
+
+ if(items < 3) {
+fatal("Usage: @vals = &dl_call($dl_func, $parms_desc, $return_desc, @parms)");
+ return oldsp;
+ }
+ dl_func = *(void **) str_get(st[1]);
+ parms_desc = str_get(st[2]);
+ return_desc = str_get(st[3]);
+
+ /* determine size of stack and temporaries */
+# define CNT_STK_TMP(PN, SN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ PN += narr; \
+ ++nstack; \
+ if(!f_no_parm) \
+ nparm += narr; \
+ } else { \
+ nstack += SN; \
+ if(!f_no_parm) \
+ ++nparm; \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_no_parm = narr = nrep = 0;
+
+ nstack = 0;
+ nparm = 0;
+ f_indirect = f_no_parm = narr = nrep = 0;
+ for(c1 = parms_desc;*c1;++c1) {
+ switch(*c1) {
+ case ' ':
+ case '\t':
+ break;
+
+ case 'c': /* signed char */
+ CNT_STK_TMP(c_pn, 1);
+ break;
+ case 'C': /* unsigned char */
+ CNT_STK_TMP(C_pn, 1);
+ break;
+ case 's': /* signed short */
+ CNT_STK_TMP(s_pn, 1);
+ break;
+ case 'S': /* unsigned short */
+ CNT_STK_TMP(S_pn, 1);
+ break;
+ case 'i': /* signed int */
+ CNT_STK_TMP(i_pn, 1);
+ break;
+ case 'I': /* unsigned int */
+ CNT_STK_TMP(I_pn, 1);
+ break;
+ case 'l': /* signed long */
+ CNT_STK_TMP(l_pn, 1);
+ break;
+ case 'L': /* unsigned long */
+ CNT_STK_TMP(L_pn, 1);
+ break;
+ case 'f': /* float */
+ CNT_STK_TMP(f_pn, 1);
+ break;
+ case 'd': /* double */
+ CNT_STK_TMP(d_pn, 2);
+ break;
+ case 'a': /* ascii (null-terminated) string */
+ CNT_STK_TMP(a_pn, 1);
+ break;
+ case 'p': /* pointer to <nlen> buffer */
+ CNT_STK_TMP(p_pn, 1);
+ break;
+
+ case '&': /* pointer = [1] */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ narr = 1;
+ break;
+ case '[': /* array */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ narr = narr * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != ']') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected ]",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '<': /* length */
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1))
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != '>') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected >",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '+':
+ break;
+ case '-':
+ f_no_parm = 1;
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ if(nrep) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: too many repeats");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ while(isdigit(*c1)) {
+ nrep = nrep * 10 + (*c1 - '0');
+ ++c1;
+ }
+ --c1;
+ break;
+ default:
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ }
+ /* trailing &[]<>+-0-9 is ignored */
+ if(nparm != items - 3) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: bad parameter count %d, expected %d",
+ items - 3, nparm);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ nparm = 4;
+
+ /* allocate temporaries */
+ if((c_pn && (c_p = (char *)
+ alloca(c_pn * sizeof(char))) == NULL) ||
+ (C_pn && (C_p = (unsigned char *)
+ alloca(C_pn * sizeof(unsigned char))) == NULL) ||
+ (s_pn && (s_p = (short *)
+ alloca(s_pn * sizeof(short))) == NULL) ||
+ (S_pn && (S_p = (unsigned short *)
+ alloca(S_pn * sizeof(unsigned short))) == NULL) ||
+ (i_pn && (i_p = (int *)
+ alloca(i_pn * sizeof(int))) == NULL) ||
+ (I_pn && (I_p = (unsigned int *)
+ alloca(I_pn * sizeof(unsigned int))) == NULL) ||
+ (l_pn && (l_p = (long *)
+ alloca(l_pn * sizeof(long))) == NULL) ||
+ (L_pn && (L_p = (unsigned long *)
+ alloca(L_pn * sizeof(unsigned long))) == NULL) ||
+ (f_pn && (f_p = (float *)
+ alloca(f_pn * sizeof(float))) == NULL) ||
+ (d_pn && (d_p = (double *)
+ alloca(d_pn * sizeof(double))) == NULL) ||
+ (a_pn && (a_p = (char **)
+ alloca(a_pn * sizeof(char *))) == NULL) ||
+ (p_pn && (p_p = (char **)
+ alloca(p_pn * sizeof(char *))) == NULL)) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_call: bad alloca");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+
+ /* grow stack - maintains stack alignment (double word) */
+ /* NOTE: no functions should be called otherwise the stack */
+ /* that is being built will be corrupted */
+ /* NOTE: some of the stack is pre-allocated, but is not */
+ /* reused here */
+ if(alloca(nstack * WORD_SIZE) == NULL) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_call: bad alloca");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+
+ /* stack base */
+#if !defined(lint)
+ asm("add %%sp,68,%%o0;st %%o0,%0" :
+ "=g" (stack_base) : /* input */ : "%%o0");
+#else
+ stack_base = 0;
+#endif
+ stack_p = stack_base;
+
+ /* layout stack */
+# define LAY_STK_NUM(T, P, PN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ *stack_p++ = (unsigned int) &P[PN]; \
+ if(f_no_parm) { \
+ PN += narr; \
+ } else { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ P[PN++] = (T) \
+ str_gnum(st[nparm++]); \
+ } \
+ } \
+ } else { \
+ if(f_no_parm) { \
+ ++stack_p; \
+ } else { \
+ *stack_p++ = (T) \
+ str_gnum(st[nparm++]); \
+ } \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_no_parm = narr = nrep = 0;
+
+# define LAY_STK_DOUBLE(T, P, PN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ *stack_p++ = (unsigned int) &P[PN]; \
+ if(f_no_parm) { \
+ PN += narr; \
+ } else { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ P[PN++] = (T) \
+ str_gnum(st[nparm++]); \
+ } \
+ } \
+ } else { \
+ if(f_no_parm) { \
+ stack_p += 2; \
+ } else { \
+ d = (T) str_gnum(st[nparm++]); \
+ xp = (unsigned int *) &d; \
+ *stack_p++ = *xp++; \
+ *stack_p++ = *xp; \
+ } \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_no_parm = narr = nrep = 0;
+
+# define LAY_STK_STR(P, PN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ *stack_p++ = (unsigned int) &P[PN]; \
+ if(f_no_parm) { \
+ PN += narr; \
+ } else { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ P[PN++] = \
+ str_get(st[nparm++]); \
+ } \
+ } \
+ } else { \
+ if(f_no_parm) { \
+ ++stack_p; \
+ } else { \
+ *stack_p++ = (unsigned int) \
+ str_get(st[nparm++]); \
+ } \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_no_parm = narr = nrep = 0;
+
+ c_pn = C_pn = s_pn = S_pn = i_pn = I_pn = l_pn = L_pn = 0;
+ f_pn = d_pn = a_pn = p_pn = 0;
+ f_indirect = f_no_parm = narr = nrep = 0;
+ for(c1 = parms_desc;*c1;++c1) {
+ switch(*c1) {
+ case ' ':
+ case '\t':
+ break;
+
+ case 'c': /* signed char */
+ LAY_STK_NUM(char, c_p, c_pn);
+ break;
+ case 'C': /* unsigned char */
+ LAY_STK_NUM(unsigned char, C_p, C_pn);
+ break;
+ case 's': /* signed short */
+ LAY_STK_NUM(short, s_p, s_pn);
+ break;
+ case 'S': /* unsigned short */
+ LAY_STK_NUM(unsigned short, S_p, S_pn);
+ break;
+ case 'i': /* signed int */
+ LAY_STK_NUM(int, i_p, i_pn);
+ break;
+ case 'I': /* unsigned int */
+ LAY_STK_NUM(unsigned int, I_p, I_pn);
+ break;
+ case 'l': /* signed long */
+ LAY_STK_NUM(long, l_p, l_pn);
+ break;
+ case 'L': /* unsigned long */
+ LAY_STK_NUM(unsigned long, L_p, L_pn);
+ break;
+ case 'f': /* float */
+ LAY_STK_NUM(float, f_p, f_pn);
+ break;
+ case 'd': /* double */
+ LAY_STK_DOUBLE(double, d_p, d_pn);
+ break;
+ case 'a': /* ascii (null-terminated) string */
+ LAY_STK_STR(a_p, a_pn);
+ break;
+ case 'p': /* pointer to <nlen> buffer */
+ LAY_STK_STR(p_p, p_pn);
+ break;
+
+ case '&': /* pointer = [1] */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ narr = 1;
+ break;
+ case '[': /* array */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ narr = narr * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != ']') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected ]",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '<': /* length */
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1))
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != '>') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected >",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '+':
+ break;
+ case '-':
+ f_no_parm = 1;
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ if(nrep) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: too many repeats");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ while(isdigit(*c1)) {
+ nrep = nrep * 10 + (*c1 - '0');
+ ++c1;
+ }
+ --c1;
+ break;
+ default:
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ }
+ /* trailing &[]<>+-0-9 is ignored */
+
+ /* call function */
+ /* NOTE: the first 6 words are passed in registers %o0 - %o5 */
+ /* %sp+68 to %sp+92 are vacant, but allocated */
+ /* and shadow %o0 - %o5 */
+ /* above stack_base starts at %sp+68 and the function */
+ /* call below sets up %o0 - %o5 from stack_base */
+ func = (void (*)()) dl_func;
+ (*func)(stack_base[0], stack_base[1], stack_base[2],
+ stack_base[3], stack_base[4], stack_base[5]);
+
+ /* save return value */
+ /* NOTE: return values are either in %o0 or %f0 */
+#if !defined(lint)
+ asm("st %%o0,%0" : "=g" (ret_o) : /* input */);
+ asm("std %%f0,%0" : "=g" (ret_fd) : /* input */);
+ asm("st %%f0,%0" : "=g" (ret_f) : /* input */);
+#else
+ ret_o = 0; ret_fd = 0.0; ret_f = 0.0;
+#endif
+
+ /* parameter results */
+# define RES_NUM(P, PN, SN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ ++nstack; \
+ if(f_result) { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ astore(stack, ++sp, str_2mortal( \
+ str_nmake((double) P[PN++]))); \
+ } \
+ } else { \
+ PN += narr; \
+ } \
+ } else { \
+ nstack += SN; \
+ if(f_result) { \
+ astore(stack, ++sp, \
+ str_mortal(&str_undef));\
+ } \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_result = narr = nlen = nrep = 0;
+
+# define RES_STR(P, PN, L, SN) \
+ n2 = 0; do { \
+ if(f_indirect) { \
+ ++nstack; \
+ if(f_result) { \
+ for(n1 = 0;n1 < narr;++n1) { \
+ astore(stack, ++sp, str_2mortal( \
+ str_make(P[PN++], L))); \
+ } \
+ } else { \
+ PN += narr; \
+ } \
+ } else { \
+ if(f_result) { \
+ astore(stack, ++sp, str_2mortal(\
+ str_make((char *) \
+ stack_base[nstack], L))); \
+ } \
+ nstack += SN; \
+ } \
+ } while(++n2 < nrep); \
+ f_indirect = f_result = narr = nlen = nrep = 0;
+
+ --sp;
+ nstack = 0;
+ c_pn = C_pn = s_pn = S_pn = i_pn = I_pn = l_pn = L_pn = 0;
+ f_pn = d_pn = a_pn = p_pn = 0;
+ f_indirect = f_result = narr = nlen = nrep = 0;
+ for(c1 = parms_desc;*c1;++c1) {
+ switch(*c1) {
+ case ' ':
+ case '\t':
+ break;
+
+ case 'c': /* signed char */
+ RES_NUM(c_p, c_pn, 1);
+ break;
+ case 'C': /* unsigned char */
+ RES_NUM(C_p, C_pn, 1);
+ break;
+ case 's': /* signed short */
+ RES_NUM(s_p, s_pn, 1);
+ break;
+ case 'S': /* unsigned short */
+ RES_NUM(S_p, S_pn, 1);
+ break;
+ case 'i': /* signed int */
+ RES_NUM(i_p, i_pn, 1);
+ break;
+ case 'I': /* unsigned int */
+ RES_NUM(I_p, I_pn, 1);
+ break;
+ case 'l': /* signed long */
+ RES_NUM(l_p, l_pn, 1);
+ break;
+ case 'L': /* unsigned long */
+ RES_NUM(L_p, L_pn, 1);
+ break;
+ case 'f': /* float */
+ RES_NUM(f_p, f_pn, 1);
+ break;
+ case 'd': /* double */
+ RES_NUM(d_p, d_pn, 2);
+ break;
+ case 'a': /* ascii (null-terminated) string */
+ RES_STR(a_p, a_pn, 0, 1);
+ break;
+ case 'p': /* pointer to <nlen> buffer */
+ RES_STR(p_p, p_pn, nlen, 1);
+ break;
+
+ case '&': /* pointer = [1] */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ narr = 1;
+ break;
+ case '[': /* array */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: too many indirections, with char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ narr = narr * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != ']') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected ]",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '<': /* length */
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ nlen = nlen * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != '>') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c, expected >",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '+':
+ f_result = 1;
+ break;
+ case '-':
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ if(nrep) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: too many repeats");
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ while(isdigit(*c1)) {
+ nrep = nrep * 10 + (*c1 - '0');
+ ++c1;
+ }
+ --c1;
+ break;
+ default:
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: parms_desc %s: bad char %c",
+ parms_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ }
+ /* trailing &[]<>+-0-9 is ignored */
+
+ /* return value */
+# define RET_NUM(T, S, P, R) \
+ if(f_indirect) { \
+ P = (T *) ret_o; \
+ for(n1 = 0;n1 < narr;++n1) { \
+ S = *P++; \
+ astore(stack, ++sp, str_2mortal( \
+ str_nmake((double) S))); \
+ } \
+ } else { \
+ S = (T) R; \
+ astore(stack, ++sp, str_2mortal( \
+ str_nmake((double) S))); \
+ }
+
+# define RET_STR(S, P, L) \
+ if(f_indirect) { \
+ P = (char **) ret_o; \
+ for(n1 = 0;n1 < narr;++n1) { \
+ S = *P++; \
+ astore(stack, ++sp, str_2mortal( \
+ str_make((char *) S, L))); \
+ } \
+ } else { \
+ S = (char *) ret_o; \
+ astore(stack, ++sp, str_2mortal( \
+ str_make((char *) S, L))); \
+ }
+
+ f_indirect = nlen = narr = 0;
+ for(c1 = return_desc;*c1;++c1) {
+ switch(*c1) {
+ case ' ':
+ case '\t':
+ break;
+
+ case 'c': /* signed char */
+ RET_NUM(char, c, c_p, ret_o);
+ goto ret_exit;
+ case 'C': /* unsigned char */
+ RET_NUM(unsigned char, C, C_p, ret_o);
+ goto ret_exit;
+ case 's': /* signed short */
+ RET_NUM(short, s, s_p, ret_o);
+ goto ret_exit;
+ case 'S': /* unsigned short */
+ RET_NUM(unsigned short, S, S_p, ret_o);
+ goto ret_exit;
+ case 'i': /* signed int */
+ RET_NUM(int, i, i_p, ret_o);
+ goto ret_exit;
+ case 'I': /* unsigned int */
+ RET_NUM(unsigned int, I, I_p, ret_o);
+ goto ret_exit;
+ case 'l': /* signed long */
+ RET_NUM(long, l, l_p, ret_o);
+ goto ret_exit;
+ case 'L': /* unsigned long */
+ RET_NUM(unsigned long, L, L_p, ret_o);
+ goto ret_exit;
+ case 'f': /* float */
+ RET_NUM(float, f, f_p, ret_f);
+ break;
+ case 'd': /* double */
+ RET_NUM(double, d, d_p, ret_fd);
+ goto ret_exit;
+ case 'a': /* ascii (null-terminated) string */
+ RET_STR(a, a_p, 0);
+ goto ret_exit;
+ case 'p': /* pointer to <nlen> buffer */
+ RET_STR(p, p_p, nlen);
+ goto ret_exit;
+
+ case '&': /* pointer = [1] */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: too many indirections, with char %c",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ narr = 1;
+ break;
+ case '[': /* array */
+ if(f_indirect) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: too many indirections, with char %c",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ f_indirect = 1;
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ narr = narr * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != ']') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: bad char %c, expected ]",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ case '<': /* length */
+ ++c1;
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ while(isdigit(*c1)) {
+ nlen = nlen * 10 + (*c1 - '0');
+ ++c1;
+ }
+ while(*c1 == ' ' && *c1 == '\t')
+ ++c1;
+ if(*c1 != '>') {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: bad char %c, expected >",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ break;
+ default:
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr,
+ "&dl_call: return_desc %s: bad char %c",
+ return_desc, *c1);
+ if(Dl_warn) warn(Dl_errstr);
+ return oldsp;
+ }
+ }
+ret_exit: /* anything beyond first [cCsSiIlLdfap] is ignored */
+ break;
+ }
+ case US_dl_close:
+ {
+ void *dl_so;
+ int dl_err;
+
+ if(items != 1) {
+ fatal("Usage: $dl_err = &dl_close($dl_so)");
+ return oldsp;
+ }
+
+ dl_so = *(void **) str_get(st[1]);
+ dl_err = dlclose(dl_so);
+
+ --sp;
+ if(dl_err) {
+ Dl_errno = 1;
+ (void) sprintf(Dl_errstr, "&dl_close: %s", dlerror());
+ if(Dl_warn) warn(Dl_errstr);
+ }
+ astore(stack, ++sp, str_2mortal(str_nmake((double) dl_err)));
+ break;
+ }
+ default:
+ fatal("dlperl: unimplemented usersub");
+ break;
+ }
+ return sp;
+}
diff --git a/dlperl/dlperl.doc b/dlperl/dlperl.doc
new file mode 100644
index 0000000000..7da0dfe1d8
--- /dev/null
+++ b/dlperl/dlperl.doc
@@ -0,0 +1,264 @@
+
+
+
+DLPERL(1) USER COMMANDS DLPERL(1)
+
+
+
+NAME
+ dlperl - dynamic link-editor subroutines for perl
+
+SYNOPSIS
+ $dl_so = &dl_open($file)
+ $dl_func = &dl_sym($dl_so, $symbol)
+ @vals = &dl_call($dl_func, $parms_desc, $return_desc, @parms)
+ $dl_err = &dl_close($dl_so)
+
+ $DL_VERSION
+ $DL_WARN
+ $dl_errno
+ $dl_errstr
+
+DESCRIPTION
+ _D_l_p_e_r_l is _p_e_r_l plus user defined subroutines (_u_s_u_b_s) that
+ interface to the dynamic link-editor and can call most C and
+ Fortran functions whose object code has been linked into a
+ shared object file.
+
+ Subroutines
+
+ All _d_l_p_e_r_l subroutines set the two predefined names
+ $dl_errno and $dl_errstr. Only partial descriptions of
+ &dl_open, &dl_sym and &dl_close appear below, see _d_l_o_p_e_n(_3_x)
+ for a complete description. The following subroutines are
+ defined by _d_l_p_e_r_l:
+
+ &dl_open($file)
+ Adds the shared object $_f_i_l_e to _d_l_p_e_r_l's address
+ space. Returns a descriptor that can be used for
+ later reference to the object in calls to &dl_sym
+ and &dl_close. When an error occurs an undef value
+ is returned.
+
+ &dl_sym($dl_so, $symbol)
+ Obtains an address binding for the function $_s_y_m_b_o_l
+ as it occurs in the shared object identified by
+ $_d_l__s_o. When an error occurs an undef value is
+ returned.
+
+ &dl_call($dl_func, $parms_desc, $return_desc, @parms)
+ Calls the function identified by $_d_l__f_u_n_c. The
+ function's entry parameters are described by
+ $_p_a_r_m_s__d_e_s_c and assigned values from @_p_a_r_m_s. The
+ function's exit value is described by $_r_e_t_u_r_n__d_e_s_c.
+ An array is returned that contains the values of any
+ result parameters and the return value. When an
+ error occurs because of a problem parsing the
+ descriptions or because of an incorrect parameter
+ count no values are returned (although the underly-
+ ing function may have been called).
+
+
+
+Sun Release 4.1 Last change: 10/16/92 1
+
+
+
+
+
+
+DLPERL(1) USER COMMANDS DLPERL(1)
+
+
+
+ The descriptions are sequences of characters that
+ give the order and type of parameters:
+
+ c A signed char value.
+ C An unsigned char value.
+ s A signed short value.
+ S An unsigned short value.
+ i A signed integer value.
+ I An unsigned integer value.
+ l A signed long value.
+ L An unsigned long value.
+ f A single-precision float.
+ d A double-precision float.
+ a An ascii (null-terminated) string.
+ p A pointer to <length> buffer.
+
+ Each letter may optionally be preceded by a number
+ that gives a repeat count. An array is specified by
+ a preceding [_a_r_r_a_y__s_i_z_e] (or & as a shorthand for
+ [_1]). (Multi-dimension arrays are not currently
+ supported.) Each scalar or array element is ini-
+ tialized from @_p_a_r_m_s. A preceding - leaves the
+ parameter uninitialized. Type _p expects a preceding
+ <_b_u_f_f_e_r__l_e_n_g_t_h>. A preceding + specifies that after
+ the function is called that particular parameter's
+ value is to be returned (multiple values are
+ returned for array types, a + with a integral type
+ like _i returns an undef value). The $_r_e_t_u_r_n__d_e_s_c
+ contains only one letter with no repeat count, - or
+ +.
+
+ An undef or zero-length $_p_a_r_m__d_e_s_c means the func-
+ tion has no parameters. An undef or a zero-length
+ $_r_e_t_u_r_n__d_e_s_c means the function returns void.
+ Strings or buffers that must be a specific length
+ (because the values are overwritten) must be pre-
+ extended. Although type _f is supported, compilers
+ typically pass floats as doubles.
+
+ &dl_close($dl_so)
+ Removes the shared object identified by $_d_l__s_o from
+ _d_l_p_e_r_l's address space. If successful, a value of
+ zero is returned. When an error occurs a non-zero
+ value is returned.
+
+ Predefined Names
+
+ The following names have special meaning to _d_l_p_e_r_l.
+
+ $DL_VERSION
+ The version of _d_l_p_e_r_l. This variable is read-only.
+
+
+
+
+Sun Release 4.1 Last change: 10/16/92 2
+
+
+
+
+
+
+DLPERL(1) USER COMMANDS DLPERL(1)
+
+
+
+ $DL_WARN
+ The current value of the _d_l_p_e_r_l warning flag.
+ Default is 1. If non-zero, when errors occur warn-
+ ings are sent to standard error. The warning is the
+ same information that is stored in $dl_errstr.
+
+ $dl_errno
+ The error number for the error that occurred. If a
+ _d_l_p_e_r_l subroutine completes successfully $dl_errno
+ is set to zero. This variable is read-only.
+
+ $dl_errstr
+ The error message for the error that occurred. If a
+ _d_l_p_e_r_l subroutine completes successfully $dl_errstr
+ is set to a zero length string. This variable is
+ read-only.
+
+EXAMPLES
+ This is an example of calling a simple C function:
+
+ open(OUT, ">example.c");
+ print OUT <<'EOC';
+ void
+ example(a1, a2, i1, d1, a3)
+ char *a1[2];
+ char *a2[2];
+ int i1;
+ double *d1;
+ char *a3[4];
+ {
+ a3[i1 + (int) *d1] = a1[0];
+ a3[i1 * (int) *d1] = a1[1];
+ a3[(int) *d1 - i1] = a2[0];
+ a3[(int) *d1 - 2 * i1] = a2[1];
+ }
+ EOC
+ close(OUT);
+
+ system("cc -c example.c;ld -o example.so example.o");
+
+ $dl_so = &dl_open("example.so");
+ die "$0: $dl_errstr" if($dl_errno);
+
+ $dl_func = &dl_sym($dl_so, "example");
+ die "$0: $dl_errstr" if($dl_errno);
+
+ $dl_func =~ s/(['\\])/\\$1/g;
+ eval <<EOC;
+ sub example {
+ &dl_call('$dl_func', "2[2]a i &d -+[4]a", undef, @_);
+ }
+ EOC
+
+
+
+Sun Release 4.1 Last change: 10/16/92 3
+
+
+
+
+
+
+DLPERL(1) USER COMMANDS DLPERL(1)
+
+
+
+ @vals = &example("hacker,", "Perl", "another", "Just", 1, 2);
+ print "@vals\n";
+
+ &dl_close($dl_so);
+ die "$0: $dl_errstr" if($dl_errno);
+
+ unlink('example.c', 'example.o', 'example.so');
+
+ If a more complicated interface is needed, the dynamically
+ linked function can define _u_s_u_b_s by calling internal _p_e_r_l
+ functions.
+
+AUTHOR
+ Eric Fifer <egf@sbi.com>
+
+SEE ALSO
+ perl(1), dlopen(3X), ld(1)
+
+BUGS
+ Additional parameter types should be implemented to support
+ structures, multi-dimension arrays, pointers to arrays,
+ pointers to functions, etc.
+
+ Unlike the _p_a_c_k operator, the repeat count precedes the
+ letter in the $_p_a_r_m__d_e_s_c syntax. The array size preceding
+ the parameter letter is also unconventional.
+
+ All errors set $dl_errno to 1.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Sun Release 4.1 Last change: 10/16/92 4
+
+
+
diff --git a/dlperl/dlperl.man b/dlperl/dlperl.man
new file mode 100644
index 0000000000..8879133ca2
--- /dev/null
+++ b/dlperl/dlperl.man
@@ -0,0 +1,219 @@
+.\"
+.\" name: dlperl.man
+.\" synopsis: dlperl man page
+.\" sccsid: @(#)dlperl.man 1.4 10/16/92 (DLPERL)
+.\"
+.ds RP 10/16/92
+.rn '' }`
+.de Sh
+.br
+.ne 5
+.PP
+\fB\\$1\fR
+.PP
+..
+.de Sp
+.if t .sp .5v
+.if n .sp
+..
+.de Ip
+.br
+.ie \\n(.$>=3 .ne \\$3
+.el .ne 3
+.IP "\\$1" \\$2
+..
+'''
+''' Set up \*(-- to give an unbreakable dash;
+''' string Tr holds user defined translation string.
+''' Bell System Logo is used as a dummy character.
+'''
+.tr \(*W-|\(bv\*(Tr
+.ie n \{\
+.ds -- \(*W-
+.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
+.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
+.ds L" ""
+.ds R" ""
+.ds L' '
+.ds R' '
+'br\}
+.el\{\
+.ds -- \(em\|
+.tr \*(Tr
+.ds L" ``
+.ds R" ''
+.ds L' `
+.ds R' '
+'br\}
+.TH DLPERL 1 "\*(RP"
+.UC
+.SH NAME
+dlperl \- dynamic link-editor subroutines for perl
+.SH SYNOPSIS
+.nf
+.ft B
+$dl_so = &dl_open($file)
+$dl_func = &dl_sym($dl_so, $symbol)
+@vals = &dl_call($dl_func, $parms_desc, $return_desc, @parms)
+$dl_err = &dl_close($dl_so)
+.ft
+.fi
+.LP
+.nf
+.ft B
+$DL_VERSION
+$DL_WARN
+$dl_errno
+$dl_errstr
+.ft
+.fi
+.SH DESCRIPTION
+.I Dlperl
+is \fIperl\fP plus user defined subroutines (\fIusubs\fP) that
+interface to the dynamic link-editor and can call most C and Fortran
+functions whose object code has been linked into a shared object file.
+.Sh "Subroutines"
+All \fIdlperl\fP subroutines set the two predefined names $dl_errno and
+$dl_errstr. Only partial descriptions of &dl_open, &dl_sym and
+&dl_close appear below, see \fIdlopen(3x)\fP for a complete
+description. The following subroutines are defined by \fIdlperl\fP:
+.Ip "&dl_open($file)" 8 2
+Adds the shared object \fI$file\fP to \fIdlperl\fP's address space.
+Returns a descriptor that can be used for later reference to the object
+in calls to &dl_sym and &dl_close. When an error occurs
+an undef value is returned.
+.Ip "&dl_sym($dl_so, $symbol)" 8 2
+Obtains an address binding for the function \fI$symbol\fP as it occurs
+in the shared object identified by \fI$dl_so\fP. When an error occurs
+an undef value is returned.
+.Ip "&dl_call($dl_func, $parms_desc, $return_desc, @parms)" 8 2
+Calls the function identified by \fI$dl_func\fP. The function's entry
+parameters are described by \fI$parms_desc\fP and assigned values from
+\fI@parms\fP. The function's exit value is described by
+\fI$return_desc\fP. An array is returned that contains the values of
+any result parameters and the return value. When an error occurs
+because of a problem parsing the descriptions or because of an
+incorrect parameter count no values are returned (although the
+underlying function may have been called).
+.Sp
+The descriptions are sequences of characters that give the order and
+type of parameters:
+.nf
+
+ c A signed char value.
+ C An unsigned char value.
+ s A signed short value.
+ S An unsigned short value.
+ i A signed integer value.
+ I An unsigned integer value.
+ l A signed long value.
+ L An unsigned long value.
+ f A single-precision float.
+ d A double-precision float.
+ a An ascii (null-terminated) string.
+ p A pointer to <length> buffer.
+
+.fi
+Each letter may optionally be preceded by a number that gives a repeat
+count. An array is specified by a preceding \fI[array_size\fP] (or
+\fI&\fP as a shorthand for \fI[1]\fP). (Multi-dimension arrays are not
+currently supported.) Each scalar or array element is initialized from
+\fI@parms\fP. A preceding \fI-\fP leaves the parameter uninitialized.
+Type \fIp\fP expects a preceding \fI<buffer_length>\fP. A preceding
+\fI+\fP specifies that after the function is called that particular
+parameter's value is to be returned (multiple values are returned for
+array types, a \fI+\fP with a integral type like \fIi\fP returns an
+undef value). The \fI$return_desc\fP contains only one letter with no
+repeat count, \fI-\fP or \fI+\fP.
+.Sp
+An undef or zero-length \fI$parm_desc\fP means the function has no
+parameters. An undef or a zero-length \fI$return_desc\fP means the
+function returns void. Strings or buffers that must be a specific
+length (because the values are overwritten) must be pre-extended.
+Although type \fIf\fP is supported, compilers typically pass floats as
+doubles.
+.Ip "&dl_close($dl_so)" 8 2
+Removes the shared object identified by \fI$dl_so\fP from
+\fIdlperl\fP's address space. If successful, a value of zero is
+returned. When an error occurs a non-zero value is returned.
+.Sh "Predefined Names"
+The following names have special meaning to \fIdlperl\fP.
+.Ip $DL_VERSION 8
+The version of \fIdlperl\fP. This variable is read-only.
+.Ip $DL_WARN 8
+The current value of the \fIdlperl\fP warning flag. Default is 1. If
+non-zero, when errors occur warnings are sent to standard error. The
+warning is the same information that is stored in $dl_errstr.
+.Ip $dl_errno 8
+The error number for the error that occurred. If a \fIdlperl\fP
+subroutine completes successfully $dl_errno is set to zero. This variable
+is read-only.
+.Ip $dl_errstr 8
+The error message for the error that occurred. If a \fIdlperl\fP
+subroutine completes successfully $dl_errstr is set to a zero length
+string. This variable is read-only.
+.SH EXAMPLES
+This is an example of calling a simple C function:
+.Sp
+.nf
+ open(OUT, ">example.c");
+ print OUT <<'EOC';
+ void
+ example(a1, a2, i1, d1, a3)
+ char *a1[2];
+ char *a2[2];
+ int i1;
+ double *d1;
+ char *a3[4];
+ {
+ a3[i1 + (int) *d1] = a1[0];
+ a3[i1 * (int) *d1] = a1[1];
+ a3[(int) *d1 - i1] = a2[0];
+ a3[(int) *d1 - 2 * i1] = a2[1];
+ }
+ EOC
+ close(OUT);
+
+ system("cc -c example.c;ld -o example.so example.o");
+
+ $dl_so = &dl_open("example.so");
+ die "$0: $dl_errstr" if($dl_errno);
+
+ $dl_func = &dl_sym($dl_so, "example");
+ die "$0: $dl_errstr" if($dl_errno);
+
+ $dl_func =~ s/(['\e\e])/\e\e$1/g;
+ eval <<EOC;
+ sub example {
+ &dl_call('$dl_func', "2[2]a i &d -+[4]a", undef, @_);
+ }
+ EOC
+
+ @vals = &example("hacker,", "Perl", "another", "Just", 1, 2);
+ print "@vals\en";
+
+ &dl_close($dl_so);
+ die "$0: $dl_errstr" if($dl_errno);
+
+ unlink('example.c', 'example.o', 'example.so');
+.fi
+.LP
+If a more complicated interface is needed, the dynamically linked
+function can define \fIusubs\fP by calling internal \fIperl\fP
+functions.
+.SH AUTHOR
+Eric Fifer <egf@sbi.com>
+.SH SEE ALSO
+.BR perl (1),
+.BR dlopen (3X),
+.BR ld (1)
+.SH BUGS
+Additional parameter types should be implemented to support structures,
+multi-dimension arrays, pointers to arrays, pointers to functions, etc.
+.LP
+Unlike the \fIpack\fP operator, the repeat count precedes the letter in
+the \fI$parm_desc\fP syntax. The array size preceding the parameter
+letter is also unconventional.
+.LP
+All errors set $dl_errno to 1.
+.rn }` ''
diff --git a/dlperl/usersub.c b/dlperl/usersub.c
new file mode 100644
index 0000000000..4ba3d6d639
--- /dev/null
+++ b/dlperl/usersub.c
@@ -0,0 +1,72 @@
+/* $RCSfile: usersub.c,v $$Revision: 4.0.1.1 $$Date: 91/11/05 19:07:24 $
+ *
+ * $Log: usersub.c,v $
+ * Revision 4.0.1.1 91/11/05 19:07:24 lwall
+ * patch11: there are now subroutines for calling back from C into Perl
+ *
+ * Revision 4.0 91/03/20 01:56:34 lwall
+ * 4.0 baseline.
+ *
+ * Revision 3.0.1.1 90/08/09 04:06:10 lwall
+ * patch19: Initial revision
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+int
+userinit()
+{
+ dlperl_init();
+}
+
+/* Be sure to refetch the stack pointer after calling these routines. */
+
+int
+callback(subname, sp, gimme, hasargs, numargs)
+char *subname;
+int sp; /* stack pointer after args are pushed */
+int gimme; /* called in array or scalar context */
+int hasargs; /* whether to create a @_ array for routine */
+int numargs; /* how many args are pushed on the stack */
+{
+ static ARG myarg[3]; /* fake syntax tree node */
+ int arglast[3];
+
+ arglast[2] = sp;
+ sp -= numargs;
+ arglast[1] = sp--;
+ arglast[0] = sp;
+
+ if (!myarg[0].arg_ptr.arg_str)
+ myarg[0].arg_ptr.arg_str = str_make("",0);
+
+ myarg[1].arg_type = A_WORD;
+ myarg[1].arg_ptr.arg_stab = stabent(subname, FALSE);
+
+ myarg[2].arg_type = hasargs ? A_EXPR : A_NULL;
+
+ return do_subr(myarg, gimme, arglast);
+}
+
+int
+callv(subname, sp, gimme, argv)
+char *subname;
+register int sp; /* current stack pointer */
+int gimme; /* called in array or scalar context */
+register char **argv; /* null terminated arg list, NULL for no arglist */
+{
+ register int items = 0;
+ int hasargs = (argv != 0);
+
+ astore(stack, ++sp, Nullstr); /* reserve spot for 1st return arg */
+ if (hasargs) {
+ while (*argv) {
+ astore(stack, ++sp, str_2mortal(str_make(*argv,0)));
+ items++;
+ argv++;
+ }
+ }
+ return callback(subname, sp, gimme, hasargs, items);
+}
View Lorry Controller Status