diff options
Diffstat (limited to 'gnu/usr.bin/perl')
| -rw-r--r-- | gnu/usr.bin/perl/Makefile | 2 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/usub/Makefile | 21 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/usub/README | 117 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/usub/curses.mus | 808 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/usub/man2mus | 66 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/usub/mus | 135 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/usub/pager | 190 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/usub/usersub.c | 72 |
8 files changed, 1410 insertions, 1 deletions
diff --git a/gnu/usr.bin/perl/Makefile b/gnu/usr.bin/perl/Makefile index 3ef6485b9745..661af5f66367 100644 --- a/gnu/usr.bin/perl/Makefile +++ b/gnu/usr.bin/perl/Makefile @@ -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> diff --git a/gnu/usr.bin/perl/usub/Makefile b/gnu/usr.bin/perl/usub/Makefile new file mode 100644 index 000000000000..7ecc6d365290 --- /dev/null +++ b/gnu/usr.bin/perl/usub/Makefile @@ -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> diff --git a/gnu/usr.bin/perl/usub/README b/gnu/usr.bin/perl/usub/README new file mode 100644 index 000000000000..4e145962b3d0 --- /dev/null +++ b/gnu/usr.bin/perl/usub/README @@ -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. diff --git a/gnu/usr.bin/perl/usub/curses.mus b/gnu/usr.bin/perl/usub/curses.mus new file mode 100644 index 000000000000..2c4d5d6013e3 --- /dev/null +++ b/gnu/usr.bin/perl/usub/curses.mus @@ -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; +} diff --git a/gnu/usr.bin/perl/usub/man2mus b/gnu/usr.bin/perl/usub/man2mus new file mode 100755 index 000000000000..a3046784f423 --- /dev/null +++ b/gnu/usr.bin/perl/usub/man2mus @@ -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; + } +} diff --git a/gnu/usr.bin/perl/usub/mus b/gnu/usr.bin/perl/usub/mus new file mode 100755 index 000000000000..b1675fdc5879 --- /dev/null +++ b/gnu/usr.bin/perl/usub/mus @@ -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; + } +} diff --git a/gnu/usr.bin/perl/usub/pager b/gnu/usr.bin/perl/usub/pager new file mode 100755 index 000000000000..1b468a05fbdb --- /dev/null +++ b/gnu/usr.bin/perl/usub/pager @@ -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; +} diff --git a/gnu/usr.bin/perl/usub/usersub.c b/gnu/usr.bin/perl/usub/usersub.c new file mode 100644 index 000000000000..ffbfbe155213 --- /dev/null +++ b/gnu/usr.bin/perl/usub/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() +{ + 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); +} |