diff options
Diffstat (limited to 'gnu/usr.bin/perl/usub')
| -rw-r--r-- | gnu/usr.bin/perl/usub/Makefile | 32 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/usub/README | 117 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/usub/curses.mus | 813 | ||||
| -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 | 77 |
7 files changed, 0 insertions, 1430 deletions
diff --git a/gnu/usr.bin/perl/usub/Makefile b/gnu/usr.bin/perl/usub/Makefile deleted file mode 100644 index a6c7259..0000000 --- a/gnu/usr.bin/perl/usub/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -PROG= curseperl - -# From perl -SRCS+= array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c -SRCS+= eval.c form.c hash.c perl.c perly.c regcomp.c regexec.c -SRCS+= stab.c str.c toke.c util.c - -# Local to us. -SRCS+= usersub.c curses.c - -CFLAGS+= -DDEBUGGING -I${.CURDIR}/../perl -LDADD+= -lncurses -lmytinfo -lcrypt -lm -DPADD+= ${LIBNCURSES} ${LIBMYTINFO} ${LIBCRYPT} ${LIBM} -CLEANFILES+= curses.c -VPATH+= ${.CURDIR}/../perl -NOMAN= yes - -# If perl exists in none of these places, something is horribly wrong. -.if exists(${.OBJDIR}/../perl/perl) -PERL=${.OBJDIR}/../perl/perl -.endif -.if !defined(PERL) && exists(${.CURDIR}/../perl/perl) -PERL=${.CURDIR}/../perl/perl -.else -PERL= /usr/bin/perl -.endif - -curses.c: curses.mus - ${PERL} ${.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 deleted file mode 100644 index 4e14596..0000000 --- a/gnu/usr.bin/perl/usub/README +++ /dev/null @@ -1,117 +0,0 @@ -[ 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 deleted file mode 100644 index 03269c3..0000000 --- a/gnu/usr.bin/perl/usub/curses.mus +++ /dev/null @@ -1,813 +0,0 @@ -/* $RCSfile: curses.mus,v $$Revision: 1.1 $$Date: 1995/03/24 04:33:49 $ - * - * $Log: curses.mus,v $ -# Revision 1.1 1995/03/24 04:33:49 jkh -# 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). -# - * 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 - -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, -}; - -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 deleted file mode 100755 index a304678..0000000 --- a/gnu/usr.bin/perl/usub/man2mus +++ /dev/null @@ -1,66 +0,0 @@ -#!/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 deleted file mode 100755 index b1675fd..0000000 --- a/gnu/usr.bin/perl/usub/mus +++ /dev/null @@ -1,135 +0,0 @@ -#!/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 deleted file mode 100755 index d55ace2..0000000 --- a/gnu/usr.bin/perl/usub/pager +++ /dev/null @@ -1,190 +0,0 @@ -#!/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 deleted file mode 100644 index 26fbcbc..0000000 --- a/gnu/usr.bin/perl/usub/usersub.c +++ /dev/null @@ -1,77 +0,0 @@ -/* $RCSfile: usersub.c,v $$Revision: 1.1 $$Date: 1995/03/24 04:33:54 $ - * - * $Log: usersub.c,v $ - * Revision 1.1 1995/03/24 04:33:54 jkh - * 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). - * - * 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); -} |
