Newsgroups: comp.sources.misc From: lwall@netlabs.com (Larry Wall) Subject: v25i060: perl - The perl programming language, Patch11 Message-ID: X-Md4-Signature: d15254ef4059f32bd601455797d4e5b9 Date: Wed, 13 Nov 1991 21:41:29 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: lwall@netlabs.com (Larry Wall) Posting-number: Volume 25, Issue 60 Archive-name: perl/patch11 Environment: UNIX, MS-DOS, OS2 Patch-To: perl: Volume 18, Issue 19-54 System: perl version 4.0 Patch #: 11 Priority: MED-HIGH Subject: added eval {} Subject: eval 'stuff' now optimized to eval {stuff} This set of patches doesn't have many enhancements but this is one of them. The eval operator has two distinct semantic functions. First, it runs the parser on some random string and executes it. Second, it traps exceptions and returns them in $@. There are times when you'd like to get the second function without the first. In order to do that, you can now eval a block of code, which is parsed like ordinary code at compile time, but which traps any run-time errors and returns them in the $@ variable. For instance, to trap divide by zero errors: eval { $answer = $foo / $bar; }; warn $@ if $@; Since single-quoted strings don't ever change, they are optimized to the eval {} form the first time they are encountered at run-time. This doesn't happen too often, though some of you have written things like eval '&try_this;'. However, the righthand side of s///e is evaluated as a single-quoted string, so this construct should run somewhat faster now. Subject: added sort {} LIST Another enhancement that some of you have been hankering for. You can now inline the sort subroutine as a block where the subroutine name used to go: @articles = sort {$a <=> $b;} readdir(DIR); Subject: added some support for 64-bit integers For Convexen and Crayen, which have 64-bit integers, there's now pack, unpack and sprintf support for 64-bit integers. Subject: sprintf() now supports any length of s field You can now use formats like %2048s and %-8192.8192s. Perl will totally bypass your system's sprintf() function on these. No, you still probably can't say %2048d. No, I'm not going to change that any time soon. Subject: substr() and vec() weren't allowed in an lvalue list Subject: extra comma at end of list is now allowed in more places (Hi, Felix!) Subject: underscore is now allowed within literal octal and hex numbers Various syntactic relaxations. You can now get away with (substr($foo,0,3), substr($bar,0,3)) = ('abc', 'def'); (1,2,3,)[$x]; $addr = 0x1a20_ff0b; Subject: safe malloc code now integrated into Perl's malloc when possible To save a bunch of subroutine calls. If you use your system's malloc it still has to use wrappers. Subject: added support for dbz By saying "make dbzperl" you can make a copy of Perl that can access C news's dbz files. You still have to follow the dbz rules, though, if you're going to try to write a dbz file. Subject: there are now subroutines for calling back from C into Perl Subject: usub/curses.mus now supports SysV curses More C linkage support. I still haven't got Perl embeddable, but we're getting there. That's too big an enhancement for this update, in which I've been trying to stick to bug fixes, with some success. Subject: prepared for ctype implementations that don't define isascii() A larger percentage of this update consists of code to do consistent ctype processing whether or not is 8-bit clean. Subject: /$foo/o optimizer could access deallocated data Subject: certain optimizations of //g in array context returned too many values Subject: regexp with no parens in array context returned wacky $`, $& and $' Subject: $' not set right on some //g Subject: grep of a split lost its values Subject: # fields could write outside allocated memory Subject: length($x) was sometimes wrong for numeric $x Recently added or modified stuff that you kind of expect to be a bit flaky still. Well, I do... Subject: passing non-existend array elements to subrouting caused core dump Subject: "foo" x -1 dumped core Subject: truncate on a closed filehandle could dump Subject: a last statement outside any block caused occasional core dumps Subject: missing arguments caused core dump in -D8 code Subject: cacheout.pl could dump core from invalid comparison operator Subject: *foo = undef coredumped Subject: warn '-' x 10000 dumped core Subject: index("little", "longer string") could visit faraway places A bunch of natty little bugs that you wouldn't generally run into unless you're trying to be coy. Subject: hex() didn't understand leading 0x It wasn't documented that it should work, but oct() understands 0x, so why not hex()? I dunno... Subject: "foo\0" eq "foo" was sometimes optimized to true Subject: eval confused by string containing null Yet more holdovers from the time before Perl was 8-bit clean. Subject: foreach on null list could spring memory leak Subject: local(*FILEHANDLE) had a memory leak Kind of slow leaks, as leaks go. Still... Subject: minimum match length calculation in regexp is now cumulative More substitutions can be done in place now because Perl knows that patterns like in s/foo\s+bar/1234567/ have to match a certain number of characters total. It used to be on that particular pattern that it only knew that it had to match at least 3 characters. Now it know it has to match at least 7. Subject: multiple reallocations now avoided in 1 .. 100000 You still don't want to say 1 .. 1000000, but at least it will refrain from allocating intermediate sized blocks while it's constructing the value, and won't do the extra copies implied by realloc. Subject: indirect subroutine calls through magic vars (e.g. &$1) didn't work Subject: defined(&$foo) and undef(&$foo) didn't work Subject: certain perl errors should set EBADF so that $! looks better Subject: stats of _ forgot whether prior stat was actually lstat Subject: -T returned true on NFS directory Subject: sysread() in socket was substituting recv() Subject: formats didn't fill their fields as well as they could Subject: ^ fields chopped hyphens on line break Subject: -P didn't allow use of #elif or #undef Subject: $0 was being truncated at times Subject: forked exec on non-existent program now issues a warning Various things you'd expect to work the way you expect, but didn't when you did, or I did, or something... Subject: perl mistook some streams for sockets because they return mode 0 too Subject: reopening STDIN, STDOUT and STDERR failed on some machines Problems opening files portably. So what's new? Subject: cppstdin now installed outside of source directory Subject: installperl now overrides installer's umask People who used cppstdin for the cpp filter or who had their umask set to 700 will now be happier. (And Configure will now prefer /lib/cpp over cppstdin like it used to. If this gives your machine heartburn because /lib/cpp doesn't set the symbols it should, write a hints file to poke them into ccflags.) Subject: initial .* in pattern had dependency on value of $* An initial .* was optimized to have a ^ on the front to avoid retrying when we know it won't match. Unfortunately this implicit ^ was paying attention to $*, which it shouldn't have been. Subject: certain patterns made use of garbage pointers from uncleared memory Many of you saw this as a failure in t/op/pat.t. Subject: perl now issues warning if $SIG{'ALARM'} is referenced Since the book mentions "SIGALARM", I thought we needed this. Subject: solitary subroutine references no longer trigger typo warnings You can now use -w (more) profitably on programs that require other files. I figured if you mistype a subroutine name you'll get a fatal error anyway, unlike a variable, which just defaults to being undefined. Subject: $foo .= could overrun malloced memory Good old-fashioned bug. Subject: \$ didn't always make it through double-quoter to regexp routines Subject: \x and \c were subject to double interpretation in regexps Subject: nested list operators could miscount parens Subject: sort eval "whatever" didn't work Syntactic misfeatures of various sorts. Subject: find2perl produced incorrect code for -group Subject: find2perl could be confused by names containing whitespace Subject: in a2p, split on whitespace produced extra null field Translator stuff. Subject: new complete.pl from Wayne Thompson Subject: assert.pl and exceptions.pl from Tom Christiansen Subject: added Tom's c2ph stuff Subject: getcwd.pl from Brandon S. Allbery Subject: fastcwd.pl from John Basik Subject: chat2.pl from Randal L. Schwartz New contributed stuff. Thanks! (Not that a lot of the other stuff isn't contributed too...) Subject: debugger got confused over nested subroutine definitions Subject: once-thru blocks didn't display right in the debugger Subject: perldb.pl modified to run within emacs in perldb-mode Debugger stuff. The first two were caused by not saving line numbers at exactly the right moment. Subject: documented meaning of scalar(%foo) I also updated the Errata section of the man page. Subject: various portability fixes Subject: random cleanup Subject: saberized perl Type casts, saber warning message suppression, hints files and various metaconfig fiddlehoods. Fix: From rn, say "| patch -p -N -d DIR", where DIR is your perl source directory. Outside of rn, say "cd DIR; patch -p -N #define PATCHLEVEL 11 Index: Configure Prereq: 4.0.1.2 *** Configure.old Tue Nov 5 23:12:54 1991 --- Configure Tue Nov 5 23:12:55 1991 *************** *** 8,14 **** # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # ! # $RCSfile: Configure,v $$Revision: 4.0.1.2 $$Date: 91/06/07 10:09:34 $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than --- 8,14 ---- # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # ! # $RCSfile: Configure,v $$Revision: 4.0.1.5 $$Date: 91/11/05 23:11:32 $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than *************** *** 17,30 **** cat >/tmp/c1$$ </tmp/c2$$ </tmp/c1$$ </tmp/c2$$ <&1` fi if test -d ../hints && test ! -f ../config.sh; then echo ' ' *************** *** 1262,1267 **** --- 1277,1287 ---- n*) nativegcc="$undef"; gccflags='-fpcc-struct-return';; *) nativegcc="$define"; gccflags='';; esac + case "$gccflags" in + *-ansi*) ;; + *-traditional*) ;; + *) gccflags="$gccflags -traditional -Dvolatile=__volatile__" ;; + esac ;; esac *************** *** 1710,1716 **** cd .. echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin chmod 755 cppstdin ! wrapper=`pwd`/cppstdin cd UU if test "X$cppstdin" != "X" && \ --- 1730,1741 ---- cd .. echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin chmod 755 cppstdin ! wrapper=cppstdin ! ! case "$cppstdin" in ! /*cppstdin) cppstdin=cppstdin;; ! esac ! cp cppstdin UU cd UU if test "X$cppstdin" != "X" && \ *************** *** 1736,1747 **** echo "Yup, it does." cppstdin="$cc -E" cppminus='-'; - elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ - $wrapper testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - cppstdin="$wrapper" - cppminus='' - echo "Eureka!." elif echo 'No such luck, maybe "'$cpp'" will work...'; \ $cpp testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then --- 1761,1766 ---- *************** *** 1754,1759 **** --- 1773,1784 ---- echo "Hooray, it works! I was beginning to wonder." cppstdin="$cpp" cppminus='-'; + elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ + $wrapper testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + cppstdin="$wrapper" + cppminus='' + echo "Eureka!." elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ $cc -P testcpp.out 2>&1; \ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then *************** *** 2497,2503 **** if $test -r $usrinclude/pwd.h ; then i_pwd="$define" echo "pwd.h found." ! $cppstdin $cppflags $cppminus <$usrinclude/pwd.h >pwd.txt if $contains 'pw_quota' pwd.txt >/dev/null 2>&1; then d_pwquota="$define" else --- 2522,2529 ---- if $test -r $usrinclude/pwd.h ; then i_pwd="$define" echo "pwd.h found." ! $cppstdin $cppflags $cppminus <$usrinclude/pwd.h | \ ! sed -n '/struct[ ][ ]*passwd/,/^};/p' >pwd.txt if $contains 'pw_quota' pwd.txt >/dev/null 2>&1; then d_pwquota="$define" else *************** *** 3029,3044 **** : determine which malloc to compile in echo " " ! case "$usemymalloc" in '') ! if bsd || v7; then ! dflt='y' ! else ! dflt='n' ! fi ;; ! *) dflt="$usemymalloc" ;; esac rp="Do you wish to attempt to use the malloc that comes with $package? [$dflt]" $echo $n "$rp $c" --- 3055,3078 ---- : determine which malloc to compile in echo " " ! case "$d_mymalloc" in '') ! case "$usemymalloc" in ! '') ! if bsd || v7; then ! dflt='y' ! else ! dflt='n' ! fi ! ;; ! n*) dflt=n;; ! *) dflt=y;; ! esac ;; ! define) dflt="y" ;; + *) dflt="n" + ;; esac rp="Do you wish to attempt to use the malloc that comes with $package? [$dflt]" $echo $n "$rp $c" *************** *** 3046,3055 **** case "$ans" in '') ans=$dflt;; esac - usemymalloc="$ans" case "$ans" in y*) mallocsrc='malloc.c'; mallocobj='malloc.o' libs=`echo $libs | sed 's/-lmalloc//'` case "$mallocptrtype" in '') cat >usemymalloc.c <<'END' --- 3080,3089 ---- case "$ans" in '') ans=$dflt;; esac case "$ans" in y*) mallocsrc='malloc.c'; mallocobj='malloc.o' libs=`echo $libs | sed 's/-lmalloc//'` + val="$define" case "$mallocptrtype" in '') cat >usemymalloc.c <<'END' *************** *** 3070,3077 **** echo " " echo "Your system wants malloc to return $mallocptrtype*, it would seem." ;; ! *) mallocsrc=''; mallocobj=''; mallocptrtype=void;; esac : determine where private executables go case "$privlib" in --- 3104,3117 ---- echo " " echo "Your system wants malloc to return $mallocptrtype*, it would seem." ;; ! *) mallocsrc=''; ! mallocobj=''; ! mallocptrtype=void ! val="$define" ! ;; esac + set d_mymalloc + eval $setvar : determine where private executables go case "$privlib" in *************** *** 3734,3740 **** ndiro='$ndiro' mallocsrc='$mallocsrc' mallocobj='$mallocobj' ! usemymalloc='$usemymalloc' mallocptrtype='$mallocptrtype' mansrc='$mansrc' manext='$manext' --- 3774,3780 ---- ndiro='$ndiro' mallocsrc='$mallocsrc' mallocobj='$mallocobj' ! d_mymalloc='$d_mymalloc' mallocptrtype='$mallocptrtype' mansrc='$mansrc' manext='$manext' Index: Makefile.SH *** Makefile.SH.old Tue Nov 5 19:25:22 1991 --- Makefile.SH Tue Nov 5 19:25:23 1991 *************** *** 25,33 **** echo "Extracting Makefile (with variable substitutions)" cat >Makefile <Makefile <.shlist # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE ! $(obj): @ echo "You haven't done a "'"make depend" yet!'; exit 1 makedepend: makedepend.SH /bin/sh makedepend.SH --- 351,357 ---- echo $(sh) | tr ' ' '\012' >.shlist # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE ! $(obj) hash.o: @ echo "You haven't done a "'"make depend" yet!'; exit 1 makedepend: makedepend.SH /bin/sh makedepend.SH *************** *** 339,341 **** --- 363,366 ---- ln Makefile ../Makefile ;; esac + rm -f makefile Index: x2p/Makefile.SH *** x2p/Makefile.SH.old Tue Nov 5 19:28:33 1991 --- x2p/Makefile.SH Tue Nov 5 19:28:33 1991 *************** *** 13,27 **** . ./config.sh ;; esac - case "$mallocsrc" in - '') ;; - *) mallocsrc="../$mallocsrc";; - esac echo "Extracting x2p/Makefile (with variable substitutions)" cat >Makefile <Makefile < a2p.fuzz ! depend: ../makedepend ../makedepend clist: --- 118,124 ---- lint: lint $(lintflags) $(defs) $(c) > a2p.fuzz ! depend: $(mallocsrc) ../makedepend ../makedepend clist: *************** *** 135,140 **** --- 134,142 ---- rm -f config.sh ln ../config.sh . + malloc.c: ../malloc.c + sed 's/"perl.h"/"..\/perl.h"/' ../malloc.c >malloc.c + # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE $(obj): @ echo "You haven't done a "'"make depend" yet!'; exit 1 *************** *** 148,150 **** --- 150,153 ---- ln Makefile ../Makefile ;; esac + rm -f makefile Index: README *** README.old Tue Nov 5 19:25:25 1991 --- README Tue Nov 5 19:25:26 1991 *************** *** 149,154 **** --- 149,156 ---- If you have GDBM available and want it instead of NDBM, say -DHAS_GDBM. C's that don't try to restore registers on longjmp() may need -DJMPCLOBBER. (Try this if you get random glitches.) + If you get duplicates upon linking for malloc et al, say -DHIDEMYMALLOC. + Turn on support for 64-bit integers (long longs) with -DQUAD. 5) make test Index: hints/altos486.sh *** hints/altos486.sh.old Tue Nov 5 19:26:26 1991 --- hints/altos486.sh Tue Nov 5 19:26:27 1991 *************** *** 0 **** --- 1,3 ---- + : have heard of problems with -lc_s on Altos 486 + set `echo " $libswanted " | sed "s/ c_s / /"` + libswanted="$*" Index: hints/apollo_C6_8.sh *** hints/apollo_C6_8.sh.old Tue Nov 5 19:26:28 1991 --- hints/apollo_C6_8.sh Tue Nov 5 19:26:28 1991 *************** *** 0 **** --- 1,20 ---- + optimize='' + ccflags='-DDEBUGGING -A cpu,mathchip -W0,-opt,2' + + cat <<'EOF' + Some tests may fail unless you use 'chacl -B'. Also, op/stat + test 2 may fail occasionally because Apollo doesn't guarantee + that mtime will be equal to ctime on a newly created unmodified + file. Finally, the sleep test will sometimes fail. See the + sleep(3) man page to learn why. + + And a note on ccflags: + + Lastly, while -A cpu,mathchip generates optimal code for your DN3500 + running sr10.3, be aware that you should be using -A cpu,mathlib_sr10 + if your perl must also run on any machines running sr10.0, sr10.1, or + sr10.2. The -A cpu,mathchip option generates code that doesn't work on + pre-sr10.3 nodes. See the cc(1) man page for more details. + -- Steve Vinoski + + EOF Index: lib/assert.pl *** lib/assert.pl.old Tue Nov 5 19:26:48 1991 --- lib/assert.pl Tue Nov 5 19:26:48 1991 *************** *** 0 **** --- 1,52 ---- + # assert.pl + # tchrist@convex.com (Tom Christiansen) + # + # Usage: + # + # &assert('@x > @y'); + # &assert('$var > 10', $var, $othervar, @various_info); + # + # That is, if the first expression evals false, we blow up. The + # rest of the args, if any, are nice to know because they will + # be printed out by &panic, which is just the stack-backtrace + # routine shamelessly borrowed from the perl debugger. + + sub assert { + &panic("ASSERTION BOTCHED: $_[0]",$@) unless eval $_[0]; + } + + sub panic { + select(STDERR); + + print "\npanic: @_\n"; + + exit 1 if $] <= 4.003; # caller broken + + # stack traceback gratefully borrowed from perl debugger + + local($i,$_); + local($p,$f,$l,$s,$h,$a,@a,@sub); + for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { + @a = @DB'args; + for (@a) { + if (/^StB\000/ && length($_) == length($_main{'_main'})) { + $_ = sprintf("%s",$_); + } + else { + s/'/\\'/g; + s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + push(@sub, "$w&$s$a from file $f line $l\n"); + } + for ($i=0; $i <= $#sub; $i++) { + print $sub[$i]; + } + exit 1; + } + + 1; Index: usub/bsdcurses.mus *** usub/bsdcurses.mus.old Tue Nov 5 19:28:15 1991 --- usub/bsdcurses.mus Tue Nov 5 19:28:16 1991 *************** *** 0 **** --- 1,684 ---- + /* $RCSfile: bsdcurses.mus,v $$Revision: 4.0.1.1 $$Date: 91/11/05 19:04:53 $ + * + * $Log: bsdcurses.mus,v $ + * Revision 4.0.1.1 91/11/05 19:04:53 lwall + * initial checkin + * + * 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(); + + #include + + static enum uservars { + UV_curscr, + UV_stdscr, + UV_Def_term, + UV_My_term, + UV_ttytype, + UV_LINES, + UV_COLS, + UV_ERR, + UV_OK, + }; + + 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_flushok, + US_idlok, + US_insch, + US_winsch, + US_insertln, + US_winsertln, + US_move, + US_wmove, + US_overlay, + US_overwrite, + US_printw, + US_wprintw, + 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_scanw, + US_wscanw, + US_baudrate, + US_delwin, + US_endwin, + US_erasechar, + US_getcap, + US_getyx, + US_inch, + US_winch, + US_initscr, + US_killchar, + US_leaveok, + US_longname, + US_fullname, + US_mvwin, + US_newwin, + US_nl, + US_nonl, + US_scrollok, + US_subwin, + US_touchline, + US_touchoverlap, + US_touchwin, + US_unctrl, + US_gettmode, + US_mvcur, + US_scroll, + US_savetty, + US_resetty, + US_setterm, + US_tstp, + US__putchar, + 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("Def_term",UV_Def_term); + MAGICVAR("My_term", UV_My_term); + MAGICVAR("ttytype", UV_ttytype); + MAGICVAR("LINES", UV_LINES); + MAGICVAR("COLS", UV_COLS); + MAGICVAR("ERR", UV_ERR); + MAGICVAR("OK", UV_OK); + + 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("flushok", US_flushok, 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("printw", US_printw, usersub, filename); + make_usub("wprintw", US_wprintw, 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("scanw", US_scanw, usersub, filename); + make_usub("wscanw", US_wscanw, 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("getcap", US_getcap, 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("fullname", US_fullname, 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("touchoverlap", US_touchoverlap,usersub, filename); + make_usub("touchwin", US_touchwin, usersub, filename); + make_usub("unctrl", US_unctrl, usersub, filename); + make_usub("gettmode", US_gettmode, usersub, filename); + 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("setterm", US_setterm, usersub, filename); + make_usub("tstp", US_tstp, usersub, filename); + make_usub("_putchar", US__putchar, usersub, filename); + make_usub("testcallback", US_testcallback,usersub, filename); + }; + + 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 flushok + I WINDOW* win + I bool boolf + 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 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; + + 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; + 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; + str_nset(st[0], &retch, 1); + } + } + return sp; + + CASE int getstr + IO char* str + END + + CASE int wgetstr + I WINDOW* win + IO 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 char* getcap + I char* str + 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 + + CASE char* longname + I char* termbuf + IO char* name + END + + CASE int fullname + I char* termbuf + IO char* name + END + + 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 + I int endx + END + + CASE int touchoverlap + I WINDOW* win1 + I WINDOW* win2 + END + + CASE int touchwin + I WINDOW* win + END + + CASE char* unctrl + I char ch + END + + CASE int gettmode + END + + 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 setterm + I char* name + END + + CASE int tstp + END + + CASE int _putchar + I char ch + END + + case US_testcallback: + sp = callback("callback", sp + items, curcsv->wantarray, 1, items); + break; + + default: + fatal("Unimplemented user-defined subroutine"); + } + return sp; + } + + static int + userval(ix, str) + int ix; + STR *str; + { + switch (ix) { + case UV_COLS: + str_numset(str, (double)COLS); + break; + case UV_Def_term: + str_set(str, Def_term); + break; + case UV_ERR: + str_numset(str, (double)ERR); + break; + case UV_LINES: + str_numset(str, (double)LINES); + break; + case UV_My_term: + str_numset(str, (double)My_term); + 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_ttytype: + str_set(str, ttytype); + 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_Def_term: + Def_term = savestr(str_get(str)); /* never freed */ + break; + case UV_LINES: + LINES = (int)str_gnum(str); + break; + case UV_My_term: + My_term = (bool)str_gnum(str); + break; + case UV_ttytype: + strcpy(ttytype, str_get(str)); /* hope it fits */ + break; + } + return 0; + } *** End of Patch 11 *** exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.