freebsd-dev/gnu/usr.bin/perl/usub/usersub.c
Jordan K. Hubbard 80926682fd Bring back perl/usub as usub/, this time containing an updated curseperl
which is also installed by default (the reason for which should also be
plain shortly).
1995-03-24 04:33:54 +00:00

73 lines
1.7 KiB
C

/* $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()
{
init_curses();
}
/* 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);
}