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).
This commit is contained in:
Jordan K. Hubbard
parent
a833576497
commit
80926682fd
@ -4,7 +4,7 @@
|
||||
# Note: I'm not sure what to do with c2ph located in misc...
|
||||
#
|
||||
|
||||
SUBDIR= perl tperl sperl lib x2p
|
||||
SUBDIR= perl tperl sperl usub lib x2p
|
||||
|
||||
.include <bsd.subdir.mk>
|
||||
|
||||
|
||||
21
gnu/usr.bin/perl/usub/Makefile
Normal file
21
gnu/usr.bin/perl/usub/Makefile
Normal file
@ -0,0 +1,21 @@
|
||||
PROG= curseperl
|
||||
|
||||
SRCS+= array.c cmd.c cons.c consarg.c
|
||||
SRCS+= doarg.c doio.c dolist.c dump.c
|
||||
SRCS+= eval.c form.c hash.c malloc.c
|
||||
SRCS+= perl.c perly.c regcomp.c regexec.c
|
||||
SRCS+= stab.c str.c toke.c util.c
|
||||
SRCS+= usersub.c curses.c
|
||||
|
||||
CFLAGS+= -DDEBUGGING -I${.CURDIR}/..
|
||||
LDADD+= -lncurses -ltermcap -ltermlib -lcrypt -lm
|
||||
DPADD+= ${LIBNCURSES} ${LIBTERMCAP} ${LIBTERMLIB} ${LIBCRYPT} ${LIBM}
|
||||
CLEANFILES+= curses.c
|
||||
VPATH+= ${.CURDIR}/..
|
||||
NOMAN= yes
|
||||
|
||||
curses.c: curses.mus
|
||||
${.CURDIR}/mus ${.CURDIR}/curses.mus > curses.c
|
||||
|
||||
.include "../../Makefile.inc"
|
||||
.include <bsd.prog.mk>
|
||||
117
gnu/usr.bin/perl/usub/README
Normal file
117
gnu/usr.bin/perl/usub/README
Normal file
@ -0,0 +1,117 @@
|
||||
[ Note: This directory was actually brought in to be able to use curseperl,
|
||||
but it's also a useful reference for general extension ]
|
||||
|
||||
This directory contains an example of how you might link in C subroutines
|
||||
with perl to make your own special copy of perl. In the perl distribution
|
||||
directory, there will be (after make is run) a file called uperl.o, which
|
||||
is all of perl except for a single undefined subroutine, named userinit().
|
||||
See usersub.c.
|
||||
|
||||
The sole purpose of the userinit() routine is to call the initialization
|
||||
routines for any modules that you want to link in. In this example, we just
|
||||
call init_curses(), which sets up to link in the System V curses routines.
|
||||
You'll find this in the file curses.c, which is the processed output of
|
||||
curses.mus. (To get BSD curses, replace curses.mus with bsdcurses.mus.)
|
||||
|
||||
The magicname() routine adds variable names into the symbol table. Along
|
||||
with the name of the variable as Perl knows it, we pass a structure containing
|
||||
an index identifying the variable, and the names of two C functions that
|
||||
know how to set or evaluate a variable given the index of the variable.
|
||||
Our example uses a macro to handle this conveniently.
|
||||
|
||||
The init routine calls make_usub() to add user-defined subroutine names
|
||||
into the symbol table. The arguments are
|
||||
|
||||
make_usub(subname, subindex, subfunc, filename);
|
||||
char *subname;
|
||||
int subindex;
|
||||
int subfunc();
|
||||
char *filename;
|
||||
|
||||
The subname is the name that will be used in the Perl program. The subindex
|
||||
will be passed to subfunc() when it is called to tell it which C function
|
||||
is desired. subfunc() is a glue routine that translates the arguments
|
||||
from Perl internal stack form to the form required by the routine in
|
||||
question, calls the desired C function, and then translates any return
|
||||
value back into the stack format. The glue routine used by curses just
|
||||
has a large switch statement, each branch of which does the processing
|
||||
for a particular C function. The subindex could, however, be used to look
|
||||
up a function in a dynamically linked library. No example of this is
|
||||
provided.
|
||||
|
||||
As a help in producing the glue routine, a preprocessor called "mus" lets
|
||||
you specify argument and return value types in a tabular format. An entry
|
||||
such as:
|
||||
|
||||
CASE int waddstr
|
||||
I WINDOW* win
|
||||
I char* str
|
||||
END
|
||||
|
||||
indicates that waddstr takes two input arguments, the first of which is a
|
||||
pointer to a window, and the second of which is an ordinary C string. It
|
||||
also indicates that an integer is returned. The mus program turns this into:
|
||||
|
||||
case US_waddstr:
|
||||
if (items != 2)
|
||||
fatal("Usage: &waddstr($win, $str)");
|
||||
else {
|
||||
int retval;
|
||||
WINDOW* win = *(WINDOW**) str_get(st[1]);
|
||||
char* str = (char*) str_get(st[2]);
|
||||
|
||||
retval = waddstr(win, str);
|
||||
str_numset(st[0], (double) retval);
|
||||
}
|
||||
return sp;
|
||||
|
||||
It's also possible to have output parameters, indicated by O, and input/ouput
|
||||
parameters indicated by IO.
|
||||
|
||||
The mus program isn't perfect. You'll note that curses.mus has some
|
||||
cases which are hand coded. They'll be passed straight through unmodified.
|
||||
You can produce similar cases by analogy to what's in curses.c, as well
|
||||
as similar routines in the doarg.c, dolist.c and doio.c routines of Perl.
|
||||
The mus program is only intended to get you about 90% there. It's not clear,
|
||||
for instance, how a given structure should be passed to Perl. But that
|
||||
shouldn't bother you--if you've gotten this far, it's already obvious
|
||||
that you are totally mad.
|
||||
|
||||
Here's an example of how to return an array value:
|
||||
|
||||
case US_appl_errlist:
|
||||
if (!wantarray) {
|
||||
str_numset(st[0], (double) appl_nerr);
|
||||
return sp;
|
||||
}
|
||||
astore(stack, sp + appl_nerr, Nullstr); /* extend stack */
|
||||
st = stack->ary_array + sp; /* possibly realloced */
|
||||
for (i = 0; i < appl_nerr; i++) {
|
||||
tmps = appl_errlist[i];
|
||||
st[i] = str_2mortal(str_make(tmps,strlen(tmps)));
|
||||
}
|
||||
return sp + appl_nerr - 1;
|
||||
|
||||
|
||||
In addition, there is a program, man2mus, that will scan a man page for
|
||||
function prototypes and attempt to construct a mus CASE entry for you. It has
|
||||
to guess about input/output parameters, so you'll have to tidy up after it.
|
||||
But it can save you a lot of time if the man pages for a library are
|
||||
reasonably well formed.
|
||||
|
||||
If you happen to have curses on your machine, you might try compiling
|
||||
a copy of curseperl. The "pager" program in this directory is a rudimentary
|
||||
start on writing a pager--don't believe the help message, which is stolen
|
||||
from the less program.
|
||||
|
||||
User-defined subroutines may not currently be called as a signal handler,
|
||||
though a signal handler may itself call a user-defined subroutine.
|
||||
|
||||
There are now glue routines to call back from C into Perl. In usersub.c
|
||||
in this directory, you'll find callback() and callv(). The callback()
|
||||
routine presumes that any arguments to pass to the Perl subroutine
|
||||
have already been pushed onto the Perl stack. The callv() routine
|
||||
is a wrapper that pushes an argv-style array of strings onto the
|
||||
stack for you, and then calls callback(). Be sure to recheck your
|
||||
stack pointer after returning from these routine, since the Perl code
|
||||
may have reallocated it.
|
||||
808
gnu/usr.bin/perl/usub/curses.mus
Normal file
808
gnu/usr.bin/perl/usub/curses.mus
Normal file
@ -0,0 +1,808 @@
|
||||
/* $RCSfile: curses.mus,v $$Revision: 4.0.1.2 $$Date: 92/06/08 16:06:12 $
|
||||
*
|
||||
* $Log: curses.mus,v $
|
||||
* Revision 4.0.1.2 92/06/08 16:06:12 lwall
|
||||
* patch20: function key support added to curses.mus
|
||||
*
|
||||
* Revision 4.0.1.1 91/11/05 19:06:19 lwall
|
||||
* patch11: usub/curses.mus now supports SysV curses
|
||||
*
|
||||
* Revision 4.0 91/03/20 01:56:13 lwall
|
||||
* 4.0 baseline.
|
||||
*
|
||||
* Revision 3.0.1.1 90/08/09 04:05:21 lwall
|
||||
* patch19: Initial revision
|
||||
*
|
||||
*/
|
||||
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
|
||||
char *savestr();
|
||||
static char *getcap();
|
||||
|
||||
#undef bool
|
||||
#include <ncurses.h>
|
||||
|
||||
#ifndef A_UNDERLINE
|
||||
#define NOSETATTR
|
||||
#define A_STANDOUT 0x0200
|
||||
#define A_UNDERLINE 0x0100
|
||||
#define A_REVERSE 0x0200
|
||||
#define A_BLINK 0x0400
|
||||
#define A_BOLD 0x0800
|
||||
#define A_ALTCHARSET 0x1000
|
||||
#define A_NORMAL 0
|
||||
#endif
|
||||
|
||||
#ifdef USG
|
||||
static char *tcbuf = NULL;
|
||||
#endif
|
||||
|
||||
#ifdef NOSETATTR
|
||||
static unsigned curattr = NORMAL;
|
||||
#endif
|
||||
|
||||
static enum uservars {
|
||||
UV_curscr,
|
||||
UV_stdscr,
|
||||
UV_LINES,
|
||||
UV_COLS,
|
||||
UV_ERR,
|
||||
UV_OK,
|
||||
UV_A_STANDOUT,
|
||||
UV_A_UNDERLINE,
|
||||
UV_A_REVERSE,
|
||||
UV_A_BLINK,
|
||||
UV_A_DIM,
|
||||
UV_A_BOLD,
|
||||
UV_A_NORMAL,
|
||||
};
|
||||
|
||||
static enum usersubs {
|
||||
US_addch,
|
||||
US_waddch,
|
||||
US_addstr,
|
||||
US_waddstr,
|
||||
US_box,
|
||||
US_clear,
|
||||
US_wclear,
|
||||
US_clearok,
|
||||
US_clrtobot,
|
||||
US_wclrtobot,
|
||||
US_clrtoeol,
|
||||
US_wclrtoeol,
|
||||
US_delch,
|
||||
US_wdelch,
|
||||
US_deleteln,
|
||||
US_wdeleteln,
|
||||
US_erase,
|
||||
US_werase,
|
||||
US_idlok,
|
||||
US_insch,
|
||||
US_winsch,
|
||||
US_insertln,
|
||||
US_winsertln,
|
||||
US_move,
|
||||
US_wmove,
|
||||
US_overlay,
|
||||
US_overwrite,
|
||||
US_refresh,
|
||||
US_wrefresh,
|
||||
US_standout,
|
||||
US_wstandout,
|
||||
US_standend,
|
||||
US_wstandend,
|
||||
US_cbreak,
|
||||
US_nocbreak,
|
||||
US_echo,
|
||||
US_noecho,
|
||||
US_getch,
|
||||
US_wgetch,
|
||||
US_getstr,
|
||||
US_wgetstr,
|
||||
US_raw,
|
||||
US_noraw,
|
||||
US_baudrate,
|
||||
US_delwin,
|
||||
US_endwin,
|
||||
US_erasechar,
|
||||
US_getyx,
|
||||
US_inch,
|
||||
US_winch,
|
||||
US_initscr,
|
||||
US_killchar,
|
||||
US_leaveok,
|
||||
US_longname,
|
||||
US_mvwin,
|
||||
US_newwin,
|
||||
US_nl,
|
||||
US_nonl,
|
||||
US_scrollok,
|
||||
US_subwin,
|
||||
US_touchline,
|
||||
US_touchwin,
|
||||
US_unctrl,
|
||||
#ifndef __FreeBSD__
|
||||
US_gettmode,
|
||||
#endif
|
||||
US_mvcur,
|
||||
US_scroll,
|
||||
US_savetty,
|
||||
US_resetty,
|
||||
US_attroff,
|
||||
US_wattroff,
|
||||
US_attron,
|
||||
US_wattron,
|
||||
US_attrset,
|
||||
US_wattrset,
|
||||
#ifdef CURSEFMT
|
||||
US_printw, /* remove */
|
||||
US_wprintw, /* remove */
|
||||
US_scanw, /* delete */
|
||||
US_wscanw, /* delete */
|
||||
#endif
|
||||
US_getcap,
|
||||
US_mysub,
|
||||
US_testcallback,
|
||||
};
|
||||
|
||||
static int usersub();
|
||||
static int userset();
|
||||
static int userval();
|
||||
|
||||
int
|
||||
init_curses()
|
||||
{
|
||||
struct ufuncs uf;
|
||||
char *filename = "curses.c";
|
||||
|
||||
uf.uf_set = userset;
|
||||
uf.uf_val = userval;
|
||||
|
||||
#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
|
||||
|
||||
MAGICVAR("curscr", UV_curscr);
|
||||
MAGICVAR("stdscr", UV_stdscr);
|
||||
MAGICVAR("LINES", UV_LINES);
|
||||
MAGICVAR("COLS", UV_COLS);
|
||||
MAGICVAR("ERR", UV_ERR);
|
||||
MAGICVAR("OK", UV_OK);
|
||||
MAGICVAR("A_STANDOUT", UV_A_STANDOUT);
|
||||
MAGICVAR("A_UNDERLINE", UV_A_UNDERLINE);
|
||||
MAGICVAR("A_REVERSE", UV_A_REVERSE);
|
||||
MAGICVAR("A_BLINK", UV_A_BLINK);
|
||||
MAGICVAR("A_DIM", UV_A_DIM);
|
||||
MAGICVAR("A_BOLD", UV_A_BOLD);
|
||||
MAGICVAR("A_NORMAL", UV_A_NORMAL);
|
||||
|
||||
make_usub("addch", US_addch, usersub, filename);
|
||||
make_usub("waddch", US_waddch, usersub, filename);
|
||||
make_usub("addstr", US_addstr, usersub, filename);
|
||||
make_usub("waddstr", US_waddstr, usersub, filename);
|
||||
make_usub("box", US_box, usersub, filename);
|
||||
make_usub("clear", US_clear, usersub, filename);
|
||||
make_usub("wclear", US_wclear, usersub, filename);
|
||||
make_usub("clearok", US_clearok, usersub, filename);
|
||||
make_usub("clrtobot", US_clrtobot, usersub, filename);
|
||||
make_usub("wclrtobot", US_wclrtobot, usersub, filename);
|
||||
make_usub("clrtoeol", US_clrtoeol, usersub, filename);
|
||||
make_usub("wclrtoeol", US_wclrtoeol, usersub, filename);
|
||||
make_usub("delch", US_delch, usersub, filename);
|
||||
make_usub("wdelch", US_wdelch, usersub, filename);
|
||||
make_usub("deleteln", US_deleteln, usersub, filename);
|
||||
make_usub("wdeleteln", US_wdeleteln, usersub, filename);
|
||||
make_usub("erase", US_erase, usersub, filename);
|
||||
make_usub("werase", US_werase, usersub, filename);
|
||||
make_usub("idlok", US_idlok, usersub, filename);
|
||||
make_usub("insch", US_insch, usersub, filename);
|
||||
make_usub("winsch", US_winsch, usersub, filename);
|
||||
make_usub("insertln", US_insertln, usersub, filename);
|
||||
make_usub("winsertln", US_winsertln, usersub, filename);
|
||||
make_usub("move", US_move, usersub, filename);
|
||||
make_usub("wmove", US_wmove, usersub, filename);
|
||||
make_usub("overlay", US_overlay, usersub, filename);
|
||||
make_usub("overwrite", US_overwrite, usersub, filename);
|
||||
make_usub("refresh", US_refresh, usersub, filename);
|
||||
make_usub("wrefresh", US_wrefresh, usersub, filename);
|
||||
make_usub("standout", US_standout, usersub, filename);
|
||||
make_usub("wstandout", US_wstandout, usersub, filename);
|
||||
make_usub("standend", US_standend, usersub, filename);
|
||||
make_usub("wstandend", US_wstandend, usersub, filename);
|
||||
make_usub("cbreak", US_cbreak, usersub, filename);
|
||||
make_usub("nocbreak", US_nocbreak, usersub, filename);
|
||||
make_usub("echo", US_echo, usersub, filename);
|
||||
make_usub("noecho", US_noecho, usersub, filename);
|
||||
make_usub("getch", US_getch, usersub, filename);
|
||||
make_usub("wgetch", US_wgetch, usersub, filename);
|
||||
make_usub("getstr", US_getstr, usersub, filename);
|
||||
make_usub("wgetstr", US_wgetstr, usersub, filename);
|
||||
make_usub("raw", US_raw, usersub, filename);
|
||||
make_usub("noraw", US_noraw, usersub, filename);
|
||||
make_usub("baudrate", US_baudrate, usersub, filename);
|
||||
make_usub("delwin", US_delwin, usersub, filename);
|
||||
make_usub("endwin", US_endwin, usersub, filename);
|
||||
make_usub("erasechar", US_erasechar, usersub, filename);
|
||||
make_usub("getyx", US_getyx, usersub, filename);
|
||||
make_usub("inch", US_inch, usersub, filename);
|
||||
make_usub("winch", US_winch, usersub, filename);
|
||||
make_usub("initscr", US_initscr, usersub, filename);
|
||||
make_usub("killchar", US_killchar, usersub, filename);
|
||||
make_usub("leaveok", US_leaveok, usersub, filename);
|
||||
make_usub("longname", US_longname, usersub, filename);
|
||||
make_usub("mvwin", US_mvwin, usersub, filename);
|
||||
make_usub("newwin", US_newwin, usersub, filename);
|
||||
make_usub("nl", US_nl, usersub, filename);
|
||||
make_usub("nonl", US_nonl, usersub, filename);
|
||||
make_usub("scrollok", US_scrollok, usersub, filename);
|
||||
make_usub("subwin", US_subwin, usersub, filename);
|
||||
make_usub("touchline", US_touchline, usersub, filename);
|
||||
make_usub("touchwin", US_touchwin, usersub, filename);
|
||||
make_usub("unctrl", US_unctrl, usersub, filename);
|
||||
#ifndef __FreeBSD__
|
||||
make_usub("gettmode", US_gettmode, usersub, filename);
|
||||
#endif
|
||||
make_usub("mvcur", US_mvcur, usersub, filename);
|
||||
make_usub("scroll", US_scroll, usersub, filename);
|
||||
make_usub("savetty", US_savetty, usersub, filename);
|
||||
make_usub("resetty", US_resetty, usersub, filename);
|
||||
make_usub("getcap", US_getcap, usersub, filename);
|
||||
make_usub("attroff", US_attroff, usersub, filename);
|
||||
make_usub("wattroff", US_wattroff, usersub, filename);
|
||||
make_usub("attron", US_attron, usersub, filename);
|
||||
make_usub("wattron", US_wattron, usersub, filename);
|
||||
make_usub("attrset", US_attrset, usersub, filename);
|
||||
make_usub("wattrset", US_wattrset, usersub, filename);
|
||||
#ifdef CURSEFMT
|
||||
make_usub("printw", US_printw, usersub, filename);
|
||||
make_usub("wprintw", US_wprintw, usersub, filename);
|
||||
make_usub("scanw", US_scanw, usersub, filename);
|
||||
make_usub("wscanw", US_wscanw, usersub, filename);
|
||||
#endif
|
||||
make_usub("testcallback", US_testcallback,usersub, filename);
|
||||
};
|
||||
|
||||
#ifdef NOSETATTR
|
||||
#define attron(attr) wattron(stdscr, attr)
|
||||
#define attroff(attr) wattroff(stdscr, attr)
|
||||
#define attset(attr) wattset(stdscr, attr)
|
||||
|
||||
int
|
||||
wattron(win, attr)
|
||||
WINDOW *win;
|
||||
chtype attr;
|
||||
{
|
||||
curattr |= attr;
|
||||
if (curattr & A_STANDOUT) {
|
||||
return(wstandout(win));
|
||||
} else {
|
||||
return(wstandend(win));
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
wattroff(win, attr)
|
||||
WINDOW *win;
|
||||
chtype attr;
|
||||
{
|
||||
curattr &= (~attr);
|
||||
if (curattr & A_STANDOUT) {
|
||||
return(wstandout(win));
|
||||
} else {
|
||||
return(wstandend(win));
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
wattrset(win, attr)
|
||||
WINDOW *win;
|
||||
chtype attr;
|
||||
{
|
||||
curattr = attr;
|
||||
if (curattr & A_STANDOUT) {
|
||||
return(wstandout(win));
|
||||
} else {
|
||||
return(wstandend(win));
|
||||
}
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
static int
|
||||
usersub(ix, sp, items)
|
||||
int ix;
|
||||
register int sp;
|
||||
register int items;
|
||||
{
|
||||
STR **st = stack->ary_array + sp;
|
||||
register int i;
|
||||
register char *tmps;
|
||||
register STR *Str; /* used in str_get and str_gnum macros */
|
||||
|
||||
switch (ix) {
|
||||
CASE int addch
|
||||
I char ch
|
||||
END
|
||||
|
||||
CASE int waddch
|
||||
I WINDOW* win
|
||||
I char ch
|
||||
END
|
||||
|
||||
CASE int addstr
|
||||
I char* str
|
||||
END
|
||||
|
||||
CASE int waddstr
|
||||
I WINDOW* win
|
||||
I char* str
|
||||
END
|
||||
|
||||
CASE int box
|
||||
I WINDOW* win
|
||||
I char vert
|
||||
I char hor
|
||||
END
|
||||
|
||||
CASE int clear
|
||||
END
|
||||
|
||||
CASE int wclear
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int clearok
|
||||
I WINDOW* win
|
||||
I bool boolf
|
||||
END
|
||||
|
||||
CASE int clrtobot
|
||||
END
|
||||
|
||||
CASE int wclrtobot
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int clrtoeol
|
||||
END
|
||||
|
||||
CASE int wclrtoeol
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int delch
|
||||
END
|
||||
|
||||
CASE int wdelch
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int deleteln
|
||||
END
|
||||
|
||||
CASE int wdeleteln
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int erase
|
||||
END
|
||||
|
||||
CASE int werase
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int idlok
|
||||
I WINDOW* win
|
||||
I bool boolf
|
||||
END
|
||||
|
||||
CASE int insch
|
||||
I char c
|
||||
END
|
||||
|
||||
CASE int winsch
|
||||
I WINDOW* win
|
||||
I char c
|
||||
END
|
||||
|
||||
CASE int insertln
|
||||
END
|
||||
|
||||
CASE int winsertln
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int move
|
||||
I int y
|
||||
I int x
|
||||
END
|
||||
|
||||
CASE int wmove
|
||||
I WINDOW* win
|
||||
I int y
|
||||
I int x
|
||||
END
|
||||
|
||||
CASE int overlay
|
||||
I WINDOW* win1
|
||||
I WINDOW* win2
|
||||
END
|
||||
|
||||
CASE int overwrite
|
||||
I WINDOW* win1
|
||||
I WINDOW* win2
|
||||
END
|
||||
|
||||
CASE int refresh
|
||||
END
|
||||
|
||||
CASE int wrefresh
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int standout
|
||||
END
|
||||
|
||||
CASE int wstandout
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int standend
|
||||
END
|
||||
|
||||
CASE int wstandend
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int cbreak
|
||||
END
|
||||
|
||||
CASE int nocbreak
|
||||
END
|
||||
|
||||
CASE int echo
|
||||
END
|
||||
|
||||
CASE int noecho
|
||||
END
|
||||
|
||||
case US_getch:
|
||||
if (items != 0)
|
||||
fatal("Usage: &getch()");
|
||||
else {
|
||||
int retval;
|
||||
char retch;
|
||||
|
||||
retval = getch();
|
||||
if (retval == EOF)
|
||||
st[0] = &str_undef;
|
||||
else {
|
||||
retch = retval;
|
||||
if (retval > 0377)
|
||||
str_numset(st[0], (double) retval);
|
||||
else
|
||||
str_nset(st[0], &retch, 1);
|
||||
}
|
||||
}
|
||||
return sp;
|
||||
|
||||
case US_wgetch:
|
||||
if (items != 1)
|
||||
fatal("Usage: &wgetch($win)");
|
||||
else {
|
||||
int retval;
|
||||
char retch;
|
||||
WINDOW* win = *(WINDOW**) str_get(st[1]);
|
||||
|
||||
retval = wgetch(win);
|
||||
if (retval == EOF)
|
||||
st[0] = &str_undef;
|
||||
else {
|
||||
retch = retval;
|
||||
if (retval > 0377)
|
||||
str_numset(st[0], (double) retval);
|
||||
else
|
||||
str_nset(st[0], &retch, 1);
|
||||
}
|
||||
}
|
||||
return sp;
|
||||
|
||||
CASE int getstr
|
||||
O char* str
|
||||
END
|
||||
|
||||
CASE int wgetstr
|
||||
I WINDOW* win
|
||||
O char* str
|
||||
END
|
||||
|
||||
CASE int raw
|
||||
END
|
||||
|
||||
CASE int noraw
|
||||
END
|
||||
|
||||
CASE int baudrate
|
||||
END
|
||||
|
||||
CASE int delwin
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int endwin
|
||||
END
|
||||
|
||||
CASE int erasechar
|
||||
END
|
||||
|
||||
case US_getyx:
|
||||
if (items != 3)
|
||||
fatal("Usage: &getyx($win, $y, $x)");
|
||||
else {
|
||||
int retval;
|
||||
STR* str = str_new(0);
|
||||
WINDOW* win = *(WINDOW**) str_get(st[1]);
|
||||
int y;
|
||||
int x;
|
||||
|
||||
do_sprintf(str, items - 1, st + 1);
|
||||
retval = getyx(win, y, x);
|
||||
str_numset(st[2], (double)y);
|
||||
str_numset(st[3], (double)x);
|
||||
str_numset(st[0], (double) retval);
|
||||
str_free(str);
|
||||
}
|
||||
return sp;
|
||||
|
||||
CASE int inch
|
||||
END
|
||||
|
||||
CASE int winch
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE WINDOW* initscr
|
||||
END
|
||||
|
||||
CASE int killchar
|
||||
END
|
||||
|
||||
CASE int leaveok
|
||||
I WINDOW* win
|
||||
I bool boolf
|
||||
END
|
||||
|
||||
#ifdef BSD
|
||||
CASE char* longname
|
||||
END
|
||||
#else
|
||||
CASE char* longname
|
||||
I char* termbug
|
||||
I char* name
|
||||
END
|
||||
#endif
|
||||
|
||||
CASE int mvwin
|
||||
I WINDOW* win
|
||||
I int y
|
||||
I int x
|
||||
END
|
||||
|
||||
CASE WINDOW* newwin
|
||||
I int lines
|
||||
I int cols
|
||||
I int begin_y
|
||||
I int begin_x
|
||||
END
|
||||
|
||||
CASE int nl
|
||||
END
|
||||
|
||||
CASE int nonl
|
||||
END
|
||||
|
||||
CASE int scrollok
|
||||
I WINDOW* win
|
||||
I bool boolf
|
||||
END
|
||||
|
||||
CASE WINDOW* subwin
|
||||
I WINDOW* win
|
||||
I int lines
|
||||
I int cols
|
||||
I int begin_y
|
||||
I int begin_x
|
||||
END
|
||||
|
||||
CASE int touchline
|
||||
I WINDOW* win
|
||||
I int y
|
||||
I int startx
|
||||
END
|
||||
|
||||
CASE int touchwin
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE char* unctrl
|
||||
I char ch
|
||||
END
|
||||
|
||||
#ifndef __FreeBSD__
|
||||
CASE int gettmode
|
||||
END
|
||||
#endif
|
||||
|
||||
CASE int mvcur
|
||||
I int lasty
|
||||
I int lastx
|
||||
I int newy
|
||||
I int newx
|
||||
END
|
||||
|
||||
CASE int scroll
|
||||
I WINDOW* win
|
||||
END
|
||||
|
||||
CASE int savetty
|
||||
END
|
||||
|
||||
CASE void resetty
|
||||
END
|
||||
|
||||
CASE int attroff
|
||||
I chtype str
|
||||
END
|
||||
|
||||
CASE int wattroff
|
||||
I WINDOW* win
|
||||
I chtype str
|
||||
END
|
||||
|
||||
CASE int wattron
|
||||
I WINDOW* win
|
||||
I chtype str
|
||||
END
|
||||
|
||||
CASE int attron
|
||||
I chtype str
|
||||
END
|
||||
|
||||
CASE int attrset
|
||||
I chtype str
|
||||
END
|
||||
|
||||
CASE int wattrset
|
||||
I WINDOW* win
|
||||
I chtype str
|
||||
END
|
||||
|
||||
#ifdef CURSEFMT
|
||||
case US_printw:
|
||||
if (items < 1)
|
||||
fatal("Usage: &printw($fmt, $arg1, $arg2, ... )");
|
||||
else {
|
||||
int retval;
|
||||
STR* str = str_new(0);
|
||||
|
||||
do_sprintf(str, items - 1, st + 1);
|
||||
retval = addstr(str->str_ptr);
|
||||
str_numset(st[0], (double) retval);
|
||||
str_free(str);
|
||||
}
|
||||
return sp;
|
||||
|
||||
case US_wprintw:
|
||||
if (items < 2)
|
||||
fatal("Usage: &wprintw($win, $fmt, $arg1, $arg2, ... )");
|
||||
else {
|
||||
int retval;
|
||||
STR* str = str_new(0);
|
||||
WINDOW* win = *(WINDOW**) str_get(st[1]);
|
||||
|
||||
do_sprintf(str, items - 1, st + 1);
|
||||
retval = waddstr(win, str->str_ptr);
|
||||
str_numset(st[0], (double) retval);
|
||||
str_free(str);
|
||||
}
|
||||
return sp;
|
||||
|
||||
#endif
|
||||
CASE char* getcap
|
||||
I char* str
|
||||
END
|
||||
default:
|
||||
fatal("Unimplemented user-defined subroutine");
|
||||
}
|
||||
return sp;
|
||||
}
|
||||
|
||||
static char
|
||||
*getcap(cap)
|
||||
register char *cap;
|
||||
{
|
||||
static char *tcbuf = NULL;
|
||||
static char nocaperr[] = "Cannot read termcap entry.";
|
||||
extern char *tgetstr();
|
||||
char *cp, *tp;
|
||||
static char capstr[256];
|
||||
|
||||
cp = capstr;
|
||||
if (tcbuf == NULL) {
|
||||
if ((tcbuf = malloc(1024)) == NULL) {
|
||||
fatal(nocaperr);
|
||||
}
|
||||
tp = getenv("TERM");
|
||||
if (!tp)
|
||||
tp = "tty";
|
||||
if (tgetent(tcbuf, tp) == -1) {
|
||||
fatal(nocaperr);
|
||||
}
|
||||
}
|
||||
return (tgetstr(cap, &cp));
|
||||
}
|
||||
|
||||
static int
|
||||
userval(ix, str)
|
||||
int ix;
|
||||
STR *str;
|
||||
{
|
||||
switch (ix) {
|
||||
case UV_COLS:
|
||||
str_numset(str, (double)COLS);
|
||||
break;
|
||||
case UV_ERR:
|
||||
str_numset(str, (double)ERR);
|
||||
break;
|
||||
case UV_LINES:
|
||||
str_numset(str, (double)LINES);
|
||||
break;
|
||||
case UV_OK:
|
||||
str_numset(str, (double)OK);
|
||||
break;
|
||||
case UV_curscr:
|
||||
str_nset(str, &curscr, sizeof(WINDOW*));
|
||||
break;
|
||||
case UV_stdscr:
|
||||
str_nset(str, &stdscr, sizeof(WINDOW*));
|
||||
break;
|
||||
case UV_A_STANDOUT:
|
||||
str_numset(str, (double)A_STANDOUT);
|
||||
break;
|
||||
case UV_A_UNDERLINE:
|
||||
str_numset(str, (double)A_UNDERLINE);
|
||||
break;
|
||||
case UV_A_REVERSE:
|
||||
str_numset(str, (double)A_REVERSE);
|
||||
break;
|
||||
case UV_A_BLINK:
|
||||
str_numset(str, (double)A_BLINK);
|
||||
break;
|
||||
case UV_A_DIM:
|
||||
str_numset(str, (double)A_DIM);
|
||||
break;
|
||||
case UV_A_BOLD:
|
||||
str_numset(str, (double)A_BOLD);
|
||||
break;
|
||||
case UV_A_NORMAL:
|
||||
str_numset(str, (double)A_NORMAL);
|
||||
break;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int
|
||||
userset(ix, str)
|
||||
int ix;
|
||||
STR *str;
|
||||
{
|
||||
switch (ix) {
|
||||
case UV_COLS:
|
||||
COLS = (int)str_gnum(str);
|
||||
break;
|
||||
case UV_LINES:
|
||||
LINES = (int)str_gnum(str);
|
||||
break;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
66
gnu/usr.bin/perl/usub/man2mus
Executable file
66
gnu/usr.bin/perl/usub/man2mus
Executable file
@ -0,0 +1,66 @@
|
||||
#!/usr/bin/perl
|
||||
while (<>) {
|
||||
if (/^\.SH SYNOPSIS/) {
|
||||
$spec = '';
|
||||
for ($_ = <>; $_ && !/^\.SH/; $_ = <>) {
|
||||
s/^\.[IRB][IRB]\s*//;
|
||||
s/^\.[IRB]\s+//;
|
||||
next if /^\./;
|
||||
s/\\f\w//g;
|
||||
s/\\&//g;
|
||||
s/^\s+//;
|
||||
next if /^$/;
|
||||
next if /^#/;
|
||||
$spec .= $_;
|
||||
}
|
||||
$_ = $spec;
|
||||
0 while s/\(([^),;]*)\s*,\s*([^);]*)\)/($1|$2)/g;
|
||||
s/\(\*([^,;]*)\)\(\)/(*)()$1/g;
|
||||
s/(\w+)\[\]/*$1/g;
|
||||
|
||||
s/\n/ /g;
|
||||
s/\s+/ /g;
|
||||
s/(\w+) \(([^*])/$1($2/g;
|
||||
s/^ //;
|
||||
s/ ?; ?/\n/g;
|
||||
s/\) /)\n/g;
|
||||
s/ \* / \*/g;
|
||||
s/\* / \*/g;
|
||||
|
||||
$* = 1;
|
||||
0 while s/^((struct )?\w+ )([^\n,]*), ?(.*)/$1$3\n$1$4/g;
|
||||
$* = 0;
|
||||
s/\|/,/g;
|
||||
|
||||
@cases = ();
|
||||
for (reverse split(/\n/,$_)) {
|
||||
if (/\)$/) {
|
||||
($type,$name,$args) = split(/(\w+)\(/);
|
||||
$type =~ s/ $//;
|
||||
if ($type =~ /^(\w+) =/) {
|
||||
$type = $type{$1} if $type{$1};
|
||||
}
|
||||
$type = 'int' if $type eq '';
|
||||
@args = grep(/./, split(/[,)]/,$args));
|
||||
$case = "CASE $type $name\n";
|
||||
foreach $arg (@args) {
|
||||
$type = $type{$arg} || "int";
|
||||
$type =~ s/ //g;
|
||||
$type .= "\t" if length($type) < 8;
|
||||
if ($type =~ /\*/) {
|
||||
$case .= "IO $type $arg\n";
|
||||
}
|
||||
else {
|
||||
$case .= "I $type $arg\n";
|
||||
}
|
||||
}
|
||||
$case .= "END\n\n";
|
||||
unshift(@cases, $case);
|
||||
}
|
||||
else {
|
||||
$type{$name} = $type if ($type,$name) = /(.*\W)(\w+)$/;
|
||||
}
|
||||
}
|
||||
print @cases;
|
||||
}
|
||||
}
|
||||
135
gnu/usr.bin/perl/usub/mus
Executable file
135
gnu/usr.bin/perl/usub/mus
Executable file
@ -0,0 +1,135 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
while (<>) {
|
||||
if (s/^CASE\s+//) {
|
||||
@fields = split;
|
||||
$funcname = pop(@fields);
|
||||
$rettype = "@fields";
|
||||
@modes = ();
|
||||
@types = ();
|
||||
@names = ();
|
||||
@outies = ();
|
||||
@callnames = ();
|
||||
$pre = "\n";
|
||||
$post = '';
|
||||
|
||||
while (<>) {
|
||||
last unless /^[IO]+\s/;
|
||||
@fields = split(' ');
|
||||
push(@modes, shift(@fields));
|
||||
push(@names, pop(@fields));
|
||||
push(@types, "@fields");
|
||||
}
|
||||
while (s/^<\s//) {
|
||||
$pre .= "\t $_";
|
||||
$_ = <>;
|
||||
}
|
||||
while (s/^>\s//) {
|
||||
$post .= "\t $_";
|
||||
$_ = <>;
|
||||
}
|
||||
$items = @names;
|
||||
$namelist = '$' . join(', $', @names);
|
||||
$namelist = '' if $namelist eq '$';
|
||||
print <<EOF;
|
||||
case US_$funcname:
|
||||
if (items != $items)
|
||||
fatal("Usage: &$funcname($namelist)");
|
||||
else {
|
||||
EOF
|
||||
if ($rettype eq 'void') {
|
||||
print <<EOF;
|
||||
int retval = 1;
|
||||
EOF
|
||||
}
|
||||
else {
|
||||
print <<EOF;
|
||||
$rettype retval;
|
||||
EOF
|
||||
}
|
||||
foreach $i (1..@names) {
|
||||
$mode = $modes[$i-1];
|
||||
$type = $types[$i-1];
|
||||
$name = $names[$i-1];
|
||||
if ($type =~ /^[A-Z]+\*$/) {
|
||||
$cast = "*($type*)";
|
||||
}
|
||||
else {
|
||||
$cast = "($type)";
|
||||
}
|
||||
$what = ($type =~ /^(struct\s+\w+|char|[A-Z]+)\s*\*$/ ? "get" : "gnum");
|
||||
$type .= "\t" if length($type) < 4;
|
||||
$cast .= "\t" if length($cast) < 8;
|
||||
$x = "\t" x (length($name) < 6);
|
||||
if ($mode =~ /O/) {
|
||||
if ($what eq 'gnum') {
|
||||
push(@outies, "\t str_numset(st[$i], (double) $name);\n");
|
||||
push(@callnames, "&$name");
|
||||
}
|
||||
else {
|
||||
push(@outies, "\t str_set(st[$i], (char*) $name);\n");
|
||||
push(@callnames, "$name");
|
||||
}
|
||||
}
|
||||
else {
|
||||
push(@callnames, $name);
|
||||
}
|
||||
if ($mode =~ /I/) {
|
||||
print <<EOF;
|
||||
$type $name =$x $cast str_$what(st[$i]);
|
||||
EOF
|
||||
}
|
||||
elsif ($type =~ /char/) {
|
||||
print <<EOF;
|
||||
char ${name}[133];
|
||||
EOF
|
||||
}
|
||||
else {
|
||||
print <<EOF;
|
||||
$type $name;
|
||||
EOF
|
||||
}
|
||||
}
|
||||
$callnames = join(', ', @callnames);
|
||||
$outies = join("\n",@outies);
|
||||
if ($rettype eq 'void') {
|
||||
print <<EOF;
|
||||
$pre (void)$funcname($callnames);
|
||||
EOF
|
||||
}
|
||||
else {
|
||||
print <<EOF;
|
||||
$pre retval = $funcname($callnames);
|
||||
EOF
|
||||
}
|
||||
if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) {
|
||||
print <<EOF;
|
||||
str_set(st[0], (char*) retval);
|
||||
EOF
|
||||
}
|
||||
elsif ($rettype =~ /^[A-Z]+\s*\*$/) {
|
||||
print <<EOF;
|
||||
str_nset(st[0], (char*) &retval, sizeof retval);
|
||||
EOF
|
||||
}
|
||||
else {
|
||||
print <<EOF;
|
||||
str_numset(st[0], (double) retval);
|
||||
EOF
|
||||
}
|
||||
print $outies if $outies;
|
||||
print $post if $post;
|
||||
if (/^END/) {
|
||||
print "\t}\n\treturn sp;\n";
|
||||
}
|
||||
else {
|
||||
redo;
|
||||
}
|
||||
}
|
||||
elsif (/^END/) {
|
||||
print "\t}\n\treturn sp;\n";
|
||||
}
|
||||
else {
|
||||
print;
|
||||
}
|
||||
}
|
||||
190
gnu/usr.bin/perl/usub/pager
Executable file
190
gnu/usr.bin/perl/usub/pager
Executable file
@ -0,0 +1,190 @@
|
||||
#!/usr/bin/curseperl
|
||||
|
||||
eval <<'EndOfMain'; $evaloffset = __LINE__;
|
||||
|
||||
$SIG{'INT'} = 'endit';
|
||||
$| = 1; # command buffering on stdout
|
||||
&initterm;
|
||||
&inithelp;
|
||||
&slurpfile && &pagearray;
|
||||
|
||||
EndOfMain
|
||||
|
||||
&endit;
|
||||
|
||||
################################################################################
|
||||
|
||||
sub initterm {
|
||||
|
||||
&initscr; &cbreak; &noecho; &scrollok($stdscr, 1);
|
||||
&defbell unless defined &bell;
|
||||
|
||||
$lines = $LINES; $lines1 = $lines - 1; $lines2 = $lines - 2;
|
||||
$cols = $COLS; $cols1 = $cols - 1; $cols2 = $cols - 2;;
|
||||
|
||||
$dl = &getcap('dl');
|
||||
$al = &getcap('al');
|
||||
$ho = &getcap('ho');
|
||||
$ce = &getcap('ce');
|
||||
}
|
||||
|
||||
sub slurpfile {
|
||||
while (<>) {
|
||||
s/^(\t+)/' ' x length($1)/e;
|
||||
&expand($_) if /\t/;
|
||||
if (length($_) < $cols) {
|
||||
push(@lines, $_);
|
||||
}
|
||||
else {
|
||||
while ($_ && $_ ne "\n") {
|
||||
push(@lines, substr($_,0,$cols));
|
||||
substr($_,0,$cols) = '';
|
||||
}
|
||||
}
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub drawscreen {
|
||||
&move(0,0);
|
||||
for ($line .. $line + $lines2) {
|
||||
&addstr($lines[$_]);
|
||||
}
|
||||
&clrtobot;
|
||||
&percent;
|
||||
&refresh;
|
||||
}
|
||||
|
||||
sub expand {
|
||||
while (($off = index($_[0],"\t")) >= 0) {
|
||||
substr($_[0], $off, 1) = ' ' x (8 - $off % 8);
|
||||
}
|
||||
}
|
||||
|
||||
sub pagearray {
|
||||
$line = 0;
|
||||
|
||||
$| = 1;
|
||||
|
||||
for (&drawscreen;;&drawscreen) {
|
||||
|
||||
$ch = &getch;
|
||||
$ch = 'j' if $ch eq "\n";
|
||||
|
||||
if ($ch eq ' ') {
|
||||
last if $percent >= 100;
|
||||
&move(0,0);
|
||||
$line += $lines1;
|
||||
}
|
||||
elsif ($ch eq 'b') {
|
||||
$line -= $lines1;
|
||||
&move(0,0);
|
||||
$line = 0 if $line < 0;
|
||||
}
|
||||
elsif ($ch eq 'j') {
|
||||
next if $percent >= 100;
|
||||
$line += 1;
|
||||
if ($dl && $ho) {
|
||||
print $ho, $dl;
|
||||
&mvcur(0,0,$lines2,0);
|
||||
print $ce,$lines[$line+$lines2],$ce;
|
||||
&wmove($curscr,0,0);
|
||||
&wdeleteln($curscr);
|
||||
&wmove($curscr,$lines2,0);
|
||||
&waddstr($curscr,$lines[$line+$lines2]);
|
||||
}
|
||||
&wmove($stdscr,0,0);
|
||||
&wdeleteln($stdscr);
|
||||
&wmove($stdscr,$lines2,0);
|
||||
&waddstr($stdscr,$lines[$line+$lines2]);
|
||||
&percent;
|
||||
&refresh;
|
||||
redo;
|
||||
}
|
||||
elsif ($ch eq 'k') {
|
||||
next if $line <= 0;
|
||||
$line -= 1;
|
||||
if ($al && $ho && $ce) {
|
||||
print $ho, $al, $ce, $lines[$line];
|
||||
&wmove($curscr,0,0);
|
||||
&winsertln($curscr);
|
||||
&waddstr($curscr,$lines[$line]);
|
||||
}
|
||||
&wmove($stdscr,0,0);
|
||||
&winsertln($stdscr);
|
||||
&waddstr($stdscr,$lines[$line]);
|
||||
&percent;
|
||||
&refresh;
|
||||
redo;
|
||||
}
|
||||
elsif ($ch eq "\f") {
|
||||
&clear;
|
||||
}
|
||||
elsif ($ch eq 'q') {
|
||||
last;
|
||||
}
|
||||
elsif ($ch eq 'h') {
|
||||
&clear;
|
||||
&help;
|
||||
&clear;
|
||||
}
|
||||
else {
|
||||
&bell;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub defbell {
|
||||
eval q#
|
||||
sub bell {
|
||||
print "\007";
|
||||
}
|
||||
#;
|
||||
}
|
||||
|
||||
sub help {
|
||||
local(*lines) = *helplines;
|
||||
local($line);
|
||||
&pagearray;
|
||||
}
|
||||
|
||||
sub inithelp {
|
||||
@helplines = split(/\n/,<<'EOT');
|
||||
|
||||
h Display this help.
|
||||
q Exit.
|
||||
|
||||
SPACE Forward screen.
|
||||
b Backward screen.
|
||||
j, CR Forward 1 line.
|
||||
k Backward 1 line.
|
||||
FF Repaint screen.
|
||||
EOT
|
||||
for (@helplines) {
|
||||
s/$/\n/;
|
||||
}
|
||||
}
|
||||
|
||||
sub percent {
|
||||
&standout;
|
||||
$percent = int(($line + $lines1) * 100 / @lines);
|
||||
&move($lines1,0);
|
||||
&addstr("($percent%)");
|
||||
&standend;
|
||||
&clrtoeol;
|
||||
}
|
||||
|
||||
sub endit {
|
||||
&move($lines1,0);
|
||||
&clrtoeol;
|
||||
&refresh;
|
||||
&endwin;
|
||||
|
||||
if ($@) {
|
||||
print ""; # force flush of stdout
|
||||
$@ =~ s/\(eval\)/$0/ && $@ =~ s/line (\d+)/'line ' . ($1 + $evaloffset)/e;
|
||||
die $@;
|
||||
}
|
||||
|
||||
exit;
|
||||
}
|
||||
72
gnu/usr.bin/perl/usub/usersub.c
Normal file
72
gnu/usr.bin/perl/usub/usersub.c
Normal file
@ -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()
|
||||
{
|
||||
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);
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user