From bd9f08584221a6bacbfeaebf19d4c3e21fa94a83 Mon Sep 17 00:00:00 2001 From: gclarkii Date: Sat, 10 Sep 1994 06:27:55 +0000 Subject: Initial import of Perl 4.046 bmaked --- gnu/usr.bin/perl/Artistic | 117 + gnu/usr.bin/perl/Copying | 248 ++ gnu/usr.bin/perl/Makefile | 10 + gnu/usr.bin/perl/Makefile.inc | 5 + gnu/usr.bin/perl/README | 195 + gnu/usr.bin/perl/VERSION | 1 + gnu/usr.bin/perl/Wishlist | 9 + gnu/usr.bin/perl/eg/ADB | 8 + gnu/usr.bin/perl/eg/README | 22 + gnu/usr.bin/perl/eg/changes | 34 + gnu/usr.bin/perl/eg/client | 34 + gnu/usr.bin/perl/eg/down | 30 + gnu/usr.bin/perl/eg/dus | 22 + gnu/usr.bin/perl/eg/findcp | 53 + gnu/usr.bin/perl/eg/findtar | 17 + gnu/usr.bin/perl/eg/g/gcp | 114 + gnu/usr.bin/perl/eg/g/gcp.man | 77 + gnu/usr.bin/perl/eg/g/ged | 21 + gnu/usr.bin/perl/eg/g/ghosts | 33 + gnu/usr.bin/perl/eg/g/gsh | 117 + gnu/usr.bin/perl/eg/g/gsh.man | 80 + gnu/usr.bin/perl/eg/muck | 141 + gnu/usr.bin/perl/eg/muck.man | 21 + gnu/usr.bin/perl/eg/myrup | 29 + gnu/usr.bin/perl/eg/nih | 10 + gnu/usr.bin/perl/eg/perlsh | 15 + gnu/usr.bin/perl/eg/relink | 91 + gnu/usr.bin/perl/eg/rename | 83 + gnu/usr.bin/perl/eg/rmfrom | 7 + gnu/usr.bin/perl/eg/scan/scan_df | 51 + gnu/usr.bin/perl/eg/scan/scan_last | 57 + gnu/usr.bin/perl/eg/scan/scan_messages | 222 ++ gnu/usr.bin/perl/eg/scan/scan_passwd | 30 + gnu/usr.bin/perl/eg/scan/scan_ps | 32 + gnu/usr.bin/perl/eg/scan/scan_sudo | 54 + gnu/usr.bin/perl/eg/scan/scan_suid | 84 + gnu/usr.bin/perl/eg/scan/scanner | 87 + gnu/usr.bin/perl/eg/server | 27 + gnu/usr.bin/perl/eg/shmkill | 24 + gnu/usr.bin/perl/eg/sysvipc/README | 9 + gnu/usr.bin/perl/eg/sysvipc/ipcmsg | 47 + gnu/usr.bin/perl/eg/sysvipc/ipcsem | 46 + gnu/usr.bin/perl/eg/sysvipc/ipcshm | 50 + gnu/usr.bin/perl/eg/travesty | 46 + gnu/usr.bin/perl/eg/van/empty | 45 + gnu/usr.bin/perl/eg/van/unvanish | 66 + gnu/usr.bin/perl/eg/van/vanexp | 21 + gnu/usr.bin/perl/eg/van/vanish | 65 + gnu/usr.bin/perl/eg/who | 13 + gnu/usr.bin/perl/emacs/perl-mode.el | 631 ++++ gnu/usr.bin/perl/emacs/perldb.el | 423 +++ gnu/usr.bin/perl/emacs/perldb.pl | 568 +++ gnu/usr.bin/perl/emacs/tedstuff | 296 ++ gnu/usr.bin/perl/h2pl/README | 71 + gnu/usr.bin/perl/h2pl/cbreak.pl | 34 + gnu/usr.bin/perl/h2pl/cbreak2.pl | 33 + gnu/usr.bin/perl/h2pl/eg/sizeof.ph | 14 + gnu/usr.bin/perl/h2pl/eg/sys/errno.pl | 92 + gnu/usr.bin/perl/h2pl/eg/sys/ioctl.pl | 186 + gnu/usr.bin/perl/h2pl/eg/sysexits.pl | 16 + gnu/usr.bin/perl/h2pl/getioctlsizes | 13 + gnu/usr.bin/perl/h2pl/mksizes | 42 + gnu/usr.bin/perl/h2pl/mkvars | 31 + gnu/usr.bin/perl/h2pl/tcbreak | 17 + gnu/usr.bin/perl/h2pl/tcbreak2 | 17 + gnu/usr.bin/perl/lib/Makefile | 19 + gnu/usr.bin/perl/lib/abbrev.pl | 33 + gnu/usr.bin/perl/lib/assert.pl | 52 + gnu/usr.bin/perl/lib/bigfloat.pl | 233 ++ gnu/usr.bin/perl/lib/bigint.pl | 271 ++ gnu/usr.bin/perl/lib/bigrat.pl | 148 + gnu/usr.bin/perl/lib/cacheout.pl | 40 + gnu/usr.bin/perl/lib/chat2.pl | 339 ++ gnu/usr.bin/perl/lib/complete.pl | 110 + gnu/usr.bin/perl/lib/ctime.pl | 51 + gnu/usr.bin/perl/lib/dumpvar.pl | 37 + gnu/usr.bin/perl/lib/exceptions.pl | 54 + gnu/usr.bin/perl/lib/fastcwd.pl | 35 + gnu/usr.bin/perl/lib/find.pl | 106 + gnu/usr.bin/perl/lib/finddepth.pl | 105 + gnu/usr.bin/perl/lib/flush.pl | 23 + gnu/usr.bin/perl/lib/getcwd.pl | 62 + gnu/usr.bin/perl/lib/getopt.pl | 41 + gnu/usr.bin/perl/lib/getopts.pl | 50 + gnu/usr.bin/perl/lib/importenv.pl | 16 + gnu/usr.bin/perl/lib/look.pl | 44 + gnu/usr.bin/perl/lib/newgetopt.pl | 271 ++ gnu/usr.bin/perl/lib/open2.pl | 54 + gnu/usr.bin/perl/lib/perldb.pl | 598 +++ gnu/usr.bin/perl/lib/pwd.pl | 72 + gnu/usr.bin/perl/lib/shellwords.pl | 48 + gnu/usr.bin/perl/lib/stat.pl | 31 + gnu/usr.bin/perl/lib/syslog.pl | 224 ++ gnu/usr.bin/perl/lib/termcap.pl | 165 + gnu/usr.bin/perl/lib/timelocal.pl | 82 + gnu/usr.bin/perl/lib/validate.pl | 104 + gnu/usr.bin/perl/misc/c2ph | 1071 ++++++ gnu/usr.bin/perl/misc/c2ph.1 | 191 + gnu/usr.bin/perl/misc/pstruct | 1071 ++++++ gnu/usr.bin/perl/perl/EXTERN.h | 26 + gnu/usr.bin/perl/perl/INTERN.h | 26 + gnu/usr.bin/perl/perl/Makefile | 20 + gnu/usr.bin/perl/perl/arg.h | 994 +++++ gnu/usr.bin/perl/perl/array.c | 287 ++ gnu/usr.bin/perl/perl/array.h | 45 + gnu/usr.bin/perl/perl/cflags | 91 + gnu/usr.bin/perl/perl/cmd.c | 1263 +++++++ gnu/usr.bin/perl/perl/cmd.h | 179 + gnu/usr.bin/perl/perl/config.H | 892 +++++ gnu/usr.bin/perl/perl/config.h | 892 +++++ gnu/usr.bin/perl/perl/config.sh | 268 ++ gnu/usr.bin/perl/perl/cons.c | 1450 +++++++ gnu/usr.bin/perl/perl/consarg.c | 1292 +++++++ gnu/usr.bin/perl/perl/crypt.c | 200 + gnu/usr.bin/perl/perl/doarg.c | 1849 +++++++++ gnu/usr.bin/perl/perl/doio.c | 2951 +++++++++++++++ gnu/usr.bin/perl/perl/dolist.c | 1973 ++++++++++ gnu/usr.bin/perl/perl/dump.c | 372 ++ gnu/usr.bin/perl/perl/eval.c | 3013 +++++++++++++++ gnu/usr.bin/perl/perl/form.c | 419 +++ gnu/usr.bin/perl/perl/form.h | 48 + gnu/usr.bin/perl/perl/handy.h | 150 + gnu/usr.bin/perl/perl/hash.c | 715 ++++ gnu/usr.bin/perl/perl/hash.h | 75 + gnu/usr.bin/perl/perl/malloc.c | 510 +++ gnu/usr.bin/perl/perl/patchlevel.h | 1 + gnu/usr.bin/perl/perl/perl.1 | 6010 ++++++++++++++++++++++++++++++ gnu/usr.bin/perl/perl/perl.c | 1449 +++++++ gnu/usr.bin/perl/perl/perl.h | 1063 ++++++ gnu/usr.bin/perl/perl/perly.c | 3063 +++++++++++++++ gnu/usr.bin/perl/perl/perly.h | 83 + gnu/usr.bin/perl/perl/regcomp.c | 1478 ++++++++ gnu/usr.bin/perl/perl/regcomp.h | 200 + gnu/usr.bin/perl/perl/regexec.c | 910 +++++ gnu/usr.bin/perl/perl/regexp.h | 53 + gnu/usr.bin/perl/perl/spat.h | 46 + gnu/usr.bin/perl/perl/stab.c | 1055 ++++++ gnu/usr.bin/perl/perl/stab.h | 145 + gnu/usr.bin/perl/perl/str.c | 1599 ++++++++ gnu/usr.bin/perl/perl/str.h | 171 + gnu/usr.bin/perl/perl/t/README | 11 + gnu/usr.bin/perl/perl/t/TEST | 102 + gnu/usr.bin/perl/perl/t/base/cond.t | 19 + gnu/usr.bin/perl/perl/t/base/if.t | 11 + gnu/usr.bin/perl/perl/t/base/lex.t | 78 + gnu/usr.bin/perl/perl/t/base/pat.t | 11 + gnu/usr.bin/perl/perl/t/base/term.t | 42 + gnu/usr.bin/perl/perl/t/cmd/elsif.t | 25 + gnu/usr.bin/perl/perl/t/cmd/for.t | 49 + gnu/usr.bin/perl/perl/t/cmd/mod.t | 33 + gnu/usr.bin/perl/perl/t/cmd/subval.t | 179 + gnu/usr.bin/perl/perl/t/cmd/switch.t | 75 + gnu/usr.bin/perl/perl/t/cmd/while.t | 110 + gnu/usr.bin/perl/perl/t/comp/cmdopt.t | 83 + gnu/usr.bin/perl/perl/t/comp/cpp.t | 51 + gnu/usr.bin/perl/perl/t/comp/decl.t | 49 + gnu/usr.bin/perl/perl/t/comp/multiline.t | 40 + gnu/usr.bin/perl/perl/t/comp/package.t | 33 + gnu/usr.bin/perl/perl/t/comp/script.t | 23 + gnu/usr.bin/perl/perl/t/comp/term.t | 35 + gnu/usr.bin/perl/perl/t/io/argv.t | 36 + gnu/usr.bin/perl/perl/t/io/dup.t | 32 + gnu/usr.bin/perl/perl/t/io/fs.t | 85 + gnu/usr.bin/perl/perl/t/io/inplace.t | 21 + gnu/usr.bin/perl/perl/t/io/pipe.t | 56 + gnu/usr.bin/perl/perl/t/io/print.t | 32 + gnu/usr.bin/perl/perl/t/io/tell.t | 44 + gnu/usr.bin/perl/perl/t/lib/big.t | 280 ++ gnu/usr.bin/perl/perl/t/op/Op.dbmx.db | Bin 0 -> 16384 bytes gnu/usr.bin/perl/perl/t/op/append.t | 21 + gnu/usr.bin/perl/perl/t/op/array.t | 120 + gnu/usr.bin/perl/perl/t/op/auto.t | 48 + gnu/usr.bin/perl/perl/t/op/chop.t | 30 + gnu/usr.bin/perl/perl/t/op/cond.t | 12 + gnu/usr.bin/perl/perl/t/op/dbm.t | 106 + gnu/usr.bin/perl/perl/t/op/delete.t | 29 + gnu/usr.bin/perl/perl/t/op/do.t | 44 + gnu/usr.bin/perl/perl/t/op/each.t | 53 + gnu/usr.bin/perl/perl/t/op/eval.t | 57 + gnu/usr.bin/perl/perl/t/op/exec.t | 21 + gnu/usr.bin/perl/perl/t/op/exp.t | 27 + gnu/usr.bin/perl/perl/t/op/flip.t | 26 + gnu/usr.bin/perl/perl/t/op/fork.t | 16 + gnu/usr.bin/perl/perl/t/op/glob.t | 22 + gnu/usr.bin/perl/perl/t/op/goto.t | 33 + gnu/usr.bin/perl/perl/t/op/groups.t | 47 + gnu/usr.bin/perl/perl/t/op/index.t | 42 + gnu/usr.bin/perl/perl/t/op/int.t | 17 + gnu/usr.bin/perl/perl/t/op/join.t | 12 + gnu/usr.bin/perl/perl/t/op/list.t | 83 + gnu/usr.bin/perl/perl/t/op/local.t | 45 + gnu/usr.bin/perl/perl/t/op/magic.t | 32 + gnu/usr.bin/perl/perl/t/op/mkdir.t | 15 + gnu/usr.bin/perl/perl/t/op/oct.t | 9 + gnu/usr.bin/perl/perl/t/op/ord.t | 14 + gnu/usr.bin/perl/perl/t/op/pack.t | 20 + gnu/usr.bin/perl/perl/t/op/pat.t | 184 + gnu/usr.bin/perl/perl/t/op/push.t | 44 + gnu/usr.bin/perl/perl/t/op/range.t | 36 + gnu/usr.bin/perl/perl/t/op/re_tests | 274 ++ gnu/usr.bin/perl/perl/t/op/read.t | 20 + gnu/usr.bin/perl/perl/t/op/readdir.t | 20 + gnu/usr.bin/perl/perl/t/op/regexp.t | 35 + gnu/usr.bin/perl/perl/t/op/repeat.t | 42 + gnu/usr.bin/perl/perl/t/op/s.t | 179 + gnu/usr.bin/perl/perl/t/op/sleep.t | 8 + gnu/usr.bin/perl/perl/t/op/sort.t | 48 + gnu/usr.bin/perl/perl/t/op/split.t | 57 + gnu/usr.bin/perl/perl/t/op/sprintf.t | 8 + gnu/usr.bin/perl/perl/t/op/stat.t | 176 + gnu/usr.bin/perl/perl/t/op/study.t | 69 + gnu/usr.bin/perl/perl/t/op/substr.t | 47 + gnu/usr.bin/perl/perl/t/op/time.t | 43 + gnu/usr.bin/perl/perl/t/op/undef.t | 56 + gnu/usr.bin/perl/perl/t/op/unshift.t | 14 + gnu/usr.bin/perl/perl/t/op/vec.t | 24 + gnu/usr.bin/perl/perl/t/op/write.t | 129 + gnu/usr.bin/perl/perl/t/printme | 6 + gnu/usr.bin/perl/perl/tdoio.c | 2948 +++++++++++++++ gnu/usr.bin/perl/perl/toke.c | 2764 ++++++++++++++ gnu/usr.bin/perl/perl/usersub.c | 148 + gnu/usr.bin/perl/perl/usub/Makefile | 16 + gnu/usr.bin/perl/perl/usub/README | 114 + gnu/usr.bin/perl/perl/usub/bsdcurses.mus | 699 ++++ gnu/usr.bin/perl/perl/usub/curses.mus | 890 +++++ gnu/usr.bin/perl/perl/usub/man2mus | 66 + gnu/usr.bin/perl/perl/usub/mus | 135 + gnu/usr.bin/perl/perl/usub/pager | 190 + gnu/usr.bin/perl/perl/usub/usersub.c | 75 + gnu/usr.bin/perl/perl/util.c | 1780 +++++++++ gnu/usr.bin/perl/perl/util.h | 61 + gnu/usr.bin/perl/sperl/Makefile | 30 + gnu/usr.bin/perl/tperl/Makefile | 30 + gnu/usr.bin/perl/x2p/EXTERN.h | 26 + gnu/usr.bin/perl/x2p/INTERN.h | 26 + gnu/usr.bin/perl/x2p/Makefile | 17 + gnu/usr.bin/perl/x2p/a2p.1 | 199 + gnu/usr.bin/perl/x2p/a2p.c | 2715 ++++++++++++++ gnu/usr.bin/perl/x2p/a2p.h | 341 ++ gnu/usr.bin/perl/x2p/a2p.y | 406 ++ gnu/usr.bin/perl/x2p/a2py.c | 1301 +++++++ gnu/usr.bin/perl/x2p/find2perl | 568 +++ gnu/usr.bin/perl/x2p/h2ph | 253 ++ gnu/usr.bin/perl/x2p/h2ph.1 | 253 ++ gnu/usr.bin/perl/x2p/handy.h | 46 + gnu/usr.bin/perl/x2p/hash.c | 250 ++ gnu/usr.bin/perl/x2p/hash.h | 60 + gnu/usr.bin/perl/x2p/malloc.c | 513 +++ gnu/usr.bin/perl/x2p/s2p | 766 ++++ gnu/usr.bin/perl/x2p/s2p.1 | 108 + gnu/usr.bin/perl/x2p/str.c | 467 +++ gnu/usr.bin/perl/x2p/str.h | 46 + gnu/usr.bin/perl/x2p/util.c | 268 ++ gnu/usr.bin/perl/x2p/util.h | 53 + gnu/usr.bin/perl/x2p/walk.c | 2086 +++++++++++ 255 files changed, 73260 insertions(+) create mode 100644 gnu/usr.bin/perl/Artistic create mode 100644 gnu/usr.bin/perl/Copying create mode 100644 gnu/usr.bin/perl/Makefile create mode 100644 gnu/usr.bin/perl/Makefile.inc create mode 100644 gnu/usr.bin/perl/README create mode 100644 gnu/usr.bin/perl/VERSION create mode 100644 gnu/usr.bin/perl/Wishlist create mode 100644 gnu/usr.bin/perl/eg/ADB create mode 100644 gnu/usr.bin/perl/eg/README create mode 100644 gnu/usr.bin/perl/eg/changes create mode 100644 gnu/usr.bin/perl/eg/client create mode 100644 gnu/usr.bin/perl/eg/down create mode 100644 gnu/usr.bin/perl/eg/dus create mode 100644 gnu/usr.bin/perl/eg/findcp create mode 100644 gnu/usr.bin/perl/eg/findtar create mode 100644 gnu/usr.bin/perl/eg/g/gcp create mode 100644 gnu/usr.bin/perl/eg/g/gcp.man create mode 100644 gnu/usr.bin/perl/eg/g/ged create mode 100644 gnu/usr.bin/perl/eg/g/ghosts create mode 100644 gnu/usr.bin/perl/eg/g/gsh create mode 100644 gnu/usr.bin/perl/eg/g/gsh.man create mode 100644 gnu/usr.bin/perl/eg/muck create mode 100644 gnu/usr.bin/perl/eg/muck.man create mode 100644 gnu/usr.bin/perl/eg/myrup create mode 100644 gnu/usr.bin/perl/eg/nih create mode 100644 gnu/usr.bin/perl/eg/perlsh create mode 100644 gnu/usr.bin/perl/eg/relink create mode 100644 gnu/usr.bin/perl/eg/rename create mode 100644 gnu/usr.bin/perl/eg/rmfrom create mode 100644 gnu/usr.bin/perl/eg/scan/scan_df create mode 100644 gnu/usr.bin/perl/eg/scan/scan_last create mode 100644 gnu/usr.bin/perl/eg/scan/scan_messages create mode 100644 gnu/usr.bin/perl/eg/scan/scan_passwd create mode 100644 gnu/usr.bin/perl/eg/scan/scan_ps create mode 100644 gnu/usr.bin/perl/eg/scan/scan_sudo create mode 100644 gnu/usr.bin/perl/eg/scan/scan_suid create mode 100644 gnu/usr.bin/perl/eg/scan/scanner create mode 100644 gnu/usr.bin/perl/eg/server create mode 100644 gnu/usr.bin/perl/eg/shmkill create mode 100644 gnu/usr.bin/perl/eg/sysvipc/README create mode 100644 gnu/usr.bin/perl/eg/sysvipc/ipcmsg create mode 100644 gnu/usr.bin/perl/eg/sysvipc/ipcsem create mode 100644 gnu/usr.bin/perl/eg/sysvipc/ipcshm create mode 100644 gnu/usr.bin/perl/eg/travesty create mode 100644 gnu/usr.bin/perl/eg/van/empty create mode 100644 gnu/usr.bin/perl/eg/van/unvanish create mode 100644 gnu/usr.bin/perl/eg/van/vanexp create mode 100644 gnu/usr.bin/perl/eg/van/vanish create mode 100644 gnu/usr.bin/perl/eg/who create mode 100644 gnu/usr.bin/perl/emacs/perl-mode.el create mode 100644 gnu/usr.bin/perl/emacs/perldb.el create mode 100644 gnu/usr.bin/perl/emacs/perldb.pl create mode 100644 gnu/usr.bin/perl/emacs/tedstuff create mode 100644 gnu/usr.bin/perl/h2pl/README create mode 100644 gnu/usr.bin/perl/h2pl/cbreak.pl create mode 100644 gnu/usr.bin/perl/h2pl/cbreak2.pl create mode 100644 gnu/usr.bin/perl/h2pl/eg/sizeof.ph create mode 100644 gnu/usr.bin/perl/h2pl/eg/sys/errno.pl create mode 100644 gnu/usr.bin/perl/h2pl/eg/sys/ioctl.pl create mode 100644 gnu/usr.bin/perl/h2pl/eg/sysexits.pl create mode 100644 gnu/usr.bin/perl/h2pl/getioctlsizes create mode 100644 gnu/usr.bin/perl/h2pl/mksizes create mode 100644 gnu/usr.bin/perl/h2pl/mkvars create mode 100644 gnu/usr.bin/perl/h2pl/tcbreak create mode 100644 gnu/usr.bin/perl/h2pl/tcbreak2 create mode 100644 gnu/usr.bin/perl/lib/Makefile create mode 100644 gnu/usr.bin/perl/lib/abbrev.pl create mode 100644 gnu/usr.bin/perl/lib/assert.pl create mode 100644 gnu/usr.bin/perl/lib/bigfloat.pl create mode 100644 gnu/usr.bin/perl/lib/bigint.pl create mode 100644 gnu/usr.bin/perl/lib/bigrat.pl create mode 100644 gnu/usr.bin/perl/lib/cacheout.pl create mode 100644 gnu/usr.bin/perl/lib/chat2.pl create mode 100644 gnu/usr.bin/perl/lib/complete.pl create mode 100644 gnu/usr.bin/perl/lib/ctime.pl create mode 100644 gnu/usr.bin/perl/lib/dumpvar.pl create mode 100644 gnu/usr.bin/perl/lib/exceptions.pl create mode 100644 gnu/usr.bin/perl/lib/fastcwd.pl create mode 100644 gnu/usr.bin/perl/lib/find.pl create mode 100644 gnu/usr.bin/perl/lib/finddepth.pl create mode 100644 gnu/usr.bin/perl/lib/flush.pl create mode 100644 gnu/usr.bin/perl/lib/getcwd.pl create mode 100644 gnu/usr.bin/perl/lib/getopt.pl create mode 100644 gnu/usr.bin/perl/lib/getopts.pl create mode 100644 gnu/usr.bin/perl/lib/importenv.pl create mode 100644 gnu/usr.bin/perl/lib/look.pl create mode 100644 gnu/usr.bin/perl/lib/newgetopt.pl create mode 100644 gnu/usr.bin/perl/lib/open2.pl create mode 100644 gnu/usr.bin/perl/lib/perldb.pl create mode 100644 gnu/usr.bin/perl/lib/pwd.pl create mode 100644 gnu/usr.bin/perl/lib/shellwords.pl create mode 100644 gnu/usr.bin/perl/lib/stat.pl create mode 100644 gnu/usr.bin/perl/lib/syslog.pl create mode 100644 gnu/usr.bin/perl/lib/termcap.pl create mode 100644 gnu/usr.bin/perl/lib/timelocal.pl create mode 100644 gnu/usr.bin/perl/lib/validate.pl create mode 100644 gnu/usr.bin/perl/misc/c2ph create mode 100644 gnu/usr.bin/perl/misc/c2ph.1 create mode 100644 gnu/usr.bin/perl/misc/pstruct create mode 100644 gnu/usr.bin/perl/perl/EXTERN.h create mode 100644 gnu/usr.bin/perl/perl/INTERN.h create mode 100644 gnu/usr.bin/perl/perl/Makefile create mode 100644 gnu/usr.bin/perl/perl/arg.h create mode 100644 gnu/usr.bin/perl/perl/array.c create mode 100644 gnu/usr.bin/perl/perl/array.h create mode 100755 gnu/usr.bin/perl/perl/cflags create mode 100644 gnu/usr.bin/perl/perl/cmd.c create mode 100644 gnu/usr.bin/perl/perl/cmd.h create mode 100644 gnu/usr.bin/perl/perl/config.H create mode 100644 gnu/usr.bin/perl/perl/config.h create mode 100644 gnu/usr.bin/perl/perl/config.sh create mode 100644 gnu/usr.bin/perl/perl/cons.c create mode 100644 gnu/usr.bin/perl/perl/consarg.c create mode 100644 gnu/usr.bin/perl/perl/crypt.c create mode 100644 gnu/usr.bin/perl/perl/doarg.c create mode 100644 gnu/usr.bin/perl/perl/doio.c create mode 100644 gnu/usr.bin/perl/perl/dolist.c create mode 100644 gnu/usr.bin/perl/perl/dump.c create mode 100644 gnu/usr.bin/perl/perl/eval.c create mode 100644 gnu/usr.bin/perl/perl/form.c create mode 100644 gnu/usr.bin/perl/perl/form.h create mode 100644 gnu/usr.bin/perl/perl/handy.h create mode 100644 gnu/usr.bin/perl/perl/hash.c create mode 100644 gnu/usr.bin/perl/perl/hash.h create mode 100644 gnu/usr.bin/perl/perl/malloc.c create mode 100644 gnu/usr.bin/perl/perl/patchlevel.h create mode 100644 gnu/usr.bin/perl/perl/perl.1 create mode 100644 gnu/usr.bin/perl/perl/perl.c create mode 100644 gnu/usr.bin/perl/perl/perl.h create mode 100644 gnu/usr.bin/perl/perl/perly.c create mode 100644 gnu/usr.bin/perl/perl/perly.h create mode 100644 gnu/usr.bin/perl/perl/regcomp.c create mode 100644 gnu/usr.bin/perl/perl/regcomp.h create mode 100644 gnu/usr.bin/perl/perl/regexec.c create mode 100644 gnu/usr.bin/perl/perl/regexp.h create mode 100644 gnu/usr.bin/perl/perl/spat.h create mode 100644 gnu/usr.bin/perl/perl/stab.c create mode 100644 gnu/usr.bin/perl/perl/stab.h create mode 100644 gnu/usr.bin/perl/perl/str.c create mode 100644 gnu/usr.bin/perl/perl/str.h create mode 100644 gnu/usr.bin/perl/perl/t/README create mode 100755 gnu/usr.bin/perl/perl/t/TEST create mode 100755 gnu/usr.bin/perl/perl/t/base/cond.t create mode 100755 gnu/usr.bin/perl/perl/t/base/if.t create mode 100755 gnu/usr.bin/perl/perl/t/base/lex.t create mode 100755 gnu/usr.bin/perl/perl/t/base/pat.t create mode 100755 gnu/usr.bin/perl/perl/t/base/term.t create mode 100755 gnu/usr.bin/perl/perl/t/cmd/elsif.t create mode 100755 gnu/usr.bin/perl/perl/t/cmd/for.t create mode 100755 gnu/usr.bin/perl/perl/t/cmd/mod.t create mode 100755 gnu/usr.bin/perl/perl/t/cmd/subval.t create mode 100755 gnu/usr.bin/perl/perl/t/cmd/switch.t create mode 100755 gnu/usr.bin/perl/perl/t/cmd/while.t create mode 100755 gnu/usr.bin/perl/perl/t/comp/cmdopt.t create mode 100755 gnu/usr.bin/perl/perl/t/comp/cpp.t create mode 100755 gnu/usr.bin/perl/perl/t/comp/decl.t create mode 100755 gnu/usr.bin/perl/perl/t/comp/multiline.t create mode 100755 gnu/usr.bin/perl/perl/t/comp/package.t create mode 100755 gnu/usr.bin/perl/perl/t/comp/script.t create mode 100755 gnu/usr.bin/perl/perl/t/comp/term.t create mode 100755 gnu/usr.bin/perl/perl/t/io/argv.t create mode 100755 gnu/usr.bin/perl/perl/t/io/dup.t create mode 100755 gnu/usr.bin/perl/perl/t/io/fs.t create mode 100755 gnu/usr.bin/perl/perl/t/io/inplace.t create mode 100755 gnu/usr.bin/perl/perl/t/io/pipe.t create mode 100755 gnu/usr.bin/perl/perl/t/io/print.t create mode 100755 gnu/usr.bin/perl/perl/t/io/tell.t create mode 100755 gnu/usr.bin/perl/perl/t/lib/big.t create mode 100644 gnu/usr.bin/perl/perl/t/op/Op.dbmx.db create mode 100755 gnu/usr.bin/perl/perl/t/op/append.t create mode 100755 gnu/usr.bin/perl/perl/t/op/array.t create mode 100755 gnu/usr.bin/perl/perl/t/op/auto.t create mode 100755 gnu/usr.bin/perl/perl/t/op/chop.t create mode 100755 gnu/usr.bin/perl/perl/t/op/cond.t create mode 100755 gnu/usr.bin/perl/perl/t/op/dbm.t create mode 100755 gnu/usr.bin/perl/perl/t/op/delete.t create mode 100755 gnu/usr.bin/perl/perl/t/op/do.t create mode 100755 gnu/usr.bin/perl/perl/t/op/each.t create mode 100755 gnu/usr.bin/perl/perl/t/op/eval.t create mode 100755 gnu/usr.bin/perl/perl/t/op/exec.t create mode 100755 gnu/usr.bin/perl/perl/t/op/exp.t create mode 100755 gnu/usr.bin/perl/perl/t/op/flip.t create mode 100755 gnu/usr.bin/perl/perl/t/op/fork.t create mode 100755 gnu/usr.bin/perl/perl/t/op/glob.t create mode 100755 gnu/usr.bin/perl/perl/t/op/goto.t create mode 100755 gnu/usr.bin/perl/perl/t/op/groups.t create mode 100755 gnu/usr.bin/perl/perl/t/op/index.t create mode 100755 gnu/usr.bin/perl/perl/t/op/int.t create mode 100755 gnu/usr.bin/perl/perl/t/op/join.t create mode 100755 gnu/usr.bin/perl/perl/t/op/list.t create mode 100755 gnu/usr.bin/perl/perl/t/op/local.t create mode 100755 gnu/usr.bin/perl/perl/t/op/magic.t create mode 100755 gnu/usr.bin/perl/perl/t/op/mkdir.t create mode 100755 gnu/usr.bin/perl/perl/t/op/oct.t create mode 100755 gnu/usr.bin/perl/perl/t/op/ord.t create mode 100755 gnu/usr.bin/perl/perl/t/op/pack.t create mode 100755 gnu/usr.bin/perl/perl/t/op/pat.t create mode 100755 gnu/usr.bin/perl/perl/t/op/push.t create mode 100755 gnu/usr.bin/perl/perl/t/op/range.t create mode 100644 gnu/usr.bin/perl/perl/t/op/re_tests create mode 100755 gnu/usr.bin/perl/perl/t/op/read.t create mode 100755 gnu/usr.bin/perl/perl/t/op/readdir.t create mode 100755 gnu/usr.bin/perl/perl/t/op/regexp.t create mode 100755 gnu/usr.bin/perl/perl/t/op/repeat.t create mode 100755 gnu/usr.bin/perl/perl/t/op/s.t create mode 100755 gnu/usr.bin/perl/perl/t/op/sleep.t create mode 100755 gnu/usr.bin/perl/perl/t/op/sort.t create mode 100755 gnu/usr.bin/perl/perl/t/op/split.t create mode 100755 gnu/usr.bin/perl/perl/t/op/sprintf.t create mode 100755 gnu/usr.bin/perl/perl/t/op/stat.t create mode 100755 gnu/usr.bin/perl/perl/t/op/study.t create mode 100755 gnu/usr.bin/perl/perl/t/op/substr.t create mode 100755 gnu/usr.bin/perl/perl/t/op/time.t create mode 100755 gnu/usr.bin/perl/perl/t/op/undef.t create mode 100755 gnu/usr.bin/perl/perl/t/op/unshift.t create mode 100755 gnu/usr.bin/perl/perl/t/op/vec.t create mode 100755 gnu/usr.bin/perl/perl/t/op/write.t create mode 100644 gnu/usr.bin/perl/perl/t/printme create mode 100644 gnu/usr.bin/perl/perl/tdoio.c create mode 100644 gnu/usr.bin/perl/perl/toke.c create mode 100644 gnu/usr.bin/perl/perl/usersub.c create mode 100644 gnu/usr.bin/perl/perl/usub/Makefile create mode 100644 gnu/usr.bin/perl/perl/usub/README create mode 100644 gnu/usr.bin/perl/perl/usub/bsdcurses.mus create mode 100644 gnu/usr.bin/perl/perl/usub/curses.mus create mode 100644 gnu/usr.bin/perl/perl/usub/man2mus create mode 100755 gnu/usr.bin/perl/perl/usub/mus create mode 100644 gnu/usr.bin/perl/perl/usub/pager create mode 100644 gnu/usr.bin/perl/perl/usub/usersub.c create mode 100644 gnu/usr.bin/perl/perl/util.c create mode 100644 gnu/usr.bin/perl/perl/util.h create mode 100644 gnu/usr.bin/perl/sperl/Makefile create mode 100644 gnu/usr.bin/perl/tperl/Makefile create mode 100644 gnu/usr.bin/perl/x2p/EXTERN.h create mode 100644 gnu/usr.bin/perl/x2p/INTERN.h create mode 100644 gnu/usr.bin/perl/x2p/Makefile create mode 100644 gnu/usr.bin/perl/x2p/a2p.1 create mode 100644 gnu/usr.bin/perl/x2p/a2p.c create mode 100644 gnu/usr.bin/perl/x2p/a2p.h create mode 100644 gnu/usr.bin/perl/x2p/a2p.y create mode 100644 gnu/usr.bin/perl/x2p/a2py.c create mode 100755 gnu/usr.bin/perl/x2p/find2perl create mode 100755 gnu/usr.bin/perl/x2p/h2ph create mode 100755 gnu/usr.bin/perl/x2p/h2ph.1 create mode 100644 gnu/usr.bin/perl/x2p/handy.h create mode 100644 gnu/usr.bin/perl/x2p/hash.c create mode 100644 gnu/usr.bin/perl/x2p/hash.h create mode 100644 gnu/usr.bin/perl/x2p/malloc.c create mode 100755 gnu/usr.bin/perl/x2p/s2p create mode 100644 gnu/usr.bin/perl/x2p/s2p.1 create mode 100644 gnu/usr.bin/perl/x2p/str.c create mode 100644 gnu/usr.bin/perl/x2p/str.h create mode 100644 gnu/usr.bin/perl/x2p/util.c create mode 100644 gnu/usr.bin/perl/x2p/util.h create mode 100644 gnu/usr.bin/perl/x2p/walk.c (limited to 'gnu/usr.bin') diff --git a/gnu/usr.bin/perl/Artistic b/gnu/usr.bin/perl/Artistic new file mode 100644 index 0000000..fbf7989 --- /dev/null +++ b/gnu/usr.bin/perl/Artistic @@ -0,0 +1,117 @@ + + + + + The "Artistic License" + + Preamble + +The intent of this document is to state the conditions under which a +Package may be copied, such that the Copyright Holder maintains some +semblance of artistic control over the development of the package, +while giving the users of the package the right to use and distribute +the Package in a more-or-less customary fashion, plus the right to make +reasonable modifications. + +Definitions: + + "Package" refers to the collection of files distributed by the + Copyright Holder, and derivatives of that collection of files + created through textual modification. + + "Standard Version" refers to such a Package if it has not been + modified, or has been modified in accordance with the wishes + of the Copyright Holder. + + "Copyright Holder" is whoever is named in the copyright or + copyrights for the package. + + "You" is you, if you're thinking about copying or distributing + this Package. + + "Reasonable copying fee" is whatever you can justify on the + basis of media cost, duplication charges, time of people involved, + and so on. (You will not be required to justify it to the + Copyright Holder, but only to the computing community at large + as a market that must bear the fee.) + + "Freely Available" means that no fee is charged for the item + itself, though there may be fees involved in handling the item. + It also means that recipients of the item may redistribute it + under the same conditions they received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications +derived from the Public Domain or from the Copyright Holder. A Package +modified in such a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided +that you insert a prominent notice in each changed file stating how and +when you changed that file, and provided that you do at least ONE of the +following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or + an equivalent medium, or placing the modifications on a major archive + site such as uunet.uu.net, or by allowing the Copyright Holder to include + your modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and provide + a separate manual page for each non-standard executable that clearly + documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or +executable form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where + to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) accompany any non-standard executables with their corresponding + Standard Version executables, giving the non-standard executables + non-standard names, and clearly documenting the differences in manual + pages (or equivalent), together with instructions on where to get + the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this Package. +You may not charge a fee for this Package itself. However, +you may distribute this Package in aggregate with other (possibly +commercial) programs as part of a larger (possibly commercial) software +distribution provided that you do not advertise this Package as a +product of your own. + +6. The scripts and library files supplied as input to or produced as +output from the programs of this Package do not automatically fall +under the copyright of this Package, but belong to whomever generated +them, and may be sold commercially, and may be aggregated with this +Package. + +7. C subroutines supplied by you and linked into this Package in order +to emulate subroutines and variables of the language defined by this +Package shall not be considered part of this Package, but are the +equivalent of input as in Paragraph 6, provided these subroutines do +not change the language in any way that would cause it to fail the +regression tests for the language. + +8. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + + The End diff --git a/gnu/usr.bin/perl/Copying b/gnu/usr.bin/perl/Copying new file mode 100644 index 0000000..3c68f02 --- /dev/null +++ b/gnu/usr.bin/perl/Copying @@ -0,0 +1,248 @@ + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/gnu/usr.bin/perl/Makefile b/gnu/usr.bin/perl/Makefile new file mode 100644 index 0000000..3ef6485 --- /dev/null +++ b/gnu/usr.bin/perl/Makefile @@ -0,0 +1,10 @@ +# +# Bmake file for perl 4.036 +# +# Note: I'm not sure what to do with c2ph located in misc... +# + +SUBDIR= perl tperl sperl lib x2p + +.include + diff --git a/gnu/usr.bin/perl/Makefile.inc b/gnu/usr.bin/perl/Makefile.inc new file mode 100644 index 0000000..c2f9b44 --- /dev/null +++ b/gnu/usr.bin/perl/Makefile.inc @@ -0,0 +1,5 @@ + + +BINDIR?= /usr/local/bin +MANDIR?= /usr/local/man/man + diff --git a/gnu/usr.bin/perl/README b/gnu/usr.bin/perl/README new file mode 100644 index 0000000..c52c7f4 --- /dev/null +++ b/gnu/usr.bin/perl/README @@ -0,0 +1,195 @@ + + Perl Kit, Version 4.0 + + Copyright (c) 1989,1990,1991, Larry Wall + All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this Kit. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either + the GNU General Public License or the Artistic License for more details. + + You should have received a copy of the Artistic License with this + Kit, in the file named "Artistic". If not, I'll be glad to provide one. + + You should also have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + For those of you that choose to use the GNU General Public License, + my interpretation of the GNU General Public License is that no Perl + script falls under the terms of the GPL unless you explicitly put + said script under the terms of the GPL yourself. Furthermore, any + object code linked with uperl.o does not automatically fall under the + terms of the GPL, provided such object code only adds definitions + of subroutines and variables, and does not otherwise impair the + resulting interpreter from executing any standard Perl script. I + consider linking in C subroutines in this manner to be the moral + equivalent of defining subroutines in the Perl language itself. You + may sell such an object file as proprietary provided that you provide + or offer to provide the Perl source, as specified by the GNU General + Public License. (This is merely an alternate way of specifying input + to the program.) You may also sell a binary produced by the dumping of + a running Perl script that belongs to you, provided that you provide or + offer to provide the Perl source as specified by the GPL. (The + fact that a Perl interpreter and your code are in the same binary file + is, in this case, a form of mere aggregation.) This is my interpretation + of the GPL. If you still have concerns or difficulties understanding + my intent, feel free to contact me. Of course, the Artistic License + spells all this out for your protection, so you may prefer to use that. + +-------------------------------------------------------------------------- + +Perl is a language that combines some of the features of C, sed, awk and shell. +See the manual page for more hype. There's also a Nutshell Handbook published +by O'Reilly & Assoc. Their U.S. number is 1-800-338-6887 (dev-nuts) and +their international number is 1-707-829-0515. E-mail to nuts@ora.com. + +Perl will probably not run on machines with a small address space. + +Please read all the directions below before you proceed any further, and +then follow them carefully. + +After you have unpacked your kit, you should have all the files listed +in MANIFEST. + +Installation + +1) Run Configure. This will figure out various things about your system. + Some things Configure will figure out for itself, other things it will + ask you about. It will then proceed to make config.h, config.sh, and + Makefile. If you're a hotshot, run Configure -d to take all the + defaults and then edit config.sh to patch up any flaws. + + You might possibly have to trim # comments from the front of Configure + if your sh doesn't handle them, but all other # comments will be taken + care of. + + (If you don't have sh, you'll have to copy the sample file config.H to + config.h and edit the config.h to reflect your system's peculiarities.) + +2) Glance through config.h to make sure system dependencies are correct. + Most of them should have been taken care of by running the Configure script. + + If you have any additional changes to make to the C definitions, they + can be done in cflags.SH. For instance, to turn off the optimizer + on eval.c, find the line in the switch structure for eval.c and + put the command $optimize='-g' before the ;;. You will probably + want to change the entry for teval.c too. To change the C flags + for all the files, edit config.sh and change either $ccflags or $optimize. + +3) make depend + + This will look for all the includes and modify Makefile accordingly. + Configure will offer to do this for you. + +4) make + + This will attempt to make perl in the current directory. + + If you can't compile successfully, try adding a -DCRIPPLED_CC flag. + (Just because you get no errors doesn't mean it compiled right!) + This simplifies some complicated expressions for compilers that + get indigestion easily. If that has no effect, try turning off + optimization. If you have missing routines, you probably need to + add some library or other, or you need to undefine some feature that + Configure thought was there but is defective or incomplete. + + Some compilers will not compile or optimize the larger files without + some extra switches to use larger jump offsets or allocate larger + internal tables. You can customize the switches for each file in + cflags.SH. It's okay to insert rules for specific files into + Makefile.SH, since a default rule only takes effect in the + absence of a specific rule. + + Most of the following hints are now done automatically by Configure. + + The 3b2 needs to turn off -O. + Compilers with limited switch tables may have to define -DSMALLSWITCHES + Domain/OS 10.3 (at least) native C 6.7 may need -opt 2 for eval.c + AIX/RT may need a -a switch and -DCRIPPLED_CC. + AIX RS/6000 needs to use system malloc and avoid -O on eval.c and toke.c. + AIX RS/6000 needs -D_NO_PROTO. + SUNOS 4.0.[12] needs -DFPUTS_BOTCH. + SUNOS 3.[45] should use the system malloc. + SGI machines may need -Ddouble="long float" and -O1. + Vax-based systems may need to hand assemble teval.s with a -J switch. + Ultrix on MIPS machines may need -DLANGUAGE_C. + Ultrix 4.0 on MIPS machines may need -Olimit 2900 or so. + Ultrix 3.[01] on MIPS needs to undefine WAITPID--the system call is busted. + MIPS machines need /bin before /bsd43/bin in PATH. + MIPS machines may need to undef d_volatile. + MIPS machines may need to turn off -O on cmd.c, perl.c and tperl.c. + Some MIPS machines may need to undefine CASTNEGFLOAT. + Xenix 386 needs -Sm11000 for yacc, and may need -UM_I86. + SCO Xenix may need -m25000 for yacc. See also README.xenix. + Genix needs to use libc rather than libc_s, or #undef VARARGS. + NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR. + A/UX may appears to work with -O -B/usr/lib/big/ optimizer flags. + A/UX needs -lposix to find rewinddir. + A/UX may need -ZP -DPOSIX, and -g if big cc is used. + FPS machines may need -J and -DBADSWITCH. + UTS may need one or more of -DCRIPPLED_CC, -K or -g, and undef LSTAT. + dynix may need to undefine CASTNEGFLOAT (d_castneg='undef' in config.sh). + Dnix (not dynix) may need to remove -O. + IRIX 3.3 may need to undefine VFORK. + HP/UX may need to pull cerror.o and syscall.o out of libc.a and link + them in explicitly. + If you get syntax errors on '(', try -DCRIPPLED_CC or -DBADSWITCH or both. + Machines with half-implemented dbm routines will need to #undef ODBM & NDBM. + 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 + + This will run the regression tests on the perl you just made. + If it doesn't say "All tests successful" then something went wrong. + See the README in the t subdirectory. Note that you can't run it + in background if this disables opening of /dev/tty. If "make test" + bombs out, just cd to the t directory and run TEST by hand to see if + it makes any difference. If individual tests bomb, you can run + them by hand, e.g., ./perl op/groups.t + +6) make install + + This will put perl into a public directory (such as /usr/local/bin). + It will also try to put the man pages in a reasonable place. It will not + nroff the man page, however. You may need to be root to do this. If + you are not root, you must own the directories in question and you should + ignore any messages about chown not working. + +7) Read the manual entry before running perl. + +8) IMPORTANT! Help save the world! Communicate any problems and suggested + patches to me, lwall@netlabs.com (Larry Wall), so we can + keep the world in sync. If you have a problem, there's someone else + out there who either has had or will have the same problem. + + If possible, send in patches such that the patch program will apply them. + Context diffs are the best, then normal diffs. Don't send ed scripts-- + I've probably changed my copy since the version you have. It's also + helpful if you send the output of "uname -a". + + Watch for perl patches in comp.lang.perl. Patches will generally be + in a form usable by the patch program. If you are just now bringing up + perl and aren't sure how many patches there are, write to me and I'll + send any you don't have. Your current patch level is shown in patchlevel.h. + + +Just a personal note: I want you to know that I create nice things like this +because it pleases the Author of my story. If this bothers you, then your +notion of Authorship needs some revision. But you can use perl anyway. :-) + + The author. diff --git a/gnu/usr.bin/perl/VERSION b/gnu/usr.bin/perl/VERSION new file mode 100644 index 0000000..2b80880 --- /dev/null +++ b/gnu/usr.bin/perl/VERSION @@ -0,0 +1 @@ +Perl 4.0 patchlevel 36 diff --git a/gnu/usr.bin/perl/Wishlist b/gnu/usr.bin/perl/Wishlist new file mode 100644 index 0000000..3290834 --- /dev/null +++ b/gnu/usr.bin/perl/Wishlist @@ -0,0 +1,9 @@ +built-in cpp +perl to C translator +multi-threading +make more easily embeddable +built-in globbing +compile to threaded code +rewrite regexp parser for better integrated optimization +add structured types and objects +allow for lexical scoping diff --git a/gnu/usr.bin/perl/eg/ADB b/gnu/usr.bin/perl/eg/ADB new file mode 100644 index 0000000..09b93c3 --- /dev/null +++ b/gnu/usr.bin/perl/eg/ADB @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/ADB,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ + +# This script is only useful when used in your crash directory. + +$num = shift; +exec 'adb', '-k', "vmunix.$num", "vmcore.$num"; diff --git a/gnu/usr.bin/perl/eg/README b/gnu/usr.bin/perl/eg/README new file mode 100644 index 0000000..87cfc33 --- /dev/null +++ b/gnu/usr.bin/perl/eg/README @@ -0,0 +1,22 @@ +Although supplied with the perl package, the perl scripts in this eg +directory and its subdirectories are placed in the public domain, and +you may do anything with them that you wish. + +This stuff is supplied on an as-is basis--little attempt has been made to make +any of it portable. It's mostly here to give you an idea of what perl code +looks like, and what tricks and idioms are used. + +System administrators responsible for many computers will enjoy the items +down in the g directory very much. The scan directory contains the beginnings +of a system to check on and report various kinds of anomalies. + +If you machine doesn't support #!, the first thing you'll want to do is +replace the #! with a couple of lines that look like this: + + eval "exec /usr/bin/perl -S $0 $*" + if $running_under_some_shell; + +being sure to include any flags that were on the #! line. A supplied script +called "nih" will translate perl scripts in place for you: + + nih g/g?? diff --git a/gnu/usr.bin/perl/eg/changes b/gnu/usr.bin/perl/eg/changes new file mode 100644 index 0000000..9835e1b --- /dev/null +++ b/gnu/usr.bin/perl/eg/changes @@ -0,0 +1,34 @@ +#!/usr/bin/perl -P + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/changes,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ + +($dir, $days) = @ARGV; +$dir = '/' if $dir eq ''; +$days = '14' if $days eq ''; + +# Masscomps do things differently from Suns + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Find, "find $dir -mtime -$days -print |") || + die "changes: can't run find"; +#else +open(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") || + die "changes: can't run find"; +#endif + +while () { + +#if defined(mc300) || defined(mc500) || defined(mc700) + $x = `/bin/ls -ild $_`; + $_ = $x; + ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split(' '); +#else + ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split(' '); +#endif + + printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n", + $perm,$links,$owner,$group,$size,$month,$day,$name); +} + diff --git a/gnu/usr.bin/perl/eg/client b/gnu/usr.bin/perl/eg/client new file mode 100644 index 0000000..5900c90 --- /dev/null +++ b/gnu/usr.bin/perl/eg/client @@ -0,0 +1,34 @@ +#!./perl + +$pat = 'S n C4 x8'; +$inet = 2; +$echo = 7; +$smtp = 25; +$nntp = 119; +$test = 2345; + +$SIG{'INT'} = 'dokill'; + +$this = pack($pat,$inet,0, 128,149,13,43); +$that = pack($pat,$inet,$test,127,0,0,1); + +if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } +if (bind(S,$this)) { print "bind ok\n"; } else { die $!; } +if (connect(S,$that)) { print "connect ok\n"; } else { die $!; } + +select(S); $| = 1; select(stdout); + +if ($child = fork) { + while () { + print S; + } + sleep 3; + do dokill(); +} +else { + while () { + print; + } +} + +sub dokill { kill 9,$child if $child; } diff --git a/gnu/usr.bin/perl/eg/down b/gnu/usr.bin/perl/eg/down new file mode 100644 index 0000000..bbb0d06 --- /dev/null +++ b/gnu/usr.bin/perl/eg/down @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +$| = 1; +if ($#ARGV >= 0) { + $cmd = join(' ',@ARGV); +} +else { + print "Command: "; + $cmd = ; + chop($cmd); + while ($cmd =~ s/\\$//) { + print "+ "; + $cmd .= ; + chop($cmd); + } +} +$cwd = `pwd`; chop($cwd); + +open(FIND,'find . -type d -print|') || die "Can't run find"; + +while () { + chop; + unless (chdir $_) { + print stderr "Can't cd to $_\n"; + next; + } + print "\t--> ",$_,"\n"; + system $cmd; + chdir $cwd; +} diff --git a/gnu/usr.bin/perl/eg/dus b/gnu/usr.bin/perl/eg/dus new file mode 100644 index 0000000..94c648b --- /dev/null +++ b/gnu/usr.bin/perl/eg/dus @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/dus,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ + +# This script does a du -s on any directories in the current directory that +# are not mount points for another filesystem. + +($mydev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('.'); + +open(ls,'ls -F1|'); + +while () { + chop; + next unless s|/$||; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($_); + next unless $dev == $mydev; + push(@ary,$_); +} + +exec 'du', '-s', @ary; diff --git a/gnu/usr.bin/perl/eg/findcp b/gnu/usr.bin/perl/eg/findcp new file mode 100644 index 0000000..47e4438 --- /dev/null +++ b/gnu/usr.bin/perl/eg/findcp @@ -0,0 +1,53 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/findcp,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ + +# This is a wrapper around the find command that pretends find has a switch +# of the form -cp host:destination. It presumes your find implements -ls. +# It uses tar to do the actual copy. If your tar knows about the I switch +# you may prefer to use findtar, since this one has to do the tar in batches. + +sub copy { + `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`; +} + +$sourcedir = $ARGV[0]; +if ($sourcedir =~ /^\//) { + $ARGV[0] = '.'; + unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; } +} + +$args = join(' ',@ARGV); +if ($args =~ s/-cp *([^ ]+)/-ls/) { + $dest = $1; + if ($dest =~ /(.*):(.*)/) { + $desthost = $1; + $destdir = $2; + } + else { + die "Malformed destination--should be host:directory"; + } +} +else { + die("No destination specified"); +} + +open(find,"find $args |") || die "Can't run find for you: $!"; + +while () { + @x = split(' '); + if ($x[2] =~ /^d/) { next;} + chop($filename = $x[10]); + if (length($list) > 5000) { + do copy(); + $list = ''; + } + else { + $list .= ' '; + } + $list .= $filename; +} + +if ($list) { + do copy(); +} diff --git a/gnu/usr.bin/perl/eg/findtar b/gnu/usr.bin/perl/eg/findtar new file mode 100644 index 0000000..a60f10f --- /dev/null +++ b/gnu/usr.bin/perl/eg/findtar @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/findtar,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ + +# findtar takes find-style arguments and spits out a tarfile on stdout. +# It won't work unless your find supports -ls and your tar the I flag. + +$args = join(' ',@ARGV); +open(find,"/usr/bin/find $args -ls |") || die "Can't run find for you."; + +open(tar,"| /bin/tar cIf - -") || die "Can't run tar for you: $!"; + +while () { + @x = split(' '); + if ($x[2] =~ /^d/) { print tar '-d ';} + print tar $x[10],"\n"; +} diff --git a/gnu/usr.bin/perl/eg/g/gcp b/gnu/usr.bin/perl/eg/g/gcp new file mode 100644 index 0000000..3e44a9c --- /dev/null +++ b/gnu/usr.bin/perl/eg/g/gcp @@ -0,0 +1,114 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/g/gcp,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $ + +# Here is a script to do global rcps. See man page. + +$#ARGV >= 1 || die "Not enough arguments.\n"; + +if ($ARGV[0] eq '-r') { + $rcp = 'rcp -r'; + shift; +} else { + $rcp = 'rcp'; +} +$args = $rcp; +$dest = $ARGV[$#ARGV]; + +$SIG{'QUIT'} = 'CLEANUP'; +$SIG{'INT'} = 'CONT'; + +while ($arg = shift) { + if ($arg =~ /^([-a-zA-Z0-9_+]+):/) { + if ($systype && $systype ne $1) { + die "Can't mix system type specifers ($systype vs $1).\n"; + } + $#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n"; + $systype = $1; + $args .= " $arg"; + } else { + if ($#ARGV >= 0) { + if ($arg =~ /^[\/~]/) { + $arg =~ /^(.*)\// && ($dir = $1); + } else { + if (!$pwd) { + chop($pwd = `pwd`); + } + $dir = $pwd; + } + } + if ($olddir && $dir ne $olddir && $dest =~ /:$/) { + $args .= " $dest$olddir; $rcp"; + } + $olddir = $dir; + $args .= " $arg"; + } +} + +die "No system type specified.\n" unless $systype; + +$args =~ s/:$/:$olddir/; + +chop($thishost = `hostname`); + +$one_of_these = ":$systype:"; +if ($systype =~ s/\+/[+]/g) { + $one_of_these =~ s/\+/:/g; +} +$one_of_these =~ s/-/:-/g; + +@ARGV = (); +push(@ARGV,'.grem') if -f '.grem'; +push(@ARGV,'.ghosts') if -f '.ghosts'; +push(@ARGV,'/etc/ghosts'); + +$remainder = ''; + +line: while (<>) { + s/[ \t]*\n//; + if (!$_ || /^#/) { + next line; + } + if (/^([a-zA-Z_0-9]+)=(.+)/) { + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $repl =~ s/-/:-/g; + $one_of_these =~ s/:$name:/:$repl:/; + $repl =~ s/:/:-/g; + $one_of_these =~ s/:-$name:/:-$repl:/g; + next line; + } + @gh = split(' '); + $host = $gh[0]; + next line if $host eq $thishost; # should handle aliases too + $wanted = 0; + foreach $class (@gh) { + $wanted++ if index($one_of_these,":$class:") >= 0; + $wanted = -9999 if index($one_of_these,":-$class:") >= 0; + } + if ($wanted > 0) { + ($cmd = $args) =~ s/[ \t]$systype:/ $host:/g; + print "$cmd\n"; + $result = `$cmd 2>&1`; + $remainder .= "$host+" if + $result =~ /Connection timed out|Permission denied/; + print $result; + } +} + +if ($remainder) { + chop($remainder); + open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n"); + print grem 'rem=', $remainder, "\n"; + close(grem); + print 'rem=', $remainder, "\n"; +} + +sub CLEANUP { + exit; +} + +sub CONT { + print "Continuing...\n"; # Just ignore the signal that kills rcp + $remainder .= "$host+"; +} diff --git a/gnu/usr.bin/perl/eg/g/gcp.man b/gnu/usr.bin/perl/eg/g/gcp.man new file mode 100644 index 0000000..8985742 --- /dev/null +++ b/gnu/usr.bin/perl/eg/g/gcp.man @@ -0,0 +1,77 @@ +.\" $Header: /home/cvs/386BSD/ports/lang/perl/eg/g/gcp.man,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $ +.TH GCP 1C "13 May 1988" +.SH NAME +gcp \- global file copy +.SH SYNOPSIS +.B gcp +file1 file2 +.br +.B gcp +[ +.B \-r +] file ... directory +.SH DESCRIPTION +.I gcp +works just like rcp(1C) except that you may specify a set of hosts to copy files +from or to. +The host sets are defined in the file /etc/ghosts. +(An individual host name can be used as a set containing one member.) +You can give a command like + + gcp /etc/motd sun: + +to copy your /etc/motd file to /etc/motd on all the Suns. +If, on the other hand, you say + + gcp /a/foo /b/bar sun:/tmp + +then your files will be copied to /tmp on all the Suns. +The general rule is that if you don't specify the destination directory, +files go to the same directory they are in currently. +.P +You may specify the union of two or more sets by using + as follows: + + gcp /a/foo /b/bar 750+mc: + +which will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy +/b/bar to /b/bar on all 750's and Masscomps. +.P +Commonly used sets should be defined in /etc/ghosts. +For example, you could add a line that says + + pep=manny+moe+jack + +Another way to do that would be to add the word "pep" after each of the host +entries: + + manny sun3 pep +.br + moe sun3 pep +.br + jack sun3 pep + +Hosts and sets of host can also be excluded: + + foo=sun-sun2 + +Any host so excluded will never be included, even if a subsequent set on the +line includes it: + + foo=abc+def +.br + bar=xyz-abc+foo + +comes out to xyz+def. + +You can define private host sets by creating .ghosts in your current directory +with entries just like /etc/ghosts. +Also, if there is a file .grem, it defines "rem" to be the remaining hosts +from the last gsh or gcp that didn't succeed everywhere. +.PP +Interrupting with a SIGINT will cause the rcp to the current host to be skipped +and execution resumed with the next host. +To stop completely, send a SIGQUIT. +.SH SEE ALSO +rcp(1C) +.SH BUGS +All the bugs of rcp, since it calls rcp. diff --git a/gnu/usr.bin/perl/eg/g/ged b/gnu/usr.bin/perl/eg/g/ged new file mode 100644 index 0000000..d296a84 --- /dev/null +++ b/gnu/usr.bin/perl/eg/g/ged @@ -0,0 +1,21 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/g/ged,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $ + +# Does inplace edits on a set of files on a set of machines. +# +# Typical invokation: +# +# ged vax+sun /etc/passwd +# s/Freddy/Freddie/; +# ^D +# + +$class = shift; +$files = join(' ',@ARGV); + +die "Usage: ged class files /tmp/gsh$$`; # get input into a handy place + $dist = " ) { # for each line of ghosts + + s/[ \t]*\n//; # trim trailing whitespace + if (!$_ || /^#/) { # skip blank line or comment + next line; + } + + if (/^(\w+)=(.+)/) { # a macro line? + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $repl =~ s/-/:-/g; + $one_of_these =~ s/:$name:/:$repl:/; # do expansion in "wanted" list + $repl =~ s/:/:-/g; + $one_of_these =~ s/:-$name:/:-$repl:/; + next line; + } + + # we have a normal line + + @attr = split(' '); # a list of attributes to match against + # which we put into an array + $host = $attr[0]; # the first attribute is the host name + if ($showhost) { + $showhost = "$host:\t"; + } + + $wanted = 0; + foreach $attr (@attr) { # iterate over attribute array + $wanted++ if index($one_of_these,":$attr:") >= 0; + $wanted = -9999 if index($one_of_these,":-$attr:") >= 0; + } + if ($wanted > 0) { + print "rsh $host$l$n '$cmd'\n" unless $silent; + $SIG{'INT'} = 'DEFAULT'; + if (open(PIPE,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh + $SIG{'INT'} = 'cont'; + for ($iter=0; ; $iter++) { + unless ($iter) { + $remainder .= "$host+" + if /Connection timed out|Permission denied/; + } + print $showhost,$_; + } + close(PIPE); + } else { + print "(Can't execute rsh: $!)\n"; + $SIG{'INT'} = 'cont'; + } + } +} + +unlink "/tmp/gsh$$" if $dodist; + +if ($remainder) { + chop($remainder); + open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n"); + print grem 'rem=', $remainder, "\n"; + close(grem); + print 'rem=', $remainder, "\n"; +} + +# here are a couple of subroutines that serve as signal handlers + +sub cont { + print "\rContinuing...\n"; + $remainder .= "$host+"; +} + +sub quit { + $| = 1; + print "\r"; + $SIG{'INT'} = ''; + kill 2, $$; +} diff --git a/gnu/usr.bin/perl/eg/g/gsh.man b/gnu/usr.bin/perl/eg/g/gsh.man new file mode 100644 index 0000000..00eafb6 --- /dev/null +++ b/gnu/usr.bin/perl/eg/g/gsh.man @@ -0,0 +1,80 @@ +.\" $Header: /home/cvs/386BSD/ports/lang/perl/eg/g/gsh.man,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $ +.TH GSH 8 "13 May 1988" +.SH NAME +gsh \- global shell +.SH SYNOPSIS +.B gsh +[options] +.I host +[options] +.I command +.SH DESCRIPTION +.I gsh +works just like rsh(1C) except that you may specify a set of hosts to execute +the command on. +The host sets are defined in the file /etc/ghosts. +(An individual host name can be used as a set containing one member.) +You can give a command like + + gsh sun /etc/mungmotd + +to run /etc/mungmotd on all your Suns. +.P +You may specify the union of two or more sets by using + as follows: + + gsh 750+mc /etc/mungmotd + +which will run mungmotd on all 750's and Masscomps. +.P +Commonly used sets should be defined in /etc/ghosts. +For example, you could add a line that says + + pep=manny+moe+jack + +Another way to do that would be to add the word "pep" after each of the host +entries: + + manny sun3 pep +.br + moe sun3 pep +.br + jack sun3 pep + +Hosts and sets of host can also be excluded: + + foo=sun-sun2 + +Any host so excluded will never be included, even if a subsequent set on the +line includes it: + + foo=abc+def + bar=xyz-abc+foo + +comes out to xyz+def. + +You can define private host sets by creating .ghosts in your current directory +with entries just like /etc/ghosts. +Also, if there is a file .grem, it defines "rem" to be the remaining hosts +from the last gsh or gcp that didn't succeed everywhere. + +Options include all those defined by rsh, as well as + +.IP "\-d" 8 +Causes gsh to collect input till end of file, and then distribute that input +to each invokation of rsh. +.IP "\-h" 8 +Rather than print out the command followed by the output, merely prepends the +host name to each line of output. +.IP "\-s" 8 +Do work silently. +.PP +Interrupting with a SIGINT will cause the rsh to the current host to be skipped +and execution resumed with the next host. +To stop completely, send a SIGQUIT. +.SH SEE ALSO +rsh(1C) +.SH BUGS +All the bugs of rsh, since it calls rsh. + +Also, will not properly return data from the remote execution that contains +null characters. diff --git a/gnu/usr.bin/perl/eg/muck b/gnu/usr.bin/perl/eg/muck new file mode 100644 index 0000000..873539b --- /dev/null +++ b/gnu/usr.bin/perl/eg/muck @@ -0,0 +1,141 @@ +#!../perl + +$M = '-M'; +$M = '-m' if -d '/usr/uts' && -f '/etc/master'; + +do 'getopt.pl'; +do Getopt('f'); + +if ($opt_f) { + $makefile = $opt_f; +} +elsif (-f 'makefile') { + $makefile = 'makefile'; +} +elsif (-f 'Makefile') { + $makefile = 'Makefile'; +} +else { + die "No makefile\n"; +} + +$MF = 'mf00'; + +while(($key,$val) = each(ENV)) { + $mac{$key} = $val; +} + +do scan($makefile); + +$co = $action{'.c.o'}; +$co = ' ' unless $co; + +$missing = "Missing dependencies:\n"; +foreach $key (sort keys(o)) { + if ($oc{$key}) { + $src = $oc{$key}; + $action = $action{$key}; + } + else { + $action = ''; + } + if (!$action) { + if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) { + $src = $c; + $action = $co; + } + else { + print "No source found for $key $c\n"; + next; + } + } + $I = ''; + $D = ''; + $I .= $1 while $action =~ s/(-I\S+\s*)//; + $D .= $1 . ' ' while $action =~ s/(-D\w+)//; + if ($opt_v) { + $cmd = "Checking $key: cc $M $D $I $src"; + $cmd =~ s/\s\s+/ /g; + print stderr $cmd,"\n"; + } + open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!"; + while () { + ($name,$dep) = split; + $dep =~ s|^\./||; + (print $missing,"$key: $dep\n"),($missing='') + unless ($dep{"$key: $dep"} += 2) > 2; + } +} + +$extra = "\nExtraneous dependencies:\n"; +foreach $key (sort keys(dep)) { + if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) { + print $extra,$key,"\n"; + $extra = ''; + } +} + +sub scan { + local($makefile) = @_; + local($MF) = $MF; + print stderr "Analyzing $makefile.\n" if $opt_v; + $MF++; + open($MF,$makefile) || die "Can't open $makefile: $!"; + while (<$MF>) { + chop; + chop($_ = $_ . <$MF>) while s/\\$//; + next if /^#/; + next if /^$/; + s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; + s/\$\((\w+)\)/$mac{$1}/eg; + $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/; + if (/^include\s+(.*)/) { + do scan($1); + print stderr "Continuing $makefile.\n" if $opt_v; + next; + } + if (/^([^:]+):\s*(.*)/) { + $left = $1; + $right = $2; + if ($right =~ /^([^;]*);(.*)/) { + $right = $1; + $action = $2; + } + else { + $action = ''; + } + while (<$MF>) { + last unless /^\t/; + chop; + chop($_ = $_ . <$MF>) while s/\\$//; + next if /^#/; + last if /^$/; + s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg; + s/\$\((\w+)\)/$mac{$1}/eg; + $action .= $_; + } + foreach $targ (split(' ',$left)) { + $targ =~ s|^\./||; + foreach $src (split(' ',$right)) { + $src =~ s|^\./||; + $deplist{$targ} .= ' ' . $src; + $dep{"$targ: $src"} = 1; + $o{$src} = 1 if $src =~ /\.o$/; + $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/; + } + $action{$targ} .= $action; + } + redo if $_; + } + } + close($MF); +} + +sub subst { + local($foo,$from,$to) = @_; + $foo = $mac{$foo}; + $from =~ s/\./[.]/; + y/a/a/; + $foo =~ s/\b$from\b/$to/g; + $foo; +} diff --git a/gnu/usr.bin/perl/eg/muck.man b/gnu/usr.bin/perl/eg/muck.man new file mode 100644 index 0000000..1b45ee0 --- /dev/null +++ b/gnu/usr.bin/perl/eg/muck.man @@ -0,0 +1,21 @@ +.\" $Header: /home/cvs/386BSD/ports/lang/perl/eg/muck.man,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ +.TH MUCK 1 "10 Jan 1989" +.SH NAME +muck \- make usage checker +.SH SYNOPSIS +.B muck +[options] +.SH DESCRIPTION +.I muck +looks at your current makefile and complains if you've left out any dependencies +between .o and .h files. +It also complains about extraneous dependencies. +.PP +You can use the -f FILENAME option to specify an alternate name for your +makefile. +The -v option is a little more verbose about what muck is mucking around +with at the moment. +.SH SEE ALSO +make(1) +.SH BUGS +Only knows about .h, .c and .o files. diff --git a/gnu/usr.bin/perl/eg/myrup b/gnu/usr.bin/perl/eg/myrup new file mode 100644 index 0000000..b318589 --- /dev/null +++ b/gnu/usr.bin/perl/eg/myrup @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/myrup,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ + +# This was a customization of ruptime requested by someone here who wanted +# to be able to find the least loaded machine easily. It uses the +# /etc/ghosts file that's defined for gsh and gcp to prune down the +# number of entries to those hosts we have administrative control over. + +print "node load (u)\n------- --------\n"; + +open(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!"; +line: while () { + next line if /^#/; + next line if /^$/; + next line if /=/; + ($host) = split; + $wanted{$host} = 1; +} + +open(ruptime,'ruptime|') || die "Can't run ruptime: $!"; +open(sort,'|sort +1n'); + +while () { + ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/); + if ($wanted{$host} && $upness eq 'up') { + printf sort "%s\t%s (%d)\n", $host, $load, $users; + } +} diff --git a/gnu/usr.bin/perl/eg/nih b/gnu/usr.bin/perl/eg/nih new file mode 100644 index 0000000..a376142 --- /dev/null +++ b/gnu/usr.bin/perl/eg/nih @@ -0,0 +1,10 @@ +eval "exec /usr/bin/perl -Spi.bak $0 $*" + if $running_under_some_shell; + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/nih,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ + +# This script makes #! scripts directly executable on machines that don't +# support #!. It edits in place any scripts mentioned on the command line. + +s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;| + if $. == 1; diff --git a/gnu/usr.bin/perl/eg/perlsh b/gnu/usr.bin/perl/eg/perlsh new file mode 100644 index 0000000..2b2cccd --- /dev/null +++ b/gnu/usr.bin/perl/eg/perlsh @@ -0,0 +1,15 @@ +#!/usr/bin/perl + +# Poor man's perl shell. + +# Simply type two carriage returns every time you want to evaluate. +# Note that it must be a complete perl statement--don't type double +# carriage return in the middle of a loop. + +$/ = "\n\n"; # set paragraph mode +$SHlinesep = "\n"; +while ($SHcmd = <>) { + $/ = $SHlinesep; + eval $SHcmd; print $@ || "\n"; + $SHlinesep = $/; $/ = ''; +} diff --git a/gnu/usr.bin/perl/eg/relink b/gnu/usr.bin/perl/eg/relink new file mode 100644 index 0000000..69956c9 --- /dev/null +++ b/gnu/usr.bin/perl/eg/relink @@ -0,0 +1,91 @@ +#!/usr/bin/perl +'di'; +'ig00'; +# +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/relink,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ +# +# $Log: relink,v $ +# Revision 1.1.1.1 1993/08/23 21:29:43 nate +# PERL! +# +# Revision 4.0 91/03/20 01:11:40 lwall +# 4.0 baseline. +# +# Revision 3.0.1.2 90/08/09 03:17:44 lwall +# patch19: added man page for relink and rename +# + +($op = shift) || die "Usage: relink perlexpr [filenames]\n"; +if (!@ARGV) { + @ARGV = ; + chop(@ARGV); +} +for (@ARGV) { + next unless -l; # symbolic link? + $name = $_; + $_ = readlink($_); + $was = $_; + eval $op; + die $@ if $@; + if ($was ne $_) { + unlink($name); + symlink($_, $name); + } +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############ +.TH RELINK 1 "July 30, 1990" +.AT 3 +.SH LINK +relink \- relinks multiple symbolic links +.SH SYNOPSIS +.B relink perlexpr [symlinknames] +.SH DESCRIPTION +.I Relink +relinks the symbolic links given according to the rule specified as the +first argument. +The argument is a Perl expression which is expected to modify the $_ +string in Perl for at least some of the names specified. +For each symbolic link named on the command line, the Perl expression +will be executed on the contents of the symbolic link with that name. +If a given symbolic link's contents is not modified by the expression, +it will not be changed. +If a name given on the command line is not a symbolic link, it will be ignored. +If no names are given on the command line, names will be read +via standard input. +.PP +For example, to relink all symbolic links in the current directory +pointing to somewhere in X11R3 so that they point to X11R4, you might say +.nf + + relink 's/X11R3/X11R4/' * + +.fi +To change all occurences of links in the system from /usr/spool to /var/spool, +you'd say +.nf + + find / -type l -print | relink 's#/usr/spool#/var/spool#' + +.fi +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +ln(1) +.br +perl(1) +.SH DIAGNOSTICS +If you give an invalid Perl expression you'll get a syntax error. +.SH BUGS +.ex diff --git a/gnu/usr.bin/perl/eg/rename b/gnu/usr.bin/perl/eg/rename new file mode 100644 index 0000000..b568406 --- /dev/null +++ b/gnu/usr.bin/perl/eg/rename @@ -0,0 +1,83 @@ +#!/usr/bin/perl +'di'; +'ig00'; +# +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/rename,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ +# +# $Log: rename,v $ +# Revision 1.1.1.1 1993/08/23 21:29:43 nate +# PERL! +# +# Revision 4.0 91/03/20 01:11:53 lwall +# 4.0 baseline. +# +# Revision 3.0.1.2 90/08/09 03:17:57 lwall +# patch19: added man page for relink and rename +# + +($op = shift) || die "Usage: rename perlexpr [filenames]\n"; +if (!@ARGV) { + @ARGV = ; + chop(@ARGV); +} +for (@ARGV) { + $was = $_; + eval $op; + die $@ if $@; + rename($was,$_) unless $was eq $_; +} +############################################################################## + + # These next few lines are legal in both Perl and nroff. + +.00; # finish .ig + +'di \" finish diversion--previous line must be blank +.nr nl 0-1 \" fake up transition to first page again +.nr % 0 \" start at page 1 +';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############ +.TH RENAME 1 "July 30, 1990" +.AT 3 +.SH NAME +rename \- renames multiple files +.SH SYNOPSIS +.B rename perlexpr [files] +.SH DESCRIPTION +.I Rename +renames the filenames supplied according to the rule specified as the +first argument. +The argument is a Perl expression which is expected to modify the $_ +string in Perl for at least some of the filenames specified. +If a given filename is not modified by the expression, it will not be +renamed. +If no filenames are given on the command line, filenames will be read +via standard input. +.PP +For example, to rename all files matching *.bak to strip the extension, +you might say +.nf + + rename 's/\e.bak$//' *.bak + +.fi +To translate uppercase names to lower, you'd use +.nf + + rename 'y/A-Z/a-z/' * + +.fi +.SH ENVIRONMENT +No environment variables are used. +.SH FILES +.SH AUTHOR +Larry Wall +.SH "SEE ALSO" +mv(1) +.br +perl(1) +.SH DIAGNOSTICS +If you give an invalid Perl expression you'll get a syntax error. +.SH BUGS +.I Rename +does not check for the existence of target filenames, so use with care. +.ex diff --git a/gnu/usr.bin/perl/eg/rmfrom b/gnu/usr.bin/perl/eg/rmfrom new file mode 100644 index 0000000..0c8fa2c --- /dev/null +++ b/gnu/usr.bin/perl/eg/rmfrom @@ -0,0 +1,7 @@ +#!/usr/bin/perl -n + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/rmfrom,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ + +# A handy (but dangerous) script to put after a find ... -print. + +chop; unlink; diff --git a/gnu/usr.bin/perl/eg/scan/scan_df b/gnu/usr.bin/perl/eg/scan/scan_df new file mode 100644 index 0000000..6887387 --- /dev/null +++ b/gnu/usr.bin/perl/eg/scan/scan_df @@ -0,0 +1,51 @@ +#!/usr/bin/perl -P + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_df,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $ + +# This report points out filesystems that are in danger of overflowing. + +(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; +`df >newdf`; +open(Df, 'olddf'); + +while () { + ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; + next if $fs =~ /:/; + next if $fs eq ''; + $oldused{$fs} = $used; +} + +open(Df, 'newdf') || die "scan_df: can't open newdf"; + +while () { + ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split; + next if $fs =~ /:/; + next if $fs eq ''; + $oldused = $oldused{$fs}; + next if ($oldused == $used && $capacity < 99); # inactive filesystem + if ($capacity >= 90) { +#if defined(mc300) || defined(mc500) || defined(mc700) + $_ = substr($_,0,13) . ' ' . substr($_,13,1000); + $kbytes /= 2; # translate blocks to K + $used /= 2; + $oldused /= 2; + $avail /= 2; +#endif + $diff = int($used - $oldused); + if ($avail < $diff * 2) { # mark specially if in danger + $mounted_on .= ' *'; + } + next if $diff < 50 && $mounted_on eq '/'; + $fs =~ s|/dev/||; + if ($diff >= 0) { + $diff = '(+' . $diff . ')'; + } + else { + $diff = '(' . $diff . ')'; + } + printf "%-8s%8d%8d %-8s%8d%7s %s\n", + $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on; + } +} + +rename('newdf','olddf'); diff --git a/gnu/usr.bin/perl/eg/scan/scan_last b/gnu/usr.bin/perl/eg/scan/scan_last new file mode 100644 index 0000000..6621120 --- /dev/null +++ b/gnu/usr.bin/perl/eg/scan/scan_last @@ -0,0 +1,57 @@ +#!/usr/bin/perl -P + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_last,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $ + +# This reports who was logged on at weird hours + +($dy, $mo, $lastdt) = split(/ +/,`date`); + +open(Last, 'exec last 2>&1 |') || die "scan_last: can't run last"; + +while () { +#if defined(mc300) || defined(mc500) || defined(mc700) + $_ = substr($_,0,19) . substr($_,23,100); +#endif + next if /^$/; + (print),next if m|^/|; + $login = substr($_,0,8); + $tty = substr($_,10,7); + $from = substr($_,19,15); + $day = substr($_,36,3); + $mo = substr($_,40,3); + $dt = substr($_,44,2); + $hr = substr($_,47,2); + $min = substr($_,50,2); + $dash = substr($_,53,1); + $tohr = substr($_,55,2); + $tomin = substr($_,58,2); + $durhr = substr($_,63,2); + $durmin = substr($_,66,2); + + next unless $hr; + next if $login eq 'reboot '; + next if $login eq 'shutdown'; + + if ($dt != $lastdt) { + if ($lastdt < $dt) { + $seen += $dt - $lastdt; + } + else { + $seen++; + } + $lastdt = $dt; + } + + $inat = $hr + $min / 60; + if ($tohr =~ /^[a-z]/) { + $outat = 12; # something innocuous + } else { + $outat = $tohr + $tomin / 60; + } + + last if $seen + ($inat < 8) > 1; + + if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) { + print; + } +} diff --git a/gnu/usr.bin/perl/eg/scan/scan_messages b/gnu/usr.bin/perl/eg/scan/scan_messages new file mode 100644 index 0000000..a28cda8 --- /dev/null +++ b/gnu/usr.bin/perl/eg/scan/scan_messages @@ -0,0 +1,222 @@ +#!/usr/bin/perl -P + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_messages,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $ + +# This prints out extraordinary console messages. You'll need to customize. + +chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; + +$maxpos = `cat oldmsgs 2>&1`; + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Msgs, '/dev/null') || die "scan_messages: can't open messages"; +#else +open(Msgs, '/usr/adm/messages') || die "scan_messages: can't open messages"; +#endif + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(Msgs); + +if ($size < $maxpos) { # Did somebody truncate messages file? + $maxpos = 0; +} + +seek(Msgs,$maxpos,0); # Start where we left off last time. + +while () { + s/\[(\d+)\]/#/ && s/$1/#/g; +#ifdef vax + $_ =~ s/[A-Z][a-z][a-z] +\w+ +[0-9:]+ +\w+ +//; + next if /root@.*:/; + next if /^vmunix: 4.3 BSD UNIX/; + next if /^vmunix: Copyright/; + next if /^vmunix: avail mem =/; + next if /^vmunix: SBIA0 at /; + next if /^vmunix: disk ra81 is/; + next if /^vmunix: dmf. at uba/; + next if /^vmunix: dmf.:.*asynch/; + next if /^vmunix: ex. at uba/; + next if /^vmunix: ex.: HW/; + next if /^vmunix: il. at uba/; + next if /^vmunix: il.: hardware/; + next if /^vmunix: ra. at uba/; + next if /^vmunix: ra.: media/; + next if /^vmunix: real mem/; + next if /^vmunix: syncing disks/; + next if /^vmunix: tms/; + next if /^vmunix: tmscp. at uba/; + next if /^vmunix: uba. at /; + next if /^vmunix: uda. at /; + next if /^vmunix: uda.: unit . ONLIN/; + next if /^vmunix: .*buffers containing/; + next if /^syslogd: .*newslog/; +#endif + next if /unknown service/; + next if /^\.\.\.$/; + if (/^[A-Z][a-z][a-z] [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]/) { + $pfx = ''; + next; + } + next if /^[ \t]*$/; + next if /^[ 0-9]*done$/; + if (/^A/) { + next if /^Accounting [sr]/; + } + elsif (/^C/) { + next if /^Called from/; + next if /^Copyright/; + } + elsif (/^E/) { + next if /^End traceback/; + next if /^Ethernet address =/; + } + elsif (/^K/) { + next if /^KERNEL MODE/; + } + elsif (/^R/) { + next if /^Rebooting Unix/; + } + elsif (/^S/) { + next if /^Sun UNIX 4\.2 Release/; + } + elsif (/^W/) { + next if /^WARNING: clock gained/; + } + elsif (/^a/) { + next if /^arg /; + next if /^avail mem =/; + } + elsif (/^b/) { + next if /^bwtwo[0-9] at /; + } + elsif (/^c/) { + next if /^cgone[0-9] at /; + next if /^cdp[0-9] at /; + next if /^csr /; + } + elsif (/^d/) { + next if /^dcpa: init/; + next if /^done$/; + next if /^dts/; + next if /^dump i\/o error/; + next if /^dumping to dev/; + next if /^dump succeeded/; + $pfx = '*' if /^dev = /; + } + elsif (/^e/) { + next if /^end \*\*/; + next if /^error in copy/; + } + elsif (/^f/) { + next if /^found /; + } + elsif (/^i/) { + next if /^ib[0-9] at /; + next if /^ie[0-9] at /; + } + elsif (/^l/) { + next if /^le[0-9] at /; + } + elsif (/^m/) { + next if /^mem = /; + next if /^mt[0-9] at /; + next if /^mti[0-9] at /; + $pfx = '*' if /^mode = /; + } + elsif (/^n/) { + next if /^not found /; + } + elsif (/^p/) { + next if /^page map /; + next if /^pi[0-9] at /; + $pfx = '*' if /^panic/; + } + elsif (/^q/) { + next if /^qqq /; + } + elsif (/^r/) { + next if /^read /; + next if /^revarp: Requesting/; + next if /^root [od]/; + } + elsif (/^s/) { + next if /^sc[0-9] at /; + next if /^sd[0-9] at /; + next if /^sd[0-9]: oldmsgs.tmp') || die "Can't create tmp file: $!\n"; +while ($_ = pop(@seen)) { + print tmp $_; +} +close(tmp); +open(tmp,'oldmsgs.tmp') || die "Can't reopen tmp file: $!\n"; +while () { + if (/^nd:/) { + next if $seen{$_} < 20; + } + if (/NFS/) { + next if $seen{$_} < 20; + } + if (/no carrier/) { + next if $seen{$_} < 20; + } + if (/silo overflow/) { + next if $seen{$_} < 20; + } + print $seen{$_},":\t",$_; +} + +print `rm -f oldmsgs.tmp 2>&1; echo $max > oldmsgs 2>&1`; diff --git a/gnu/usr.bin/perl/eg/scan/scan_passwd b/gnu/usr.bin/perl/eg/scan/scan_passwd new file mode 100644 index 0000000..f9c53c7d --- /dev/null +++ b/gnu/usr.bin/perl/eg/scan/scan_passwd @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_passwd,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $ + +# This scans passwd file for security holes. + +open(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n"; +# $dotriv = (`date` =~ /^Mon/); +$dotriv = 1; + +while () { + ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/); + if ($shell eq '') { + print "Short: $_"; + } + next if /^[+]/; + if ($pass eq '') { + if (index(":sync:lpq:+:", ":$login:") < 0) { + print "No pass: $login\t$gcos\n"; + } + } + elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) { + print "Trivial: $login\t$gcos\n"; + } + if ($uid == 0) { + if ($login !~ /^.?root$/ && $pass ne '*') { + print "Extra root: $_"; + } + } +} diff --git a/gnu/usr.bin/perl/eg/scan/scan_ps b/gnu/usr.bin/perl/eg/scan/scan_ps new file mode 100644 index 0000000..b0480d5 --- /dev/null +++ b/gnu/usr.bin/perl/eg/scan/scan_ps @@ -0,0 +1,32 @@ +#!/usr/bin/perl -P + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_ps,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $ + +# This looks for looping processes. + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps"; + +while () { + next if /rwhod/; + print if index(' T', substr($_,62,1)) < 0; +} +#else +open(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps"; + +while () { + next if /dataserver/; + next if /nfsd/; + next if /update/; + next if /ypserv/; + next if /rwhod/; + next if /routed/; + next if /pagedaemon/; +#ifdef vax + ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split; +#else + ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split; +#endif + print if length($time) > 4; +} +#endif diff --git a/gnu/usr.bin/perl/eg/scan/scan_sudo b/gnu/usr.bin/perl/eg/scan/scan_sudo new file mode 100644 index 0000000..a95a609 --- /dev/null +++ b/gnu/usr.bin/perl/eg/scan/scan_sudo @@ -0,0 +1,54 @@ +#!/usr/bin/perl -P + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_sudo,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $ + +# Analyze the sudo log. + +chdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n"; + +if (open(Oldsudo,'oldsudo')) { + $maxpos = ; + close Oldsudo; +} +else { + $maxpos = 0; + `echo 0 >oldsudo`; +} + +unless (open(Sudo, '/usr/adm/sudo.log')) { + print "Somebody removed sudo.log!!!\n" if $maxpos; + exit 0; +} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(Sudo); + +if ($size < $maxpos) { + $maxpos = 0; + print "Somebody reset sudo.log!!!\n"; +} + +seek(Sudo,$maxpos,0); + +while () { + s/^.* :[ \t]+//; + s/ipcrm.*/ipcrm/; + s/kill.*/kill/; + unless ($seen{$_}++) { + push(@seen,$_); + } + $last = $_; +} +$max = tell(Sudo); + +open(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n"; +while ($_ = pop(@seen)) { + print tmp $_; +} +close(tmp); +open(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n"; +while () { + print $seen{$_},":\t",$_; +} + +print `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`; diff --git a/gnu/usr.bin/perl/eg/scan/scan_suid b/gnu/usr.bin/perl/eg/scan/scan_suid new file mode 100644 index 0000000..a730e0a --- /dev/null +++ b/gnu/usr.bin/perl/eg/scan/scan_suid @@ -0,0 +1,84 @@ +#!/usr/bin/perl -P + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scan_suid,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $ + +# Look for new setuid root files. + +chdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n"; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('oldsuid'); +if ($nlink) { + $lasttime = $mtime; + $tmp = $ctime - $atime; + if ($tmp <= 0 || $tmp >= 10) { + print "WARNING: somebody has read oldsuid!\n"; + } + $tmp = $ctime - $mtime; + if ($tmp <= 0 || $tmp >= 10) { + print "WARNING: somebody has modified oldsuid!!!\n"; + } +} else { + $lasttime = time - 60 * 60 * 24; # one day ago +} +$thistime = time; + +#if defined(mc300) || defined(mc500) || defined(mc700) +open(Find, 'find / -perm -04000 -print |') || + die "scan_find: can't run find"; +#else +open(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') || + die "scan_find: can't run find"; +#endif + +open(suid, '>newsuid.tmp'); + +while () { + +#if defined(mc300) || defined(mc500) || defined(mc700) + $x = `/bin/ls -il $_`; + $_ = $x; + s/^ *//; + ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split; +#else + s/^ *//; + ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name) + = split; +#endif + + if ($perm =~ /[sS]/ && $owner eq 'root') { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($name); + $foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n", + $perm,$links,$owner,$group,$size,$month,$day,$name,$inode); + print suid $foo; + if ($ctime > $lasttime) { + if ($ctime > $thistime) { + print "Future file: $foo"; + } + else { + $ct .= $foo; + } + } + } +} +close(suid); + +print `sort +7 -8 newsuid.tmp >newsuid 2>&1`; +$foo = `/bin/diff oldsuid newsuid 2>&1`; +print "Differences in suid info:\n",$foo if $foo; +print `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`; +print `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`; +print `rm -f newsuid.tmp 2>&1`; + +@ct = split(/\n/,$ct); +$ct = ''; +$* = 1; +while ($#ct >= 0) { + $tmp = shift(@ct); + unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; } +} + +print "Inode changed since last time:\n",$ct if $ct; + diff --git a/gnu/usr.bin/perl/eg/scan/scanner b/gnu/usr.bin/perl/eg/scan/scanner new file mode 100644 index 0000000..f773e87 --- /dev/null +++ b/gnu/usr.bin/perl/eg/scan/scanner @@ -0,0 +1,87 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/scan/scanner,v 1.1.1.1 1993/08/23 21:29:44 nate Exp $ + +# This runs all the scan_* routines on all the machines in /etc/ghosts. +# We run this every morning at about 6 am: + +# !/bin/sh +# cd /usr/adm/private +# decrypt scanner | perl >scan.out 2>&1 +# mail admin = 0) { + @scanlist = @ARGV; +} else { + @scanlist = split(/[ \t\n]+/,`echo scan_*`); +} + +scan: while ($scan = shift(@scanlist)) { + print "\n********** $scan **********\n"; + $showhost++; + + $systype = 'all'; + + open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file'; + + $one_of_these = ":$systype:"; + if ($systype =~ s/\+/[+]/g) { + $one_of_these =~ s/\+/:/g; + } + + line: while () { + s/[ \t]*\n//; + if (!$_ || /^#/) { + next line; + } + if (/^([a-zA-Z_0-9]+)=(.+)/) { + $name = $1; $repl = $2; + $repl =~ s/\+/:/g; + $one_of_these =~ s/:$name:/:$repl:/; + next line; + } + @gh = split; + $host = $gh[0]; + if ($showhost) { $showhost = "$host:\t"; } + class: while ($class = pop(gh)) { + if (index($one_of_these,":$class:") >=0) { + $iter = 0; + `exec crypt -inquire <$scan >.x 2>/dev/null`; + unless (open(scan,'.x')) { + print "Can't run $scan: $!\n"; + next scan; + } + $cmd = ; + unless ($cmd =~ s/#!(.*)\n/$1/) { + $cmd = '/usr/bin/perl'; + } + close(scan); + if (open(PIPE,"exec rsh $host '$cmd' <.x|")) { + sleep(5); + unlink '.x'; + while () { + last if $iter++ > 1000; # must be looping + next if /^[0-9.]+u [0-9.]+s/; + print $showhost,$_; + } + close(PIPE); + } else { + print "(Can't execute rsh: $!)\n"; + } + last class; + } + } + } +} diff --git a/gnu/usr.bin/perl/eg/server b/gnu/usr.bin/perl/eg/server new file mode 100644 index 0000000..49a140a --- /dev/null +++ b/gnu/usr.bin/perl/eg/server @@ -0,0 +1,27 @@ +#!./perl + +$pat = 'S n C4 x8'; +$inet = 2; +$echo = 7; +$smtp = 25; +$nntp = 119; + +$this = pack($pat,$inet,2345, 0,0,0,0); +select(NS); $| = 1; select(stdout); + +if (socket(S,2,1,6)) { print "socket ok\n"; } else { die $!; } +if (bind(S,$this)) { print "bind ok\n"; } else { die $!; } +if (listen(S,5)) { print "listen ok\n"; } else { die $!; } +for (;;) { + print "Listening again\n"; + if ($addr = accept(NS,S)) { print "accept ok\n"; } else { die $!; } + + @ary = unpack($pat,$addr); + $, = ' '; + print @ary; print "\n"; + + while () { + print; + print NS; + } +} diff --git a/gnu/usr.bin/perl/eg/shmkill b/gnu/usr.bin/perl/eg/shmkill new file mode 100644 index 0000000..e8d1b11 --- /dev/null +++ b/gnu/usr.bin/perl/eg/shmkill @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/shmkill,v 1.1.1.1 1993/08/23 21:29:43 nate Exp $ + +# A script to call from crontab periodically when people are leaving shared +# memory sitting around unattached. + +open(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!"; + +while () { + $tmp = index($_,'NATTCH'); + $pos = $tmp if $tmp >= 0; + if (/^m/) { + ($m,$id,$key,$mode,$owner,$group,$attach) = split; + if ($attach != substr($_,$pos,6)) { + die "Different ipcs format--can't parse!\n"; + } + if ($attach == 0) { + push(@goners,'-m',$id); + } + } +} + +exec 'ipcrm', @goners if $#goners >= 0; diff --git a/gnu/usr.bin/perl/eg/sysvipc/README b/gnu/usr.bin/perl/eg/sysvipc/README new file mode 100644 index 0000000..54094f1 --- /dev/null +++ b/gnu/usr.bin/perl/eg/sysvipc/README @@ -0,0 +1,9 @@ +FYEnjoyment, here are the test scripts I used while implementing SysV +IPC in Perl. Each of them must be run with the parameter "s" for +"send" or "r" for "receive"; in each case, the receiver is the server +and the sender is the client. + +-- +Chip Salzenberg at ComDev/TCT , + + diff --git a/gnu/usr.bin/perl/eg/sysvipc/ipcmsg b/gnu/usr.bin/perl/eg/sysvipc/ipcmsg new file mode 100644 index 0000000..317e027 --- /dev/null +++ b/gnu/usr.bin/perl/eg/sysvipc/ipcmsg @@ -0,0 +1,47 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if 0; + +require 'sys/ipc.ph'; +require 'sys/msg.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; +$send = ($mode eq "s"); + +$id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644); +die "Can't get message queue: $!\n" unless defined($id); +print "message queue id: $id\n"; + +if ($send) { + while () { + chop; + unless (msgsnd($id, pack("LA*", $., $_), 0)) { + die "Can't send message: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + unless (msgrcv($id, $_, 512, 0, 0)) { + die "Can't receive message: $!\n"; + } + ($type, $message) = unpack("La*", $_); + printf "[%d] %s\n", $type, $message; + } +} + +&leave; + +sub leave { + if (!$send) { + $x = msgctl($id, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove message queue: $!\n"; + } + } + exit; +} diff --git a/gnu/usr.bin/perl/eg/sysvipc/ipcsem b/gnu/usr.bin/perl/eg/sysvipc/ipcsem new file mode 100644 index 0000000..d72a2dd --- /dev/null +++ b/gnu/usr.bin/perl/eg/sysvipc/ipcsem @@ -0,0 +1,46 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if 0; + +require 'sys/ipc.ph'; +require 'sys/msg.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; +$signal = ($mode eq "s"); + +$id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644); +die "Can't get semaphore: $!\n" unless defined($id); +print "semaphore id: $id\n"; + +if ($signal) { + while () { + print "Signalling\n"; + unless (semop($id, 0, pack("sss", 0, 1, 0))) { + die "Can't signal semaphore: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + unless (semop($id, 0, pack("sss", 0, -1, 0))) { + die "Can't wait for semaphore: $!\n"; + } + print "Unblocked\n"; + } +} + +&leave; + +sub leave { + if (!$signal) { + $x = semctl($id, 0, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove semaphore: $!\n"; + } + } + exit; +} diff --git a/gnu/usr.bin/perl/eg/sysvipc/ipcshm b/gnu/usr.bin/perl/eg/sysvipc/ipcshm new file mode 100644 index 0000000..d40e46b --- /dev/null +++ b/gnu/usr.bin/perl/eg/sysvipc/ipcshm @@ -0,0 +1,50 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if 0; + +require 'sys/ipc.ph'; +require 'sys/shm.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/; +$send = ($mode eq "s"); + +$SIZE = 32; +$id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644); +die "Can't get shared memory: $!\n" unless defined($id); +print "shared memory id: $id\n"; + +if ($send) { + while () { + chop; + unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) { + die "Can't write to shared memory: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + $_ = ; + unless (shmread($id, $_, 0, $SIZE)) { + die "Can't read shared memory: $!\n"; + } + $len = unpack("L", $_); + $message = substr($_, length(pack("L",0)), $len); + printf "[%d] %s\n", $len, $message; + } +} + +&leave; + +sub leave { + if (!$send) { + $x = shmctl($id, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove shared memory: $!\n"; + } + } + exit; +} diff --git a/gnu/usr.bin/perl/eg/travesty b/gnu/usr.bin/perl/eg/travesty new file mode 100644 index 0000000..7e6f983 --- /dev/null +++ b/gnu/usr.bin/perl/eg/travesty @@ -0,0 +1,46 @@ +#!/usr/bin/perl + +while (<>) { + next if /^\./; + next if /^From / .. /^$/; + next if /^Path: / .. /^$/; + s/^\W+//; + push(@ary,split(' ')); + while ($#ary > 1) { + $a = $p; + $p = $n; + $w = shift(@ary); + $n = $num{$w}; + if ($n eq '') { + push(@word,$w); + $n = pack('S',$#word); + $num{$w} = $n; + } + $lookup{$a . $p} .= $n; + } +} + +for (;;) { + $n = $lookup{$a . $p}; + ($foo,$n) = each(lookup) if $n eq ''; + $n = substr($n,int(rand(length($n))) & 0177776,2); + $a = $p; + $p = $n; + ($w) = unpack('S',$n); + $w = $word[$w]; + $col += length($w) + 1; + if ($col >= 65) { + $col = 0; + print "\n"; + } + else { + print ' '; + } + print $w; + if ($w =~ /\.$/) { + if (rand() < .1) { + print "\n"; + $col = 80; + } + } +} diff --git a/gnu/usr.bin/perl/eg/van/empty b/gnu/usr.bin/perl/eg/van/empty new file mode 100644 index 0000000..ee656e6 --- /dev/null +++ b/gnu/usr.bin/perl/eg/van/empty @@ -0,0 +1,45 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/van/empty,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $ + +# This script empties a trashcan. + +$recursive = shift if $ARGV[0] eq '-r'; + +@ARGV = '.' if $#ARGV < 0; + +chop($pwd = `pwd`); + +dir: foreach $dir (@ARGV) { + unless (chdir $dir) { + print stderr "Can't find directory $dir: $!\n"; + next dir; + } + if ($recursive) { + do cmd('find . -name .deleted -exec /bin/rm -rf {} ;'); + } + else { + if (-d '.deleted') { + do cmd('rm -rf .deleted'); + } + else { + if ($dir eq '.' && $pwd =~ m|/\.deleted$|) { + chdir '..'; + do cmd('rm -rf .deleted'); + } + else { + print stderr "No trashcan found in directory $dir\n"; + } + } + } +} +continue { + chdir $pwd; +} + +# force direct execution with no shell + +sub cmd { + system split(' ',join(' ',@_)); +} + diff --git a/gnu/usr.bin/perl/eg/van/unvanish b/gnu/usr.bin/perl/eg/van/unvanish new file mode 100644 index 0000000..5045982 --- /dev/null +++ b/gnu/usr.bin/perl/eg/van/unvanish @@ -0,0 +1,66 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/van/unvanish,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $ + +sub it { + if ($olddir ne '.') { + chop($pwd = `pwd`) if $pwd eq ''; + (chdir $olddir) || die "Directory $olddir is not accesible"; + } + unless ($olddir eq '.deleted') { + if (-d '.deleted') { + chdir '.deleted' || die "Directory .deleted is not accesible"; + } + else { + chop($pwd = `pwd`) if $pwd eq ''; + die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/; + } + } + print `mv $startfiles$filelist..$force`; + if ($olddir ne '.') { + (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; + } +} + +if ($#ARGV < 0) { + open(lastcmd,'.deleted/.lastcmd') || + open(lastcmd,'.lastcmd') || + die "No previous vanish in this dir"; + $ARGV = ; + close(lastcmd); + @ARGV = split(/[\n ]+/,$ARGV); +} + +while ($ARGV[0] =~ /^-/) { + $_ = shift; + /^-f/ && ($force = ' >/dev/null 2>&1'); + /^-i/ && ($interactive = 1); + if (/^-+$/) { + $startfiles = '- '; + last; + } +} + +while ($file = shift) { + if ($file =~ s|^(.*)/||) { + $dir = $1; + } + else { + $dir = '.'; + } + + if ($dir ne $olddir) { + do it() if $olddir; + $olddir = $dir; + } + + if ($interactive) { + print "unvanish: restore $dir/$file? "; + next unless =~ /^y/i; + } + + $filelist .= $file; $filelist .= ' '; + +} + +do it() if $olddir; diff --git a/gnu/usr.bin/perl/eg/van/vanexp b/gnu/usr.bin/perl/eg/van/vanexp new file mode 100644 index 0000000..79b7885 --- /dev/null +++ b/gnu/usr.bin/perl/eg/van/vanexp @@ -0,0 +1,21 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/van/vanexp,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $ + +# This is for running from a find at night to expire old .deleteds + +$can = $ARGV[0]; + +exit 1 unless $can =~ /.deleted$/; + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($can); + +exit 0 unless $size; + +if (time - $mtime > 2 * 24 * 60 * 60) { + `/bin/rm -rf $can`; +} +else { + `find $can -ctime +2 -exec rm -f {} \;`; +} diff --git a/gnu/usr.bin/perl/eg/van/vanish b/gnu/usr.bin/perl/eg/van/vanish new file mode 100644 index 0000000..b79776a --- /dev/null +++ b/gnu/usr.bin/perl/eg/van/vanish @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +# $Header: /home/cvs/386BSD/ports/lang/perl/eg/van/vanish,v 1.1.1.1 1993/08/23 21:29:45 nate Exp $ + +sub it { + if ($olddir ne '.') { + chop($pwd = `pwd`) if $pwd eq ''; + (chdir $olddir) || die "Directory $olddir is not accesible"; + } + if (!-d .deleted) { + print `mkdir .deleted; chmod 775 .deleted`; + die "You can't remove files from $olddir" if $?; + } + $filelist =~ s/ $//; + $filelist =~ s/#/\\#/g; + if ($filelist !~ /^[ \t]*$/) { + open(lastcmd,'>.deleted/.lastcmd'); + print lastcmd $filelist,"\n"; + close(lastcmd); + print `/bin/mv $startfiles$filelist .deleted$force`; + } + if ($olddir ne '.') { + (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n"; + } +} + +while ($ARGV[0] =~ /^-/) { + $_ = shift; + /^-f/ && ($force = ' >/dev/null 2>&1'); + /^-i/ && ($interactive = 1); + if (/^-+$/) { + $startfiles = '- '; + last; + } +} + +chop($pwd = `pwd`); + +while ($file = shift) { + if ($file =~ s|^(.*)/||) { + $dir = $1; + } + else { + $dir = '.'; + } + + if ($interactive) { + print "vanish: remove $dir/$file? "; + next unless =~ /^y/i; + } + + if ($file eq '.deleted') { + print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n"; + next; + } + + if ($dir ne $olddir) { + do it() if $olddir; + $olddir = $dir; + } + + $filelist .= $file; $filelist .= ' '; +} + +do it() if $olddir; diff --git a/gnu/usr.bin/perl/eg/who b/gnu/usr.bin/perl/eg/who new file mode 100644 index 0000000..ac15246 --- /dev/null +++ b/gnu/usr.bin/perl/eg/who @@ -0,0 +1,13 @@ +#!/usr/bin/perl +# This assumes your /etc/utmp file looks like ours +open(UTMP,'/etc/utmp'); +@mo = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec); +while (read(UTMP,$utmp,36)) { + ($line,$name,$host,$time) = unpack('A8A8A16l',$utmp); + if ($name) { + $host = "($host)" if ord($host); + ($sec,$min,$hour,$mday,$mon) = localtime($time); + printf "%-9s%-8s%s %2d %02d:%02d %s\n", + $name,$line,$mo[$mon],$mday,$hour,$min,$host; + } +} diff --git a/gnu/usr.bin/perl/emacs/perl-mode.el b/gnu/usr.bin/perl/emacs/perl-mode.el new file mode 100644 index 0000000..cb6195d --- /dev/null +++ b/gnu/usr.bin/perl/emacs/perl-mode.el @@ -0,0 +1,631 @@ +;; Perl code editing commands for GNU Emacs +;; Copyright (C) 1990 William F. Mann +;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the +;; Free Software Foundation, under terms of its General Public License. + +;; This file may be made part of GNU Emacs at the option of the FSF, or +;; of the perl distribution at the option of Larry Wall. + +;; This code is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; this code, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode") +;; to your .emacs file and change the first line of your perl script to: +;; #!/usr/bin/perl -- # -*-Perl-*- +;; With argments to perl: +;; #!/usr/bin/perl -P- # -*-Perl-*- +;; To handle files included with do 'filename.pl';, add something like +;; (setq auto-mode-alist (append (list (cons "\\.pl$" 'perl-mode)) +;; auto-mode-alist)) +;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode. + +;; This code is based on the 18.53 version c-mode.el, with extensive +;; rewriting. Most of the features of c-mode survived intact. + +;; I added a new feature which adds functionality to TAB; it is controlled +;; by the variable perl-tab-to-comment. With it enabled, TAB does the +;; first thing it can from the following list: change the indentation; +;; move past leading white space; delete an empty comment; reindent a +;; comment; move to end of line; create an empty comment; tell you that +;; the line ends in a quoted string, or has a # which should be a \#. + +;; If your machine is slow, you may want to remove some of the bindings +;; to electric-perl-terminator. I changed the indenting defaults to be +;; what Larry Wall uses in perl/lib, but left in all the options. + +;; I also tuned a few things: comments and labels starting in column +;; zero are left there by indent-perl-exp; perl-beginning-of-function +;; goes back to the first open brace/paren in column zero, the open brace +;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp +;; (meta-^q) indents from the current line through the close of the next +;; brace/paren, so you don't need to start exactly at a brace or paren. + +;; It may be good style to put a set of redundant braces around your +;; main program. This will let you reindent it with meta-^q. + +;; Known problems (these are all caused by limitations in the elisp +;; parsing routine (parse-partial-sexp), which was not designed for such +;; a rich language; writing a more suitable parser would be a big job): +;; 1) Regular expression delimitors do not act as quotes, so special +;; characters such as `'"#:;[](){} may need to be backslashed +;; in regular expressions and in both parts of s/// and tr///. +;; 2) The globbing syntax is not recognized, so special +;; characters in the pattern string must be backslashed. +;; 3) The q, qq, and << quoting operators are not recognized; see below. +;; 4) \ (backslash) always quotes the next character, so '\' is +;; treated as the start of a string. Use "\\" as a work-around. +;; 5) To make variables such a $' and $#array work, perl-mode treats +;; $ just like backslash, so '$' is the same as problem 5. +;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an +;; unmatched }. See below. +;; 7) When ' (quote) is used as a package name separator, perl-mode +;; doesn't understand, and thinks it is seeing a quoted string. + +;; Here are some ugly tricks to bypass some of these problems: the perl +;; expression /`/ (that's a back-tick) usually evaluates harmlessly, +;; but will trick perl-mode into starting a quoted string, which +;; can be ended with another /`/. Assuming you have no embedded +;; back-ticks, this can used to help solve problem 3: +;; +;; /`/; $ugly = q?"'$?; /`/; +;; +;; To solve problem 6, add a /{/; before each use of ${var}: +;; /{/; while (<${glob_me}>) ... +;; +;; Problem 7 is even worse, but this 'fix' does work :-( +;; $DB'stop#' +;; [$DB'line#' +;; ] =~ s/;9$//; + + +(defvar perl-mode-abbrev-table nil + "Abbrev table in use in perl-mode buffers.") +(define-abbrev-table 'perl-mode-abbrev-table ()) + +(defvar perl-mode-map () + "Keymap used in Perl mode.") +(if perl-mode-map + () + (setq perl-mode-map (make-sparse-keymap)) + (define-key perl-mode-map "{" 'electric-perl-terminator) + (define-key perl-mode-map "}" 'electric-perl-terminator) + (define-key perl-mode-map ";" 'electric-perl-terminator) + (define-key perl-mode-map ":" 'electric-perl-terminator) + (define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function) + (define-key perl-mode-map "\e\C-e" 'perl-end-of-function) + (define-key perl-mode-map "\e\C-h" 'mark-perl-function) + (define-key perl-mode-map "\e\C-q" 'indent-perl-exp) + (define-key perl-mode-map "\177" 'backward-delete-char-untabify) + (define-key perl-mode-map "\t" 'perl-indent-command)) + +(autoload 'c-macro-expand "cmacexp" + "Display the result of expanding all C macros occurring in the region. +The expansion is entirely correct because it uses the C preprocessor." + t) + +(defvar perl-mode-syntax-table nil + "Syntax table in use in perl-mode buffers.") + +(if perl-mode-syntax-table + () + (setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table))) + (modify-syntax-entry ?\n ">" perl-mode-syntax-table) + (modify-syntax-entry ?# "<" perl-mode-syntax-table) + (modify-syntax-entry ?$ "/" perl-mode-syntax-table) + (modify-syntax-entry ?% "." perl-mode-syntax-table) + (modify-syntax-entry ?& "." perl-mode-syntax-table) + (modify-syntax-entry ?\' "\"" perl-mode-syntax-table) + (modify-syntax-entry ?* "." perl-mode-syntax-table) + (modify-syntax-entry ?+ "." perl-mode-syntax-table) + (modify-syntax-entry ?- "." perl-mode-syntax-table) + (modify-syntax-entry ?/ "." perl-mode-syntax-table) + (modify-syntax-entry ?< "." perl-mode-syntax-table) + (modify-syntax-entry ?= "." perl-mode-syntax-table) + (modify-syntax-entry ?> "." perl-mode-syntax-table) + (modify-syntax-entry ?\\ "\\" perl-mode-syntax-table) + (modify-syntax-entry ?` "\"" perl-mode-syntax-table) + (modify-syntax-entry ?| "." perl-mode-syntax-table) +) + +(defconst perl-indent-level 4 + "*Indentation of Perl statements with respect to containing block.") +(defconst perl-continued-statement-offset 4 + "*Extra indent for lines not starting new statements.") +(defconst perl-continued-brace-offset -4 + "*Extra indent for substatements that start with open-braces. +This is in addition to perl-continued-statement-offset.") +(defconst perl-brace-offset 0 + "*Extra indentation for braces, compared with other text in same context.") +(defconst perl-brace-imaginary-offset 0 + "*Imagined indentation of an open brace that actually follows a statement.") +(defconst perl-label-offset -2 + "*Offset of Perl label lines relative to usual indentation.") + +(defconst perl-tab-always-indent t + "*Non-nil means TAB in Perl mode should always indent the current line, +regardless of where in the line point is when the TAB command is used.") + +(defconst perl-tab-to-comment t + "*Non-nil means that for lines which don't need indenting, TAB will +either indent an existing comment, move to end-of-line, or if at end-of-line +already, create a new comment.") + +(defconst perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:" + "*Lines starting with this regular expression will not be auto-indented.") + +(defun perl-mode () + "Major mode for editing Perl code. +Expression and list commands understand all Perl brackets. +Tab indents for Perl code. +Comments are delimited with # ... \\n. +Paragraphs are separated by blank lines only. +Delete converts tabs to spaces as it moves back. +\\{perl-mode-map} +Variables controlling indentation style: + perl-tab-always-indent + Non-nil means TAB in Perl mode should always indent the current line, + regardless of where in the line point is when the TAB command is used. + perl-tab-to-comment + Non-nil means that for lines which don't need indenting, TAB will + either delete an empty comment, indent an existing comment, move + to end-of-line, or if at end-of-line already, create a new comment. + perl-nochange + Lines starting with this regular expression will not be auto-indented. + perl-indent-level + Indentation of Perl statements within surrounding block. + The surrounding block's indentation is the indentation + of the line on which the open-brace appears. + perl-continued-statement-offset + Extra indentation given to a substatement, such as the + then-clause of an if or body of a while. + perl-continued-brace-offset + Extra indentation given to a brace that starts a substatement. + This is in addition to perl-continued-statement-offset. + perl-brace-offset + Extra indentation for line if it starts with an open brace. + perl-brace-imaginary-offset + An open brace following other text is treated as if it were + this far to the right of the start of its line. + perl-label-offset + Extra indentation for line that is a label. + +Various indentation styles: K&R BSD BLK GNU LW + perl-indent-level 5 8 0 2 4 + perl-continued-statement-offset 5 8 4 2 4 + perl-continued-brace-offset 0 0 0 0 -4 + perl-brace-offset -5 -8 0 0 0 + perl-brace-imaginary-offset 0 0 4 0 0 + perl-label-offset -5 -8 -2 -2 -2 + +Turning on Perl mode calls the value of the variable perl-mode-hook with no +args, if that value is non-nil." + (interactive) + (kill-all-local-variables) + (use-local-map perl-mode-map) + (setq major-mode 'perl-mode) + (setq mode-name "Perl") + (setq local-abbrev-table perl-mode-abbrev-table) + (set-syntax-table perl-mode-syntax-table) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "^$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'perl-indent-line) + (make-local-variable 'require-final-newline) + (setq require-final-newline t) + (make-local-variable 'comment-start) + (setq comment-start "# ") + (make-local-variable 'comment-end) + (setq comment-end "") + (make-local-variable 'comment-column) + (setq comment-column 32) + (make-local-variable 'comment-start-skip) + (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *") + (make-local-variable 'comment-indent-hook) + (setq comment-indent-hook 'perl-comment-indent) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments nil) + (run-hooks 'perl-mode-hook)) + +;; This is used by indent-for-comment +;; to decide how much to indent a comment in Perl code +;; based on its context. +(defun perl-comment-indent () + (if (and (bolp) (not (eolp))) + 0 ;Existing comment at bol stays there. + (save-excursion + (skip-chars-backward " \t") + (max (1+ (current-column)) ;Else indent at comment column + comment-column)))) ; except leave at least one space. + +(defun electric-perl-terminator (arg) + "Insert character. If at end-of-line, and not in a comment or a quote, +correct the line's indentation." + (interactive "P") + (let ((insertpos (point))) + (and (not arg) ; decide whether to indent + (eolp) + (save-excursion + (beginning-of-line) + (and (not ; eliminate comments quickly + (re-search-forward comment-start-skip insertpos t)) + (or (/= last-command-char ?:) + ;; Colon is special only after a label .... + (looking-at "\\s-*\\(\\w\\|\\s_\\)+$")) + (let ((pps (parse-partial-sexp + (perl-beginning-of-function) insertpos))) + (not (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))) + (progn ; must insert, indent, delete + (insert-char last-command-char 1) + (perl-indent-line) + (delete-char -1)))) + (self-insert-command (prefix-numeric-value arg))) + +;; not used anymore, but may be useful someday: +;;(defun perl-inside-parens-p () +;; (condition-case () +;; (save-excursion +;; (save-restriction +;; (narrow-to-region (point) +;; (perl-beginning-of-function)) +;; (goto-char (point-max)) +;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) +;; (error nil))) + +(defun perl-indent-command (&optional arg) + "Indent current line as Perl code, or optionally, insert a tab character. + +With an argument, indent the current line, regardless of other options. + +If perl-tab-always-indent is nil and point is not in the indentation +area at the beginning of the line, simply insert a tab. + +Otherwise, indent the current line. If point was within the indentation +area it is moved to the end of the indentation area. If the line was +already indented properly and point was not within the indentation area, +and if perl-tab-to-comment is non-nil (the default), then do the first +possible action from the following list: + + 1) delete an empty comment + 2) move forward to start of comment, indenting if necessary + 3) move forward to end of line + 4) create an empty comment + 5) move backward to start of comment, indenting if necessary." + (interactive "P") + (if arg ; If arg, just indent this line + (perl-indent-line "\f") + (if (and (not perl-tab-always-indent) + (<= (current-column) (current-indentation))) + (insert-tab) + (let (bof lsexp delta (oldpnt (point))) + (beginning-of-line) + (setq lsexp (point)) + (setq bof (perl-beginning-of-function)) + (goto-char oldpnt) + (setq delta (perl-indent-line "\f\\|;?#" bof)) + (and perl-tab-to-comment + (= oldpnt (point)) ; done if point moved + (if (listp delta) ; if line starts in a quoted string + (setq lsexp (or (nth 2 delta) bof)) + (= delta 0)) ; done if indenting occurred + (let (eol state) + (end-of-line) + (setq eol (point)) + (if (= (char-after bof) ?=) + (if (= oldpnt eol) + (message "In a format statement")) + (setq state (parse-partial-sexp lsexp eol)) + (if (nth 3 state) + (if (= oldpnt eol) ; already at eol in a string + (message "In a string which starts with a %c." + (nth 3 state))) + (if (not (nth 4 state)) + (if (= oldpnt eol) ; no comment, create one? + (indent-for-comment)) + (beginning-of-line) + (if (re-search-forward comment-start-skip eol 'move) + (if (eolp) + (progn ; kill existing comment + (goto-char (match-beginning 0)) + (skip-chars-backward " \t") + (kill-region (point) eol)) + (if (or (< oldpnt (point)) (= oldpnt eol)) + (indent-for-comment) ; indent existing comment + (end-of-line))) + (if (/= oldpnt eol) + (end-of-line) + (message "Use backslash to quote # characters.") + (ding t)))))))))))) + +(defun perl-indent-line (&optional nochange parse-start) + "Indent current line as Perl code. Return the amount the indentation +changed by, or (parse-state) if line starts in a quoted string." + (let ((case-fold-search nil) + (pos (- (point-max) (point))) + (bof (or parse-start (save-excursion (perl-beginning-of-function)))) + beg indent shift-amt) + (beginning-of-line) + (setq beg (point)) + (setq shift-amt + (cond ((= (char-after bof) ?=) 0) + ((listp (setq indent (calculate-perl-indent bof))) indent) + ((looking-at (or nochange perl-nochange)) 0) + (t + (skip-chars-forward " \t\f") + (cond ((looking-at "\\(\\w\\|\\s_\\)+:") + (setq indent (max 1 (+ indent perl-label-offset)))) + ((= (following-char) ?}) + (setq indent (- indent perl-indent-level))) + ((= (following-char) ?{) + (setq indent (+ indent perl-brace-offset)))) + (- indent (current-column))))) + (skip-chars-forward " \t\f") + (if (and (numberp shift-amt) (/= 0 shift-amt)) + (progn (delete-region beg (point)) + (indent-to indent))) + ;; If initial point was within line's indentation, + ;; position after the indentation. Else stay at same point in text. + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))) + shift-amt)) + +(defun calculate-perl-indent (&optional parse-start) + "Return appropriate indentation for current line as Perl code. +In usual case returns an integer: the column to indent to. +Returns (parse-state) if line starts inside a string." + (save-excursion + (beginning-of-line) + (let ((indent-point (point)) + (case-fold-search nil) + (colon-line-end 0) + state containing-sexp) + (if parse-start ;used to avoid searching + (goto-char parse-start) + (perl-beginning-of-function)) + (while (< (point) indent-point) ;repeat until right sexp + (setq parse-start (point)) + (setq state (parse-partial-sexp (point) indent-point 0)) +; state = (depth_in_parens innermost_containing_list last_complete_sexp +; string_terminator_or_nil inside_commentp following_quotep +; minimum_paren-depth_this_scan) +; Parsing stops if depth in parentheses becomes equal to third arg. + (setq containing-sexp (nth 1 state))) + (cond ((nth 3 state) state) ; In a quoted string? + ((null containing-sexp) ; Line is at top level. + (skip-chars-forward " \t\f") + (if (= (following-char) ?{) + 0 ; move to beginning of line if it starts a function body + ;; indent a little if this is a continuation line + (perl-backward-to-noncomment) + (if (or (bobp) + (memq (preceding-char) '(?\; ?\}))) + 0 perl-continued-statement-offset))) + ((/= (char-after containing-sexp) ?{) + ;; line is expression, not statement: + ;; indent to just after the surrounding open. + (goto-char (1+ containing-sexp)) + (current-column)) + (t + ;; Statement level. Is it a continuation or a new statement? + ;; Find previous non-comment character. + (perl-backward-to-noncomment) + ;; Back up over label lines, since they don't + ;; affect whether our line is a continuation. + (while (or (eq (preceding-char) ?\,) + (and (eq (preceding-char) ?:) + (memq (char-syntax (char-after (- (point) 2))) + '(?w ?_)))) + (if (eq (preceding-char) ?\,) + (perl-backward-to-start-of-continued-exp containing-sexp)) + (beginning-of-line) + (perl-backward-to-noncomment)) + ;; Now we get the answer. + (if (not (memq (preceding-char) '(?\; ?\} ?\{))) + ;; This line is continuation of preceding line's statement; + ;; indent perl-continued-statement-offset more than the + ;; previous line of the statement. + (progn + (perl-backward-to-start-of-continued-exp containing-sexp) + (+ perl-continued-statement-offset (current-column) + (if (save-excursion (goto-char indent-point) + (looking-at "[ \t]*{")) + perl-continued-brace-offset 0))) + ;; This line starts a new statement. + ;; Position at last unclosed open. + (goto-char containing-sexp) + (or + ;; If open paren is in col 0, close brace is special + (and (bolp) + (save-excursion (goto-char indent-point) + (looking-at "[ \t]*}")) + perl-indent-level) + ;; Is line first statement after an open-brace? + ;; If no, find that first statement and indent like it. + (save-excursion + (forward-char 1) + ;; Skip over comments and labels following openbrace. + (while (progn + (skip-chars-forward " \t\f\n") + (cond ((looking-at ";?#") + (forward-line 1) t) + ((looking-at "\\(\\w\\|\\s_\\)+:") + (save-excursion + (end-of-line) + (setq colon-line-end (point))) + (search-forward ":"))))) + ;; The first following code counts + ;; if it is before the line we want to indent. + (and (< (point) indent-point) + (if (> colon-line-end (point)) + (- (current-indentation) perl-label-offset) + (current-column)))) + ;; If no previous statement, + ;; indent it relative to line brace is on. + ;; For open paren in column zero, don't let statement + ;; start there too. If perl-indent-level is zero, + ;; use perl-brace-offset + perl-continued-statement-offset + ;; For open-braces not the first thing in a line, + ;; add in perl-brace-imaginary-offset. + (+ (if (and (bolp) (zerop perl-indent-level)) + (+ perl-brace-offset perl-continued-statement-offset) + perl-indent-level) + ;; Move back over whitespace before the openbrace. + ;; If openbrace is not first nonwhite thing on the line, + ;; add the perl-brace-imaginary-offset. + (progn (skip-chars-backward " \t") + (if (bolp) 0 perl-brace-imaginary-offset)) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + ;; possibly a different line + (progn + (if (eq (preceding-char) ?\)) + (forward-sexp -1)) + ;; Get initial indentation of the line we are on. + (current-indentation)))))))))) + +(defun perl-backward-to-noncomment () + "Move point backward to after the first non-white-space, skipping comments." + (interactive) + (let (opoint stop) + (while (not stop) + (setq opoint (point)) + (beginning-of-line) + (if (re-search-forward comment-start-skip opoint 'move 1) + (progn (goto-char (match-end 1)) + (skip-chars-forward ";"))) + (skip-chars-backward " \t\f") + (setq stop (or (bobp) + (not (bolp)) + (forward-char -1)))))) + +(defun perl-backward-to-start-of-continued-exp (lim) + (if (= (preceding-char) ?\)) + (forward-sexp -1)) + (beginning-of-line) + (if (<= (point) lim) + (goto-char (1+ lim))) + (skip-chars-forward " \t\f")) + +;; note: this may be slower than the c-mode version, but I can understand it. +(defun indent-perl-exp () + "Indent each line of the Perl grouping following point." + (interactive) + (let* ((case-fold-search nil) + (oldpnt (point-marker)) + (bof-mark (save-excursion + (end-of-line 2) + (perl-beginning-of-function) + (point-marker))) + eol last-mark lsexp-mark delta) + (if (= (char-after (marker-position bof-mark)) ?=) + (message "Can't indent a format statement") + (message "Indenting Perl expression...") + (save-excursion (end-of-line) (setq eol (point))) + (save-excursion ; locate matching close paren + (while (and (not (eobp)) (<= (point) eol)) + (parse-partial-sexp (point) (point-max) 0)) + (setq last-mark (point-marker))) + (setq lsexp-mark bof-mark) + (beginning-of-line) + (while (< (point) (marker-position last-mark)) + (setq delta (perl-indent-line nil (marker-position bof-mark))) + (if (numberp delta) ; unquoted start-of-line? + (progn + (if (eolp) + (delete-horizontal-space)) + (setq lsexp-mark (point-marker)))) + (end-of-line) + (setq eol (point)) + (if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol)) + (progn ; line ends in a comment + (beginning-of-line) + (if (or (not (looking-at "\\s-*;?#")) + (listp delta) + (and (/= 0 delta) + (= (- (current-indentation) delta) comment-column))) + (if (re-search-forward comment-start-skip eol t) + (indent-for-comment))))) ; indent existing comment + (forward-line 1)) + (goto-char (marker-position oldpnt)) + (message "Indenting Perl expression...done")))) + +(defun perl-beginning-of-function (&optional arg) + "Move backward to next beginning-of-function, or as far as possible. +With argument, repeat that many times; negative args move forward. +Returns new value of point in all cases." + (interactive "p") + (or arg (setq arg 1)) + (if (< arg 0) (forward-char 1)) + (and (/= arg 0) + (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*=\\|^\\." + nil 'move arg) + (goto-char (1- (match-end 0)))) + (point)) + +;; note: this routine is adapted directly from emacs lisp.el, end-of-defun; +;; no bugs have been removed :-) +(defun perl-end-of-function (&optional arg) + "Move forward to next end-of-function. +The end of a function is found by moving forward from the beginning of one. +With argument, repeat that many times; negative args move backward." + (interactive "p") + (or arg (setq arg 1)) + (let ((first t)) + (while (and (> arg 0) (< (point) (point-max))) + (let ((pos (point)) npos) + (while (progn + (if (and first + (progn + (forward-char 1) + (perl-beginning-of-function 1) + (not (bobp)))) + nil + (or (bobp) (forward-char -1)) + (perl-beginning-of-function -1)) + (setq first nil) + (forward-list 1) + (skip-chars-forward " \t") + (if (looking-at "[#\n]") + (forward-line 1)) + (<= (point) pos)))) + (setq arg (1- arg))) + (while (< arg 0) + (let ((pos (point))) + (perl-beginning-of-function 1) + (forward-sexp 1) + (forward-line 1) + (if (>= (point) pos) + (if (progn (perl-beginning-of-function 2) (not (bobp))) + (progn + (forward-list 1) + (skip-chars-forward " \t") + (if (looking-at "[#\n]") + (forward-line 1))) + (goto-char (point-min))))) + (setq arg (1+ arg))))) + +(defun mark-perl-function () + "Put mark at end of Perl function, point at beginning." + (interactive) + (push-mark (point)) + (perl-end-of-function) + (push-mark (point)) + (perl-beginning-of-function) + (backward-paragraph)) + +;;;;;;;; That's all, folks! ;;;;;;;;; diff --git a/gnu/usr.bin/perl/emacs/perldb.el b/gnu/usr.bin/perl/emacs/perldb.el new file mode 100644 index 0000000..66951be --- /dev/null +++ b/gnu/usr.bin/perl/emacs/perldb.el @@ -0,0 +1,423 @@ +;; Run perl -d under Emacs +;; Based on gdb.el, as written by W. Schelter, and modified by rms. +;; Modified for Perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990. + +;; This file is part of GNU Emacs. +;; Copyright (C) 1988,1990 Free Software Foundation, Inc. + +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility +;; to anyone for the consequences of using it or for whether it serves +;; any particular purpose or works at all, unless he says so in writing. +;; Refer to the GNU Emacs General Public License for full details. + +;; Everyone is granted permission to copy, modify and redistribute GNU +;; Emacs, but only under the conditions described in the GNU Emacs +;; General Public License. A copy of this license is supposed to have +;; been given to you along with GNU Emacs so you can know your rights and +;; responsibilities. It should be in a file named COPYING. Among other +;; things, the copyright notice and this notice must be preserved on all +;; copies. + +;; Description of perl -d interface: + +;; A facility is provided for the simultaneous display of the source code +;; in one window, while using perldb to step through a function in the +;; other. A small arrow in the source window, indicates the current +;; line. + +;; Starting up: + +;; In order to use this facility, invoke the command PERLDB to obtain a +;; shell window with the appropriate command bindings. You will be asked +;; for the name of a file to run and additional command line arguments. +;; Perldb will be invoked on this file, in a window named *perldb-foo* +;; if the file is foo. + +;; M-s steps by one line, and redisplays the source file and line. + +;; You may easily create additional commands and bindings to interact +;; with the display. For example to put the perl debugger command n on \M-n +;; (def-perldb n "\M-n") + +;; This causes the emacs command perldb-next to be defined, and runs +;; perldb-display-frame after the command. + +;; perldb-display-frame is the basic display function. It tries to display +;; in the other window, the file and line corresponding to the current +;; position in the perldb window. For example after a perldb-step, it would +;; display the line corresponding to the position for the last step. Or +;; if you have done a backtrace in the perldb buffer, and move the cursor +;; into one of the frames, it would display the position corresponding to +;; that frame. + +;; perldb-display-frame is invoked automatically when a filename-and-line-number +;; appears in the output. + + +(require 'shell) + +(defvar perldb-prompt-pattern "^ DB<[0-9]+> " + "A regexp to recognize the prompt for perldb.") + +(defvar perldb-mode-map nil + "Keymap for perldb-mode.") + +(if perldb-mode-map + nil + (setq perldb-mode-map (copy-keymap shell-mode-map)) + (define-key perldb-mode-map "\C-l" 'perldb-refresh)) + +(define-key ctl-x-map " " 'perldb-break) +(define-key ctl-x-map "&" 'send-perldb-command) + +;;Of course you may use `def-perldb' with any other perldb command, including +;;user defined ones. + +(defmacro def-perldb (name key &optional doc) + (let* ((fun (intern (concat "perldb-" name)))) + (` (progn + (defun (, fun) (arg) + (, (or doc "")) + (interactive "p") + (perldb-call (if (not (= 1 arg)) + (concat (, name) arg) + (, name)))) + (define-key perldb-mode-map (, key) (quote (, fun))))))) + +(def-perldb "s" "\M-s" "Step one source line with display") +(def-perldb "n" "\M-n" "Step one source line (skip functions)") +(def-perldb "c" "\M-c" "Continue with display") +(def-perldb "r" "\C-c\C-r" "Return from current subroutine") +(def-perldb "A" "\C-c\C-a" "Delete all actions") + +(defun perldb-mode () + "Major mode for interacting with an inferior Perl debugger process. +The following commands are available: + +\\{perldb-mode-map} + +\\[perldb-display-frame] displays in the other window +the last line referred to in the perldb buffer. + +\\[perldb-s],\\[perldb-n], and \\[perldb-n] in the perldb window, +call perldb to step, next or continue and then update the other window +with the current file and position. + +If you are in a source file, you may select a point to break +at, by doing \\[perldb-break]. + +Commands: +Many commands are inherited from shell mode. +Additionally we have: + +\\[perldb-display-frame] display frames file in other window +\\[perldb-s] advance one line in program +\\[perldb-n] advance one line in program (skip over calls). +\\[send-perldb-command] used for special printing of an arg at the current point. +C-x SPACE sets break point at current line." + (interactive) + (kill-all-local-variables) + (setq major-mode 'perldb-mode) + (setq mode-name "Inferior Perl") + (setq mode-line-process '(": %s")) + (use-local-map perldb-mode-map) + (make-local-variable 'last-input-start) + (setq last-input-start (make-marker)) + (make-local-variable 'last-input-end) + (setq last-input-end (make-marker)) + (make-local-variable 'perldb-last-frame) + (setq perldb-last-frame nil) + (make-local-variable 'perldb-last-frame-displayed-p) + (setq perldb-last-frame-displayed-p t) + (make-local-variable 'perldb-delete-prompt-marker) + (setq perldb-delete-prompt-marker nil) + (make-local-variable 'perldb-filter-accumulator) + (setq perldb-filter-accumulator nil) + (make-local-variable 'shell-prompt-pattern) + (setq shell-prompt-pattern perldb-prompt-pattern) + (run-hooks 'shell-mode-hook 'perldb-mode-hook)) + +(defvar current-perldb-buffer nil) + +(defvar perldb-command-name "perl" + "Pathname for executing perl -d.") + +(defun end-of-quoted-arg (argstr start end) + (let* ((chr (substring argstr start (1+ start))) + (idx (string-match (concat "[^\\]" chr) argstr (1+ start)))) + (and idx (1+ idx)) + ) +) + +(defun parse-args-helper (arglist argstr start end) + (while (and (< start end) (string-match "[ \t\n\f\r\b]" + (substring argstr start (1+ start)))) + (setq start (1+ start))) + (cond + ((= start end) arglist) + ((string-match "[\"']" (substring argstr start (1+ start))) + (let ((next (end-of-quoted-arg argstr start end))) + (parse-args-helper (cons (substring argstr (1+ start) next) arglist) + argstr (1+ next) end))) + (t (let ((next (string-match "[ \t\n\f\b\r]" argstr start))) + (if next + (parse-args-helper (cons (substring argstr start next) arglist) + argstr (1+ next) end) + (cons (substring argstr start) arglist)))) + ) + ) + +(defun parse-args (args) + "Extract arguments from a string ARGS. +White space separates arguments, with single or double quotes +used to protect spaces. A list of strings is returned, e.g., +(parse-args \"foo bar 'two args'\") => (\"foo\" \"bar\" \"two args\")." + (nreverse (parse-args-helper '() args 0 (length args))) +) + +(defun perldb (path args) + "Run perldb on program FILE in buffer *perldb-FILE*. +The default directory for the current buffer becomes the initial +working directory, by analogy with gdb . If you wish to change this, use +the Perl command `chdir(DIR)'." + (interactive "FRun perl -d on file: \nsCommand line arguments: ") + (setq path (expand-file-name path)) + (let ((file (file-name-nondirectory path)) + (dir default-directory)) + (switch-to-buffer (concat "*perldb-" file "*")) + (setq default-directory dir) + (or (bolp) (newline)) + (insert "Current directory is " default-directory "\n") + (apply 'make-shell + (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs" + (parse-args args)) + (perldb-mode) + (set-process-filter (get-buffer-process (current-buffer)) 'perldb-filter) + (set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel) + (perldb-set-buffer))) + +(defun perldb-set-buffer () + (cond ((eq major-mode 'perldb-mode) + (setq current-perldb-buffer (current-buffer))))) + +;; This function is responsible for inserting output from Perl +;; into the buffer. +;; Aside from inserting the text, it notices and deletes +;; each filename-and-line-number; +;; that Perl prints to identify the selected frame. +;; It records the filename and line number, and maybe displays that file. +(defun perldb-filter (proc string) + (let ((inhibit-quit t)) + (if perldb-filter-accumulator + (perldb-filter-accumulate-marker proc + (concat perldb-filter-accumulator string)) + (perldb-filter-scan-input proc string)))) + +(defun perldb-filter-accumulate-marker (proc string) + (setq perldb-filter-accumulator nil) + (if (> (length string) 1) + (if (= (aref string 1) ?\032) + (let ((end (string-match "\n" string))) + (if end + (progn + (let* ((first-colon (string-match ":" string 2)) + (second-colon + (string-match ":" string (1+ first-colon)))) + (setq perldb-last-frame + (cons (substring string 2 first-colon) + (string-to-int + (substring string (1+ first-colon) + second-colon))))) + (setq perldb-last-frame-displayed-p nil) + (perldb-filter-scan-input proc + (substring string (1+ end)))) + (setq perldb-filter-accumulator string))) + (perldb-filter-insert proc "\032") + (perldb-filter-scan-input proc (substring string 1))) + (setq perldb-filter-accumulator string))) + +(defun perldb-filter-scan-input (proc string) + (if (equal string "") + (setq perldb-filter-accumulator nil) + (let ((start (string-match "\032" string))) + (if start + (progn (perldb-filter-insert proc (substring string 0 start)) + (perldb-filter-accumulate-marker proc + (substring string start))) + (perldb-filter-insert proc string))))) + +(defun perldb-filter-insert (proc string) + (let ((moving (= (point) (process-mark proc))) + (output-after-point (< (point) (process-mark proc))) + (old-buffer (current-buffer)) + start) + (set-buffer (process-buffer proc)) + (unwind-protect + (save-excursion + ;; Insert the text, moving the process-marker. + (goto-char (process-mark proc)) + (setq start (point)) + (insert string) + (set-marker (process-mark proc) (point)) + (perldb-maybe-delete-prompt) + ;; Check for a filename-and-line number. + (perldb-display-frame + ;; Don't display the specified file + ;; unless (1) point is at or after the position where output appears + ;; and (2) this buffer is on the screen. + (or output-after-point + (not (get-buffer-window (current-buffer)))) + ;; Display a file only when a new filename-and-line-number appears. + t)) + (set-buffer old-buffer)) + (if moving (goto-char (process-mark proc))))) + +(defun perldb-sentinel (proc msg) + (cond ((null (buffer-name (process-buffer proc))) + ;; buffer killed + ;; Stop displaying an arrow in a source file. + (setq overlay-arrow-position nil) + (set-process-buffer proc nil)) + ((memq (process-status proc) '(signal exit)) + ;; Stop displaying an arrow in a source file. + (setq overlay-arrow-position nil) + ;; Fix the mode line. + (setq mode-line-process + (concat ": " + (symbol-name (process-status proc)))) + (let* ((obuf (current-buffer))) + ;; save-excursion isn't the right thing if + ;; process-buffer is current-buffer + (unwind-protect + (progn + ;; Write something in *compilation* and hack its mode line, + (set-buffer (process-buffer proc)) + ;; Force mode line redisplay soon + (set-buffer-modified-p (buffer-modified-p)) + (if (eobp) + (insert ?\n mode-name " " msg) + (save-excursion + (goto-char (point-max)) + (insert ?\n mode-name " " msg))) + ;; If buffer and mode line will show that the process + ;; is dead, we can delete it now. Otherwise it + ;; will stay around until M-x list-processes. + (delete-process proc)) + ;; Restore old buffer, but don't restore old point + ;; if obuf is the perldb buffer. + (set-buffer obuf)))))) + + +(defun perldb-refresh () + "Fix up a possibly garbled display, and redraw the arrow." + (interactive) + (redraw-display) + (perldb-display-frame)) + +(defun perldb-display-frame (&optional nodisplay noauto) + "Find, obey and delete the last filename-and-line marker from PERLDB. +The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n. +Obeying it means displaying in another window the specified file and line." + (interactive) + (perldb-set-buffer) + (and perldb-last-frame (not nodisplay) + (or (not perldb-last-frame-displayed-p) (not noauto)) + (progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame)) + (setq perldb-last-frame-displayed-p t)))) + +;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen +;; and that its line LINE is visible. +;; Put the overlay-arrow on the line LINE in that buffer. + +(defun perldb-display-line (true-file line) + (let* ((buffer (find-file-noselect true-file)) + (window (display-buffer buffer t)) + (pos)) + (save-excursion + (set-buffer buffer) + (save-restriction + (widen) + (goto-line line) + (setq pos (point)) + (setq overlay-arrow-string "=>") + (or overlay-arrow-position + (setq overlay-arrow-position (make-marker))) + (set-marker overlay-arrow-position (point) (current-buffer))) + (cond ((or (< pos (point-min)) (> pos (point-max))) + (widen) + (goto-char pos)))) + (set-window-point window overlay-arrow-position))) + +(defun perldb-call (command) + "Invoke perldb COMMAND displaying source in other window." + (interactive) + (goto-char (point-max)) + (setq perldb-delete-prompt-marker (point-marker)) + (perldb-set-buffer) + (send-string (get-buffer-process current-perldb-buffer) + (concat command "\n"))) + +(defun perldb-maybe-delete-prompt () + (if (and perldb-delete-prompt-marker + (> (point-max) (marker-position perldb-delete-prompt-marker))) + (let (start) + (goto-char perldb-delete-prompt-marker) + (setq start (point)) + (beginning-of-line) + (delete-region (point) start) + (setq perldb-delete-prompt-marker nil)))) + +(defun perldb-break () + "Set PERLDB breakpoint at this source line." + (interactive) + (let ((line (save-restriction + (widen) + (1+ (count-lines 1 (point)))))) + (send-string (get-buffer-process current-perldb-buffer) + (concat "b " line "\n")))) + +(defun perldb-read-token() + "Return a string containing the token found in the buffer at point. +A token can be a number or an identifier. If the token is a name prefaced +by `$', `@', or `%', the leading character is included in the token." + (save-excursion + (let (begin) + (or (looking-at "[$@%]") + (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move)) + (setq begin (point)) + (or (looking-at "[$@%]") (setq begin (+ begin 1))) + (forward-char 1) + (buffer-substring begin + (if (re-search-forward "[^a-zA-Z_0-9]" + (point-max) 'move) + (- (point) 1) + (point))) +))) + +(defvar perldb-commands nil + "List of strings or functions used by send-perldb-command. +It is for customization by the user.") + +(defun send-perldb-command (arg) + "Issue a Perl debugger command selected by the prefix arg. A numeric +arg selects the ARG'th member COMMAND of the list perldb-commands. +The token under the cursor is passed to the command. If COMMAND is a +string, (format COMMAND TOKEN) is inserted at the end of the perldb +buffer, otherwise (funcall COMMAND TOKEN) is inserted. If there is +no such COMMAND, then the token itself is inserted. For example, +\"p %s\" is a possible string to be a member of perldb-commands, +or \"p $ENV{%s}\"." + (interactive "P") + (let (comm token) + (if arg (setq comm (nth arg perldb-commands))) + (setq token (perldb-read-token)) + (if (eq (current-buffer) current-perldb-buffer) + (set-mark (point))) + (cond (comm + (setq comm + (if (stringp comm) (format comm token) (funcall comm token)))) + (t (setq comm token))) + (switch-to-buffer-other-window current-perldb-buffer) + (goto-char (dot-max)) + (insert-string comm))) diff --git a/gnu/usr.bin/perl/emacs/perldb.pl b/gnu/usr.bin/perl/emacs/perldb.pl new file mode 100644 index 0000000..7c9e651 --- /dev/null +++ b/gnu/usr.bin/perl/emacs/perldb.pl @@ -0,0 +1,568 @@ +package DB; + +# modified Perl debugger, to be run from Emacs in perldb-mode +# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 + +$header = '$Header: /home/cvs/386BSD/ports/lang/perl/emacs/perldb.pl,v 1.1.1.1 1993/08/23 21:29:46 nate Exp $'; +# +# This file is automatically included if you do perl -d. +# It's probably not useful to include this yourself. +# +# Perl supplies the values for @line and %sub. It effectively inserts +# a do DB'DB(); in front of every place that can +# have a breakpoint. It also inserts a do 'perldb.pl' before the first line. +# +# $Log: perldb.pl,v $ +# Revision 1.1.1.1 1993/08/23 21:29:46 nate +# PERL! +# +# Revision 4.0 91/03/20 01:18:58 lwall +# 4.0 baseline. +# +# Revision 3.0.1.6 91/01/11 18:08:58 lwall +# patch42: @_ couldn't be accessed from debugger +# +# Revision 3.0.1.5 90/11/10 01:40:26 lwall +# patch38: the debugger wouldn't stop correctly or do action routines +# +# Revision 3.0.1.4 90/10/15 17:40:38 lwall +# patch29: added caller +# patch29: the debugger now understands packages and evals +# patch29: scripts now run at almost full speed under the debugger +# patch29: more variables are settable from debugger +# +# Revision 3.0.1.3 90/08/09 04:00:58 lwall +# patch19: debugger now allows continuation lines +# patch19: debugger can now dump lists of variables +# patch19: debugger can now add aliases easily from prompt +# +# Revision 3.0.1.2 90/03/12 16:39:39 lwall +# patch13: perl -d didn't format stack traces of *foo right +# patch13: perl -d wiped out scalar return values of subroutines +# +# Revision 3.0.1.1 89/10/26 23:14:02 lwall +# patch1: RCS expanded an unintended $Header in lib/perldb.pl +# +# Revision 3.0 89/10/18 15:19:46 lwall +# 3.0 baseline +# +# Revision 2.0 88/06/05 00:09:45 root +# Baseline version 2.0. +# +# + +open(IN, "/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout +select(OUT); +$| = 1; # for DB'OUT +select(STDOUT); +$| = 1; # for real STDOUT +$sub = ''; + +# Is Perl being run from Emacs? +$emacs = $main'ARGV[$[] eq '-emacs'; +shift(@main'ARGV) if $emacs; + +$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; +print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n"; + +sub DB { + &save; + ($package, $filename, $line) = caller; + $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' . + "package $package;"; # this won't let them modify, alas + local(*dbline) = "_<$filename"; + $max = $#dbline; + if (($stop,$action) = split(/\0/,$dbline{$line})) { + if ($stop eq '1') { + $signal |= 1; + } + else { + $evalarg = "\$DB'signal |= do {$stop;}"; &eval; + $dbline{$line} =~ s/;9($|\0)/$1/; + } + } + if ($single || $trace || $signal) { + if ($emacs) { + print OUT "\032\032$filename:$line:0\n"; + } else { + print OUT "$package'" unless $sub =~ /'/; + print OUT "$sub($filename:$line):\t",$dbline[$line]; + for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { + last if $dbline[$i] =~ /^\s*(}|#|\n)/; + print OUT "$sub($filename:$i):\t",$dbline[$i]; + } + } + } + $evalarg = $action, &eval if $action; + if ($single || $signal) { + $evalarg = $pre, &eval if $pre; + print OUT $#stack . " levels deep in subroutine calls!\n" + if $single & 4; + $start = $line; + while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) { + $single = 0; + $signal = 0; + $cmd eq '' && exit 0; + chop($cmd); + $cmd =~ s/\\$// && do { + print OUT " cont: "; + $cmd .= &gets; + redo; + }; + $cmd =~ /^q$/ && exit 0; + $cmd =~ /^$/ && ($cmd = $laststep); + push(@hist,$cmd) if length($cmd) > 1; + ($i) = split(/\s+/,$cmd); + eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; + $cmd =~ /^h$/ && do { + print OUT " +T Stack trace. +s Single step. +n Next, steps over subroutine calls. +r Return from current subroutine. +c [line] Continue; optionally inserts a one-time-only breakpoint + at the specified line. + Repeat last n or s. +l min+incr List incr+1 lines starting at min. +l min-max List lines. +l line List line; +l List next window. +- List previous window. +w line List window around line. +l subname List subroutine. +f filename Switch to filename. +/pattern/ Search forwards for pattern; final / is optional. +?pattern? Search backwards for pattern. +L List breakpoints and actions. +S List subroutine names. +t Toggle trace mode. +b [line] [condition] + Set breakpoint; line defaults to the current execution line; + condition breaks if it evaluates to true, defaults to \'1\'. +b subname [condition] + Set breakpoint at first line of subroutine. +d [line] Delete breakpoint. +D Delete all breakpoints. +a [line] command + Set an action to be done before the line is executed. + Sequence is: check for breakpoint, print line if necessary, + do action, prompt user if breakpoint or step, evaluate line. +A Delete all actions. +V [pkg [vars]] List some (default all) variables in package (default current). +X [vars] Same as \"V currentpackage [vars]\". +< command Define command before prompt. +| command Define command after prompt. +! number Redo command (default previous command). +! -number Redo number\'th to last command. +H -number Display last number commands (default all). +q or ^D Quit. +p expr Same as \"print DB'OUT expr\" in current package. += [alias value] Define a command alias, or list current aliases. +command Execute as a perl statement in current package. + +"; + next; }; + $cmd =~ /^t$/ && do { + $trace = !$trace; + print OUT "Trace = ".($trace?"on":"off")."\n"; + next; }; + $cmd =~ /^S$/ && do { + foreach $subname (sort(keys %sub)) { + print OUT $subname,"\n"; + } + next; }; + $cmd =~ s/^X\b/V $package/; + $cmd =~ /^V$/ && do { + $cmd = 'V $package'; }; + $cmd =~ /^V\s*(\S+)\s*(.*)/ && do { + $packname = $1; + @vars = split(' ',$2); + do 'dumpvar.pl' unless defined &main'dumpvar; + if (defined &main'dumpvar) { + &main'dumpvar($packname,@vars); + } + else { + print DB'OUT "dumpvar.pl not available.\n"; + } + next; }; + $cmd =~ /^f\s*(.*)/ && do { + $file = $1; + if (!$file) { + print OUT "The old f command is now the r command.\n"; + print OUT "The new f command switches filenames.\n"; + next; + } + if (!defined $_main{'_<' . $file}) { + if (($try) = grep(m#^_<.*$file#, keys %_main)) { + $file = substr($try,2); + print "\n$file:\n"; + } + } + if (!defined $_main{'_<' . $file}) { + print OUT "There's no code here anything matching $file.\n"; + next; + } + elsif ($file ne $filename) { + *dbline = "_<$file"; + $max = $#dbline; + $filename = $file; + $start = 1; + $cmd = "l"; + } }; + $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do { + $subname = $1; + $subname = "main'" . $subname unless $subname =~ /'/; + $subname = "main" . $subname if substr($subname,0,1) eq "'"; + ($file,$subrange) = split(/:/,$sub{$subname}); + if ($file ne $filename) { + *dbline = "_<$file"; + $max = $#dbline; + $filename = $file; + } + if ($subrange) { + if (eval($subrange) < -$window) { + $subrange =~ s/-.*/+/; + } + $cmd = "l $subrange"; + } else { + print OUT "Subroutine $1 not found.\n"; + next; + } }; + $cmd =~ /^w\s*(\d*)$/ && do { + $incr = $window - 1; + $start = $1 if $1; + $start -= $preview; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^-$/ && do { + $incr = $window - 1; + $cmd = 'l ' . ($start-$window*2) . '+'; }; + $cmd =~ /^l$/ && do { + $incr = $window - 1; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do { + $start = $1 if $1; + $incr = $2; + $incr = $window - 1 unless $incr; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { + $end = (!$2) ? $max : ($4 ? $4 : $2); + $end = $max if $end > $max; + $i = $2; + $i = $line if $i eq '.'; + $i = 1 if $i < 1; + if ($emacs) { + print OUT "\032\032$filename:$i:0\n"; + $i = $end; + } else { + for (; $i <= $end; $i++) { + print OUT "$i:\t", $dbline[$i]; + last if $signal; + } + } + $start = $i; # remember in case they want more + $start = $max if $start > $max; + next; }; + $cmd =~ /^D$/ && do { + print OUT "Deleting all breakpoints...\n"; + for ($i = 1; $i <= $max ; $i++) { + if (defined $dbline{$i}) { + $dbline{$i} =~ s/^[^\0]+//; + if ($dbline{$i} =~ s/^\0?$//) { + delete $dbline{$i}; + } + } + } + next; }; + $cmd =~ /^L$/ && do { + for ($i = 1; $i <= $max; $i++) { + if (defined $dbline{$i}) { + print OUT "$i:\t", $dbline[$i]; + ($stop,$action) = split(/\0/, $dbline{$i}); + print OUT " break if (", $stop, ")\n" + if $stop; + print OUT " action: ", $action, "\n" + if $action; + last if $signal; + } + } + next; }; + $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do { + $subname = $1; + $cond = $2 || '1'; + $subname = "$package'" . $subname unless $subname =~ /'/; + $subname = "main" . $subname if substr($subname,0,1) eq "'"; + ($filename,$i) = split(/[:-]/, $sub{$subname}); + if ($i) { + *dbline = "_<$filename"; + ++$i while $dbline[$i] == 0 && $i < $#dbline; + $dbline{$i} =~ s/^[^\0]*/$cond/; + } else { + print OUT "Subroutine $subname not found.\n"; + } + next; }; + $cmd =~ /^b\s*(\d*)\s*(.*)/ && do { + $i = ($1?$1:$line); + $cond = $2 || '1'; + if ($dbline[$i] == 0) { + print OUT "Line $i not breakable.\n"; + } else { + $dbline{$i} =~ s/^[^\0]*/$cond/; + } + next; }; + $cmd =~ /^d\s*(\d+)?/ && do { + $i = ($1?$1:$line); + $dbline{$i} =~ s/^[^\0]*//; + delete $dbline{$i} if $dbline{$i} eq ''; + next; }; + $cmd =~ /^A$/ && do { + for ($i = 1; $i <= $max ; $i++) { + if (defined $dbline{$i}) { + $dbline{$i} =~ s/\0[^\0]*//; + delete $dbline{$i} if $dbline{$i} eq ''; + } + } + next; }; + $cmd =~ /^<\s*(.*)/ && do { + $pre = do action($1); + next; }; + $cmd =~ /^>\s*(.*)/ && do { + $post = do action($1); + next; }; + $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do { + $i = $1; + if ($dbline[$i] == 0) { + print OUT "Line $i may not have an action.\n"; + } else { + $dbline{$i} =~ s/\0[^\0]*//; + $dbline{$i} .= "\0" . do action($3); + } + next; }; + $cmd =~ /^n$/ && do { + $single = 2; + $laststep = $cmd; + last; }; + $cmd =~ /^s$/ && do { + $single = 1; + $laststep = $cmd; + last; }; + $cmd =~ /^c\s*(\d*)\s*$/ && do { + $i = $1; + if ($i) { + if ($dbline[$i] == 0) { + print OUT "Line $i not breakable.\n"; + next; + } + $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p. + } + for ($i=0; $i <= $#stack; ) { + $stack[$i++] &= ~1; + } + last; }; + $cmd =~ /^r$/ && do { + $stack[$#stack] |= 2; + last; }; + $cmd =~ /^T$/ && do { + local($p,$f,$l,$s,$h,$a,@a,@sub); + for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { + @a = @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"); + last if $signal; + } + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + print OUT $sub[$i]; + } + next; }; + $cmd =~ /^\/(.*)$/ && do { + $inpat = $1; + $inpat =~ s:([^\\])/$:$1:; + if ($inpat ne "") { + eval '$inpat =~ m'."\n$inpat\n"; + if ($@ ne "") { + print OUT "$@"; + next; + } + $pat = $inpat; + } + $end = $start; + eval ' + for (;;) { + ++$start; + $start = 1 if ($start > $max); + last if ($start == $end); + if ($dbline[$start] =~ m'."\n$pat\n".'i) { + if ($emacs) { + print OUT "\032\032$filename:$start:0\n"; + } else { + print OUT "$start:\t", $dbline[$start], "\n"; + } + last; + } + } '; + print OUT "/$pat/: not found\n" if ($start == $end); + next; }; + $cmd =~ /^\?(.*)$/ && do { + $inpat = $1; + $inpat =~ s:([^\\])\?$:$1:; + if ($inpat ne "") { + eval '$inpat =~ m'."\n$inpat\n"; + if ($@ ne "") { + print OUT "$@"; + next; + } + $pat = $inpat; + } + $end = $start; + eval ' + for (;;) { + --$start; + $start = $max if ($start <= 0); + last if ($start == $end); + if ($dbline[$start] =~ m'."\n$pat\n".'i) { + if ($emacs) { + print OUT "\032\032$filename:$start:0\n"; + } else { + print OUT "$start:\t", $dbline[$start], "\n"; + } + last; + } + } '; + print OUT "?$pat?: not found\n" if ($start == $end); + next; }; + $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { + pop(@hist) if length($cmd) > 1; + $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); + $cmd = $hist[$i] . "\n"; + print OUT $cmd; + redo; }; + $cmd =~ /^!(.+)$/ && do { + $pat = "^$1"; + pop(@hist) if length($cmd) > 1; + for ($i = $#hist; $i; --$i) { + last if $hist[$i] =~ $pat; + } + if (!$i) { + print OUT "No such command!\n\n"; + next; + } + $cmd = $hist[$i] . "\n"; + print OUT $cmd; + redo; }; + $cmd =~ /^H\s*(-(\d+))?/ && do { + $end = $2?($#hist-$2):0; + $hist = 0 if $hist < 0; + for ($i=$#hist; $i>$end; $i--) { + print OUT "$i: ",$hist[$i],"\n" + unless $hist[$i] =~ /^.?$/; + }; + next; }; + $cmd =~ s/^p( .*)?$/print DB'OUT$1/; + $cmd =~ /^=/ && do { + if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { + $alias{$k}="s~$k~$v~"; + print OUT "$k = $v\n"; + } elsif ($cmd =~ /^=\s*$/) { + foreach $k (sort keys(%alias)) { + if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { + print OUT "$k = $v\n"; + } else { + print OUT "$k\t$alias{$k}\n"; + }; + }; + }; + next; }; + $evalarg = $cmd; &eval; + print OUT "\n"; + } + if ($post) { + $evalarg = $post; &eval; + } + } + ($@, $!, $[, $,, $/, $\) = @saved; +} + +sub save { + @saved = ($@, $!, $[, $,, $/, $\); + $[ = 0; $, = ""; $/ = "\n"; $\ = ""; +} + +# The following takes its argument via $evalarg to preserve current @_ + +sub eval { + eval "$usercontext $evalarg; &DB'save"; + print OUT $@; +} + +sub action { + local($action) = @_; + while ($action =~ s/\\$//) { + print OUT "+ "; + $action .= &gets; + } + $action; +} + +sub gets { + local($.); + ; +} + +sub catch { + $signal = 1; +} + +sub sub { + push(@stack, $single); + $single &= 1; + $single |= 4 if $#stack == $deep; + if (wantarray) { + @i = &$sub; + $single |= pop(@stack); + @i; + } + else { + $i = &$sub; + $single |= pop(@stack); + $i; + } +} + +$single = 1; # so it stops on first executable statement +@hist = ('?'); +$SIG{'INT'} = "DB'catch"; +$deep = 100; # warning if stack gets this deep +$window = 10; +$preview = 3; + +@stack = (0); +@ARGS = @ARGV; +for (@args) { + s/'/\\'/g; + s/(.*)/'$1'/ unless /^-?[\d.]+$/; +} + +if (-f '.perldb') { + do './.perldb'; +} +elsif (-f "$ENV{'LOGDIR'}/.perldb") { + do "$ENV{'LOGDIR'}/.perldb"; +} +elsif (-f "$ENV{'HOME'}/.perldb") { + do "$ENV{'HOME'}/.perldb"; +} + +1; diff --git a/gnu/usr.bin/perl/emacs/tedstuff b/gnu/usr.bin/perl/emacs/tedstuff new file mode 100644 index 0000000..257bbc8 --- /dev/null +++ b/gnu/usr.bin/perl/emacs/tedstuff @@ -0,0 +1,296 @@ +Article 4417 of comp.lang.perl: +Path: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf +From: ted@evi.com (Ted Stefanik) +Newsgroups: comp.lang.perl +Subject: Correction to Perl fatal error marking in GNU Emacs +Message-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU> +Date: 27 Feb 91 06:58:53 GMT +Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System) +Reply-To: ted@evi.com (Ted Stefanik) +Organization: The Internet +Lines: 282 + +Reading my own message, it occurred to me that I didn't quite satisfy the +request of stef@zweig.sun (Stephane Payrard): + +| Does anyone has extended perdb/perdb.el to position the +| point to the first syntax error? It would be cool. + +What I posted is a way to use the "M-x compile" command to test perl scripts. +(Needless to say, the script cannot be not interactive; you can't provide input +to a *compilation* buffer). When creating new Perl programs, I use "M-x +compile" until I'm sure that they are syntatically correct; if syntax errors +occur, C-x` takes me to each in sequence. After I'm sure the syntax is +correct, I start worrying about semantics, and switch to "M-x perldb" if +necessary. + +Therefore, the stuff I posted works great with "M-x compile", but not at all +with "M-x perldb". + +Next, let me update what I posted. I found that perl's die() command doesn't +print the same format error message as perl does when it dies with a syntax +error. If you put the following in your ".emacs" file, it causes C-x` to +recognize both kinds of errors: + +(load-library "compile") +(setq compilation-error-regexp + "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)") + +Last, so I don't look like a total fool, let me propose a way to satisfy +Stephane Payrard's original request (repeated again): + +| Does anyone has extended perdb/perdb.el to position the +| point to the first syntax error? It would be cool. + +I'm not satisfied with just the "first syntax error". Perl's parser is better +than most about not getting out of sync; therefore, if it reports multiple +errors, you can usually be assured they are all real errors. + +So... I hacked in the "next-error" function from "compile.el" to form +"perldb-next-error". You can apply the patches at the end of this message +to add "perldb-next-error" to your "perldb.el". + +Notes: + 1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift + of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS). + + 2) "next-error" is meant to work on a single *compilation* buffer; any new + "M-x compile" or "M-x grep" command will clear the old *compilation* + buffer and reset the compilation-error parser to start at the top of the + *compilation* buffer. + + "perldb-next-error", on the other hand, has to deal with multiple + *perldb-* buffers, each of which keep growing. "perldb-next-error" + correctly handles the constantly growing *perldb-* buffers by + keeping track of the last reported error in the "current-perldb-buffer". + + Sadly however, when you invoke a new "M-x perldb" on a different Perl + script, "perldb-next-error" will start parsing the new *perldb-* + buffer at the top (even if it was previously parsed), and will completely + lose the marker of the last reported error in *perldb-*. + + 3) "perldb-next-error" still uses "compilation-error-regexp" to find + fatal errors. Therefore, both the "M-x compile"/C-x` scheme and + the "M-x perldb"/C-x~ scheme can be used to find fatal errors that + match the common "compilation-error-regexp". You *will* want to install + that "compilation-error-regexp" stuff into your .emacs file. + + 4) The patch was developed and tested with GNU Emacs 18.55. + + 5) Since the patch was ripped off from compile.el, the code is (of + course) subject to the GNU copyleft. + +*** perldb.el.orig Wed Feb 27 00:44:27 1991 +--- perldb.el Wed Feb 27 00:44:30 1991 +*************** +*** 199,205 **** + + (defun perldb-set-buffer () + (cond ((eq major-mode 'perldb-mode) +! (setq current-perldb-buffer (current-buffer))))) + + ;; This function is responsible for inserting output from Perl + ;; into the buffer. +--- 199,211 ---- + + (defun perldb-set-buffer () + (cond ((eq major-mode 'perldb-mode) +! (cond ((not (eq current-perldb-buffer (current-buffer))) +! (perldb-forget-errors) +! (setq perldb-parsing-end 2)) ;; 2 to defeat grep defeater +! (t +! (if (> perldb-parsing-end (point-max)) +! (setq perldb-parsing-end (max (point-max) 2))))) +! (setq current-perldb-buffer (current-buffer))))) + + ;; This function is responsible for inserting output from Perl + ;; into the buffer. +*************** +*** 291,297 **** + ;; process-buffer is current-buffer + (unwind-protect + (progn +! ;; Write something in *compilation* and hack its mode line, + (set-buffer (process-buffer proc)) + ;; Force mode line redisplay soon + (set-buffer-modified-p (buffer-modified-p)) +--- 297,303 ---- + ;; process-buffer is current-buffer + (unwind-protect + (progn +! ;; Write something in *perldb-* and hack its mode line, + (set-buffer (process-buffer proc)) + ;; Force mode line redisplay soon + (set-buffer-modified-p (buffer-modified-p)) +*************** +*** 421,423 **** +--- 427,593 ---- + (switch-to-buffer-other-window current-perldb-buffer) + (goto-char (dot-max)) + (insert-string comm))) ++ ++ (defvar perldb-error-list nil ++ "List of error message descriptors for visiting erring functions. ++ Each error descriptor is a list of length two. ++ Its car is a marker pointing to an error message. ++ Its cadr is a marker pointing to the text of the line the message is about, ++ or nil if that is not interesting. ++ The value may be t instead of a list; ++ this means that the buffer of error messages should be reparsed ++ the next time the list of errors is wanted.") ++ ++ (defvar perldb-parsing-end nil ++ "Position of end of buffer when last error messages parsed.") ++ ++ (defvar perldb-error-message "No more fatal Perl errors" ++ "Message to print when no more matches for compilation-error-regexp are found") ++ ++ (defun perldb-next-error (&optional argp) ++ "Visit next perldb error message and corresponding source code. ++ This operates on the output from the \\[perldb] command. ++ If all preparsed error messages have been processed, ++ the error message buffer is checked for new ones. ++ A non-nil argument (prefix arg, if interactive) ++ means reparse the error message buffer and start at the first error." ++ (interactive "P") ++ (if (or (eq perldb-error-list t) ++ argp) ++ (progn (perldb-forget-errors) ++ (setq perldb-parsing-end 2))) ;; 2 to defeat grep defeater ++ (if perldb-error-list ++ nil ++ (save-excursion ++ (switch-to-buffer current-perldb-buffer) ++ (perldb-parse-errors))) ++ (let ((next-error (car perldb-error-list))) ++ (if (null next-error) ++ (error (concat perldb-error-message ++ (if (and (get-buffer-process current-perldb-buffer) ++ (eq (process-status ++ (get-buffer-process ++ current-perldb-buffer)) ++ 'run)) ++ " yet" "")))) ++ (setq perldb-error-list (cdr perldb-error-list)) ++ (if (null (car (cdr next-error))) ++ nil ++ (switch-to-buffer (marker-buffer (car (cdr next-error)))) ++ (goto-char (car (cdr next-error))) ++ (set-marker (car (cdr next-error)) nil)) ++ (let* ((pop-up-windows t) ++ (w (display-buffer (marker-buffer (car next-error))))) ++ (set-window-point w (car next-error)) ++ (set-window-start w (car next-error))) ++ (set-marker (car next-error) nil))) ++ ++ ;; Set perldb-error-list to nil, and ++ ;; unchain the markers that point to the error messages and their text, ++ ;; so that they no longer slow down gap motion. ++ ;; This would happen anyway at the next garbage collection, ++ ;; but it is better to do it right away. ++ (defun perldb-forget-errors () ++ (if (eq perldb-error-list t) ++ (setq perldb-error-list nil)) ++ (while perldb-error-list ++ (let ((next-error (car perldb-error-list))) ++ (set-marker (car next-error) nil) ++ (if (car (cdr next-error)) ++ (set-marker (car (cdr next-error)) nil))) ++ (setq perldb-error-list (cdr perldb-error-list)))) ++ ++ (defun perldb-parse-errors () ++ "Parse the current buffer as error messages. ++ This makes a list of error descriptors, perldb-error-list. ++ For each source-file, line-number pair in the buffer, ++ the source file is read in, and the text location is saved in perldb-error-list. ++ The function next-error, assigned to \\[next-error], takes the next error off the list ++ and visits its location." ++ (setq perldb-error-list nil) ++ (message "Parsing error messages...") ++ (let (text-buffer ++ last-filename last-linenum) ++ ;; Don't reparse messages already seen at last parse. ++ (goto-char perldb-parsing-end) ++ ;; Don't parse the first two lines as error messages. ++ ;; This matters for grep. ++ (if (bobp) ++ (forward-line 2)) ++ (while (re-search-forward compilation-error-regexp nil t) ++ (let (linenum filename ++ error-marker text-marker) ++ ;; Extract file name and line number from error message. ++ (save-restriction ++ (narrow-to-region (match-beginning 0) (match-end 0)) ++ (goto-char (point-max)) ++ (skip-chars-backward "[0-9]") ++ ;; If it's a lint message, use the last file(linenum) on the line. ++ ;; Normally we use the first on the line. ++ (if (= (preceding-char) ?\() ++ (progn ++ (narrow-to-region (point-min) (1+ (buffer-size))) ++ (end-of-line) ++ (re-search-backward compilation-error-regexp) ++ (skip-chars-backward "^ \t\n") ++ (narrow-to-region (point) (match-end 0)) ++ (goto-char (point-max)) ++ (skip-chars-backward "[0-9]"))) ++ ;; Are we looking at a "filename-first" or "line-number-first" form? ++ (if (looking-at "[0-9]") ++ (progn ++ (setq linenum (read (current-buffer))) ++ (goto-char (point-min))) ++ ;; Line number at start, file name at end. ++ (progn ++ (goto-char (point-min)) ++ (setq linenum (read (current-buffer))) ++ (goto-char (point-max)) ++ (skip-chars-backward "^ \t\n"))) ++ (setq filename (perldb-grab-filename))) ++ ;; Locate the erring file and line. ++ (if (and (equal filename last-filename) ++ (= linenum last-linenum)) ++ nil ++ (beginning-of-line 1) ++ (setq error-marker (point-marker)) ++ ;; text-buffer gets the buffer containing this error's file. ++ (if (not (equal filename last-filename)) ++ (setq text-buffer ++ (and (file-exists-p (setq last-filename filename)) ++ (find-file-noselect filename)) ++ last-linenum 0)) ++ (if text-buffer ++ ;; Go to that buffer and find the erring line. ++ (save-excursion ++ (set-buffer text-buffer) ++ (if (zerop last-linenum) ++ (progn ++ (goto-char 1) ++ (setq last-linenum 1))) ++ (forward-line (- linenum last-linenum)) ++ (setq last-linenum linenum) ++ (setq text-marker (point-marker)) ++ (setq perldb-error-list ++ (cons (list error-marker text-marker) ++ perldb-error-list))))) ++ (forward-line 1))) ++ (setq perldb-parsing-end (point-max))) ++ (message "Parsing error messages...done") ++ (setq perldb-error-list (nreverse perldb-error-list))) ++ ++ (defun perldb-grab-filename () ++ "Return a string which is a filename, starting at point. ++ Ignore quotes and parentheses around it, as well as trailing colons." ++ (if (eq (following-char) ?\") ++ (save-restriction ++ (narrow-to-region (point) ++ (progn (forward-sexp 1) (point))) ++ (goto-char (point-min)) ++ (read (current-buffer))) ++ (buffer-substring (point) ++ (progn ++ (skip-chars-forward "^ :,\n\t(") ++ (point))))) ++ ++ (define-key ctl-x-map "~" 'perldb-next-error) + + diff --git a/gnu/usr.bin/perl/h2pl/README b/gnu/usr.bin/perl/h2pl/README new file mode 100644 index 0000000..5fe8ae7 --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/README @@ -0,0 +1,71 @@ +[This file of Tom Christiansen's has been edited to change makelib to h2ph +and .h to .ph where appropriate--law.] + +This directory contains files to help you convert the *.ph files generated my +h2ph out of the perl source directory into *.pl files with all the +indirection of the subroutine calls removed. The .ph version will be more +safely portable, because if something isn't defined on the new system, like +&TIOCGETP, then you'll get a fatal run-time error on the system lacking that +function. Using the .pl version means that the subsequent scripts will give +you a 0 $TIOCGETP and God only knows what may then happen. Still, I like the +.pl stuff because they're faster to load. + +FIrst, you need to run h2ph on things like sys/ioctl.h to get stuff +into the perl library directory, often /usr/local/lib/perl. For example, + # h2ph sys/ioctl.h +takes /usr/include/sys/ioctl.h as input and writes (without i/o redirection) +the file /usr/local/lib/perl/sys/ioctl.ph, which looks like this + + eval 'sub TIOCM_RTS {0004;}'; + eval 'sub TIOCM_ST {0010;}'; + eval 'sub TIOCM_SR {0020;}'; + eval 'sub TIOCM_CTS {0040;}'; + eval 'sub TIOCM_CAR {0100;}'; + +and much worse, rather than what Larry's ioctl.pl from the perl source dir has, +which is: + + $TIOCM_RTS = 0004; + $TIOCM_ST = 0010; + $TIOCM_SR = 0020; + $TIOCM_CTS = 0040; + $TIOCM_CAR = 0100; + +[Workaround for fixed bug in makedir/h2ph deleted--law.] + +The more complicated ioctl subs look like this: + + eval 'sub TIOCGSIZE {&TIOCGWINSZ;}'; + eval 'sub TIOCGWINSZ {&_IOR("t", 104, \'struct winsize\');}'; + eval 'sub TIOCSETD {&_IOW("t", 1, \'int\');}'; + eval 'sub TIOCGETP {&_IOR("t", 8,\'struct sgttyb\');}'; + +The _IO[RW] routines use a %sizeof array, which (presumably) +is keyed on the type name with the value being the size in bytes. + +To build %sizeof, try running this in this directory: + + % ./getioctlsizes + +Which will tell you which things the %sizeof array needs +to hold. You can try to build a sizeof.ph file with: + + % ./getioctlsizes | ./mksizes > sizeof.ph + +Note that mksizes hardcodes the #include files for all the types, so it will +probably require customization. Once you have sizeof.ph, install it in the +perl library directory. Run my tcbreak script to see whether you can do +ioctls in perl now. You'll get some kind of fatal run-time error if you +can't. That script should be included in this directory. + +If this works well, now you can try to convert the *.ph files into +*.pl files. Try this: + + foreach file ( sysexits.ph sys/{errno.ph,ioctl.ph} ) + ./mkvars $file > t/$file:r.pl + end + +The last one will be the hardest. If it works, should be able to +run tcbreak2 and have it work the same as tcbreak. + +Good luck. diff --git a/gnu/usr.bin/perl/h2pl/cbreak.pl b/gnu/usr.bin/perl/h2pl/cbreak.pl new file mode 100644 index 0000000..422185e --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/cbreak.pl @@ -0,0 +1,34 @@ +$sgttyb_t = 'C4 S'; + +sub cbreak { + &set_cbreak(1); +} + +sub cooked { + &set_cbreak(0); +} + +sub set_cbreak { + local($on) = @_; + + require 'sizeof.ph'; + require 'sys/ioctl.ph'; + + ioctl(STDIN,&TIOCGETP,$sgttyb) + || die "Can't ioctl TIOCGETP: $!"; + + @ary = unpack($sgttyb_t,$sgttyb); + if ($on) { + $ary[4] |= &CBREAK; + $ary[4] &= ~&ECHO; + } else { + $ary[4] &= ~&CBREAK; + $ary[4] |= &ECHO; + } + $sgttyb = pack($sgttyb_t,@ary); + ioctl(STDIN,&TIOCSETP,$sgttyb) + || die "Can't ioctl TIOCSETP: $!"; + +} + +1; diff --git a/gnu/usr.bin/perl/h2pl/cbreak2.pl b/gnu/usr.bin/perl/h2pl/cbreak2.pl new file mode 100644 index 0000000..8ac55a3 --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/cbreak2.pl @@ -0,0 +1,33 @@ +$sgttyb_t = 'C4 S'; + +sub cbreak { + &set_cbreak(1); +} + +sub cooked { + &set_cbreak(0); +} + +sub set_cbreak { + local($on) = @_; + + require 'sys/ioctl.pl'; + + ioctl(STDIN,$TIOCGETP,$sgttyb) + || die "Can't ioctl TIOCGETP: $!"; + + @ary = unpack($sgttyb_t,$sgttyb); + if ($on) { + $ary[4] |= $CBREAK; + $ary[4] &= ~$ECHO; + } else { + $ary[4] &= ~$CBREAK; + $ary[4] |= $ECHO; + } + $sgttyb = pack($sgttyb_t,@ary); + ioctl(STDIN,$TIOCSETP,$sgttyb) + || die "Can't ioctl TIOCSETP: $!"; + +} + +1; diff --git a/gnu/usr.bin/perl/h2pl/eg/sizeof.ph b/gnu/usr.bin/perl/h2pl/eg/sizeof.ph new file mode 100644 index 0000000..285bff1 --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/eg/sizeof.ph @@ -0,0 +1,14 @@ +$sizeof{'char'} = 1; +$sizeof{'int'} = 4; +$sizeof{'long'} = 4; +$sizeof{'struct arpreq'} = 36; +$sizeof{'struct ifconf'} = 8; +$sizeof{'struct ifreq'} = 32; +$sizeof{'struct ltchars'} = 6; +$sizeof{'struct pcntl'} = 116; +$sizeof{'struct rtentry'} = 52; +$sizeof{'struct sgttyb'} = 6; +$sizeof{'struct tchars'} = 6; +$sizeof{'struct ttychars'} = 14; +$sizeof{'struct winsize'} = 8; +$sizeof{'struct termios'} = 132; diff --git a/gnu/usr.bin/perl/h2pl/eg/sys/errno.pl b/gnu/usr.bin/perl/h2pl/eg/sys/errno.pl new file mode 100644 index 0000000..d9ba3be --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/eg/sys/errno.pl @@ -0,0 +1,92 @@ +$EPERM = 0x1; +$ENOENT = 0x2; +$ESRCH = 0x3; +$EINTR = 0x4; +$EIO = 0x5; +$ENXIO = 0x6; +$E2BIG = 0x7; +$ENOEXEC = 0x8; +$EBADF = 0x9; +$ECHILD = 0xA; +$EAGAIN = 0xB; +$ENOMEM = 0xC; +$EACCES = 0xD; +$EFAULT = 0xE; +$ENOTBLK = 0xF; +$EBUSY = 0x10; +$EEXIST = 0x11; +$EXDEV = 0x12; +$ENODEV = 0x13; +$ENOTDIR = 0x14; +$EISDIR = 0x15; +$EINVAL = 0x16; +$ENFILE = 0x17; +$EMFILE = 0x18; +$ENOTTY = 0x19; +$ETXTBSY = 0x1A; +$EFBIG = 0x1B; +$ENOSPC = 0x1C; +$ESPIPE = 0x1D; +$EROFS = 0x1E; +$EMLINK = 0x1F; +$EPIPE = 0x20; +$EDOM = 0x21; +$ERANGE = 0x22; +$EWOULDBLOCK = 0x23; +$EINPROGRESS = 0x24; +$EALREADY = 0x25; +$ENOTSOCK = 0x26; +$EDESTADDRREQ = 0x27; +$EMSGSIZE = 0x28; +$EPROTOTYPE = 0x29; +$ENOPROTOOPT = 0x2A; +$EPROTONOSUPPORT = 0x2B; +$ESOCKTNOSUPPORT = 0x2C; +$EOPNOTSUPP = 0x2D; +$EPFNOSUPPORT = 0x2E; +$EAFNOSUPPORT = 0x2F; +$EADDRINUSE = 0x30; +$EADDRNOTAVAIL = 0x31; +$ENETDOWN = 0x32; +$ENETUNREACH = 0x33; +$ENETRESET = 0x34; +$ECONNABORTED = 0x35; +$ECONNRESET = 0x36; +$ENOBUFS = 0x37; +$EISCONN = 0x38; +$ENOTCONN = 0x39; +$ESHUTDOWN = 0x3A; +$ETOOMANYREFS = 0x3B; +$ETIMEDOUT = 0x3C; +$ECONNREFUSED = 0x3D; +$ELOOP = 0x3E; +$ENAMETOOLONG = 0x3F; +$EHOSTDOWN = 0x40; +$EHOSTUNREACH = 0x41; +$ENOTEMPTY = 0x42; +$EPROCLIM = 0x43; +$EUSERS = 0x44; +$EDQUOT = 0x45; +$ESTALE = 0x46; +$EREMOTE = 0x47; +$EDEADLK = 0x48; +$ENOLCK = 0x49; +$MTH_UNDEF_SQRT = 0x12C; +$MTH_OVF_EXP = 0x12D; +$MTH_UNDEF_LOG = 0x12E; +$MTH_NEG_BASE = 0x12F; +$MTH_ZERO_BASE = 0x130; +$MTH_OVF_POW = 0x131; +$MTH_LRG_SIN = 0x132; +$MTH_LRG_COS = 0x133; +$MTH_LRG_TAN = 0x134; +$MTH_LRG_COT = 0x135; +$MTH_OVF_TAN = 0x136; +$MTH_OVF_COT = 0x137; +$MTH_UNDEF_ASIN = 0x138; +$MTH_UNDEF_ACOS = 0x139; +$MTH_UNDEF_ATAN2 = 0x13A; +$MTH_OVF_SINH = 0x13B; +$MTH_OVF_COSH = 0x13C; +$MTH_UNDEF_ZLOG = 0x13D; +$MTH_UNDEF_ZDIV = 0x13E; diff --git a/gnu/usr.bin/perl/h2pl/eg/sys/ioctl.pl b/gnu/usr.bin/perl/h2pl/eg/sys/ioctl.pl new file mode 100644 index 0000000..0b552ca --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/eg/sys/ioctl.pl @@ -0,0 +1,186 @@ +$_IOCTL_ = 0x1; +$TIOCGSIZE = 0x40087468; +$TIOCSSIZE = 0x80087467; +$IOCPARM_MASK = 0x7F; +$IOC_VOID = 0x20000000; +$IOC_OUT = 0x40000000; +$IOC_IN = 0x80000000; +$IOC_INOUT = 0xC0000000; +$TIOCGETD = 0x40047400; +$TIOCSETD = 0x80047401; +$TIOCHPCL = 0x20007402; +$TIOCMODG = 0x40047403; +$TIOCMODS = 0x80047404; +$TIOCM_LE = 0x1; +$TIOCM_DTR = 0x2; +$TIOCM_RTS = 0x4; +$TIOCM_ST = 0x8; +$TIOCM_SR = 0x10; +$TIOCM_CTS = 0x20; +$TIOCM_CAR = 0x40; +$TIOCM_CD = 0x40; +$TIOCM_RNG = 0x80; +$TIOCM_RI = 0x80; +$TIOCM_DSR = 0x100; +$TIOCGETP = 0x40067408; +$TIOCSETP = 0x80067409; +$TIOCSETN = 0x8006740A; +$TIOCEXCL = 0x2000740D; +$TIOCNXCL = 0x2000740E; +$TIOCFLUSH = 0x80047410; +$TIOCSETC = 0x80067411; +$TIOCGETC = 0x40067412; +$TIOCSET = 0x80047413; +$TIOCBIS = 0x80047414; +$TIOCBIC = 0x80047415; +$TIOCGET = 0x40047416; +$TANDEM = 0x1; +$CBREAK = 0x2; +$LCASE = 0x4; +$ECHO = 0x8; +$CRMOD = 0x10; +$RAW = 0x20; +$ODDP = 0x40; +$EVENP = 0x80; +$ANYP = 0xC0; +$NLDELAY = 0x300; +$NL0 = 0x0; +$NL1 = 0x100; +$NL2 = 0x200; +$NL3 = 0x300; +$TBDELAY = 0xC00; +$TAB0 = 0x0; +$TAB1 = 0x400; +$TAB2 = 0x800; +$XTABS = 0xC00; +$CRDELAY = 0x3000; +$CR0 = 0x0; +$CR1 = 0x1000; +$CR2 = 0x2000; +$CR3 = 0x3000; +$VTDELAY = 0x4000; +$FF0 = 0x0; +$FF1 = 0x4000; +$BSDELAY = 0x8000; +$BS0 = 0x0; +$BS1 = 0x8000; +$ALLDELAY = 0xFF00; +$CRTBS = 0x10000; +$PRTERA = 0x20000; +$CRTERA = 0x40000; +$TILDE = 0x80000; +$MDMBUF = 0x100000; +$LITOUT = 0x200000; +$TOSTOP = 0x400000; +$FLUSHO = 0x800000; +$NOHANG = 0x1000000; +$L001000 = 0x2000000; +$CRTKIL = 0x4000000; +$L004000 = 0x8000000; +$CTLECH = 0x10000000; +$PENDIN = 0x20000000; +$DECCTQ = 0x40000000; +$NOFLSH = 0x80000000; +$TIOCCSET = 0x800E7417; +$TIOCCGET = 0x400E7418; +$TIOCLBIS = 0x8004747F; +$TIOCLBIC = 0x8004747E; +$TIOCLSET = 0x8004747D; +$TIOCLGET = 0x4004747C; +$LCRTBS = 0x1; +$LPRTERA = 0x2; +$LCRTERA = 0x4; +$LTILDE = 0x8; +$LMDMBUF = 0x10; +$LLITOUT = 0x20; +$LTOSTOP = 0x40; +$LFLUSHO = 0x80; +$LNOHANG = 0x100; +$LCRTKIL = 0x400; +$LCTLECH = 0x1000; +$LPENDIN = 0x2000; +$LDECCTQ = 0x4000; +$LNOFLSH = 0x8000; +$TIOCSBRK = 0x2000747B; +$TIOCCBRK = 0x2000747A; +$TIOCSDTR = 0x20007479; +$TIOCCDTR = 0x20007478; +$TIOCGPGRP = 0x40047477; +$TIOCSPGRP = 0x80047476; +$TIOCSLTC = 0x80067475; +$TIOCGLTC = 0x40067474; +$TIOCOUTQ = 0x40047473; +$TIOCSTI = 0x80017472; +$TIOCNOTTY = 0x20007471; +$TIOCPKT = 0x80047470; +$TIOCPKT_DATA = 0x0; +$TIOCPKT_FLUSHREAD = 0x1; +$TIOCPKT_FLUSHWRITE = 0x2; +$TIOCPKT_STOP = 0x4; +$TIOCPKT_START = 0x8; +$TIOCPKT_NOSTOP = 0x10; +$TIOCPKT_DOSTOP = 0x20; +$TIOCSTOP = 0x2000746F; +$TIOCSTART = 0x2000746E; +$TIOCREMOTE = 0x20007469; +$TIOCGWINSZ = 0x40087468; +$TIOCSWINSZ = 0x80087467; +$TIOCRESET = 0x20007466; +$OTTYDISC = 0x0; +$NETLDISC = 0x1; +$NTTYDISC = 0x2; +$FIOCLEX = 0x20006601; +$FIONCLEX = 0x20006602; +$FIONREAD = 0x4004667F; +$FIONBIO = 0x8004667E; +$FIOASYNC = 0x8004667D; +$FIOSETOWN = 0x8004667C; +$FIOGETOWN = 0x4004667B; +$STPUTTABLE = 0x8004667A; +$STGETTABLE = 0x80046679; +$SIOCSHIWAT = 0x80047300; +$SIOCGHIWAT = 0x40047301; +$SIOCSLOWAT = 0x80047302; +$SIOCGLOWAT = 0x40047303; +$SIOCATMARK = 0x40047307; +$SIOCSPGRP = 0x80047308; +$SIOCGPGRP = 0x40047309; +$SIOCADDRT = 0x8034720A; +$SIOCDELRT = 0x8034720B; +$SIOCSIFADDR = 0x8020690C; +$SIOCGIFADDR = 0xC020690D; +$SIOCSIFDSTADDR = 0x8020690E; +$SIOCGIFDSTADDR = 0xC020690F; +$SIOCSIFFLAGS = 0x80206910; +$SIOCGIFFLAGS = 0xC0206911; +$SIOCGIFBRDADDR = 0xC0206912; +$SIOCSIFBRDADDR = 0x80206913; +$SIOCGIFCONF = 0xC0086914; +$SIOCGIFNETMASK = 0xC0206915; +$SIOCSIFNETMASK = 0x80206916; +$SIOCGIFMETRIC = 0xC0206917; +$SIOCSIFMETRIC = 0x80206918; +$SIOCSARP = 0x8024691E; +$SIOCGARP = 0xC024691F; +$SIOCDARP = 0x80246920; +$PIXCONTINUE = 0x80747000; +$PIXSTEP = 0x80747001; +$PIXTERMINATE = 0x20007002; +$PIGETFLAGS = 0x40747003; +$PIXINHERIT = 0x80747004; +$PIXDETACH = 0x20007005; +$PIXGETSUBCODE = 0xC0747006; +$PIXRDREGS = 0xC0747007; +$PIXWRREGS = 0xC0747008; +$PIXRDVREGS = 0xC0747009; +$PIXWRVREGS = 0xC074700A; +$PIXRDVSTATE = 0xC074700B; +$PIXWRVSTATE = 0xC074700C; +$PIXRDCREGS = 0xC074700D; +$PIXWRCREGS = 0xC074700E; +$PIRDSDRS = 0xC074700F; +$PIXGETSIGACTION = 0xC0747010; +$PIGETU = 0xC0747011; +$PISETRWTID = 0xC0747012; +$PIXGETTHCOUNT = 0xC0747013; +$PIXRUN = 0x20007014; diff --git a/gnu/usr.bin/perl/h2pl/eg/sysexits.pl b/gnu/usr.bin/perl/h2pl/eg/sysexits.pl new file mode 100644 index 0000000..f4cb777 --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/eg/sysexits.pl @@ -0,0 +1,16 @@ +$EX_OK = 0x0; +$EX__BASE = 0x40; +$EX_USAGE = 0x40; +$EX_DATAERR = 0x41; +$EX_NOINPUT = 0x42; +$EX_NOUSER = 0x43; +$EX_NOHOST = 0x44; +$EX_UNAVAILABLE = 0x45; +$EX_SOFTWARE = 0x46; +$EX_OSERR = 0x47; +$EX_OSFILE = 0x48; +$EX_CANTCREAT = 0x49; +$EX_IOERR = 0x4A; +$EX_TEMPFAIL = 0x4B; +$EX_PROTOCOL = 0x4C; +$EX_NOPERM = 0x4D; diff --git a/gnu/usr.bin/perl/h2pl/getioctlsizes b/gnu/usr.bin/perl/h2pl/getioctlsizes new file mode 100644 index 0000000..403fffa --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/getioctlsizes @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed"; + +while () { + if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\('?\w+'?,\s*\w+,\s*([^)]+)/) { + $need{$2}++; + } +} + +foreach $key ( sort keys %need ) { + print $key,"\n"; +} diff --git a/gnu/usr.bin/perl/h2pl/mksizes b/gnu/usr.bin/perl/h2pl/mksizes new file mode 100644 index 0000000..cb4b8ab --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/mksizes @@ -0,0 +1,42 @@ +#!/usr/local/bin/perl + +($iam = $0) =~ s%.*/%%; +$tmp = "$iam.$$"; +open (CODE,">$tmp.c") || die "$iam: cannot create $tmp.c: $!\n"; + +$mask = q/printf ("$sizeof{'%s'} = %d;\n"/; + +# write C program +select(CODE); + +print < +#include +#include +#include +#include +#include +#include + +main() { +EO_C_PROGRAM + +while ( <> ) { + chop; + printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_; +} + +print "\n}\n"; + +close CODE; + +# compile C program + +select(STDOUT); + +system "cc $tmp.c -o $tmp"; +die "couldn't compile $tmp.c" if $?; +system "./$tmp"; +die "couldn't run $tmp" if $?; + +unlink "$tmp.c", $tmp; diff --git a/gnu/usr.bin/perl/h2pl/mkvars b/gnu/usr.bin/perl/h2pl/mkvars new file mode 100644 index 0000000..ffb0f0b --- /dev/null +++ b/gnu/usr.bin/perl/h2pl/mkvars @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +require 'sizeof.ph'; + +$LIB = '/usr/local/lib/perl'; + +foreach $include (@ARGV) { + printf STDERR "including %s\n", $include; + do $include; + warn "sourcing $include: $@\n" if ($@); + if (!open (INCLUDE,"$LIB/$include")) { + warn "can't open $LIB/$include: $!\n"; + next; + } + while () { + chop; + if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) { + $var = $1; + $val = eval "&$var;"; + if ($@) { + warn "$@: $_"; + print < + + diff --git a/gnu/usr.bin/perl/lib/abbrev.pl b/gnu/usr.bin/perl/lib/abbrev.pl new file mode 100644 index 0000000..c233d4a --- /dev/null +++ b/gnu/usr.bin/perl/lib/abbrev.pl @@ -0,0 +1,33 @@ +;# Usage: +;# %foo = (); +;# &abbrev(*foo,LIST); +;# ... +;# $long = $foo{$short}; + +package abbrev; + +sub main'abbrev { + local(*domain) = @_; + shift(@_); + @cmp = @_; + local($[) = 0; + foreach $name (@_) { + @extra = split(//,$name); + $abbrev = shift(@extra); + $len = 1; + foreach $cmp (@cmp) { + next if $cmp eq $name; + while (substr($cmp,0,$len) eq $abbrev) { + $abbrev .= shift(@extra); + ++$len; + } + } + $domain{$abbrev} = $name; + while ($#extra >= 0) { + $abbrev .= shift(@extra); + $domain{$abbrev} = $name; + } + } +} + +1; diff --git a/gnu/usr.bin/perl/lib/assert.pl b/gnu/usr.bin/perl/lib/assert.pl new file mode 100644 index 0000000..cfda70c --- /dev/null +++ b/gnu/usr.bin/perl/lib/assert.pl @@ -0,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; diff --git a/gnu/usr.bin/perl/lib/bigfloat.pl b/gnu/usr.bin/perl/lib/bigfloat.pl new file mode 100644 index 0000000..278f11d --- /dev/null +++ b/gnu/usr.bin/perl/lib/bigfloat.pl @@ -0,0 +1,233 @@ +package bigfloat; +require "bigint.pl"; +# Arbitrary length float math package +# +# by Mark Biggar +# +# number format +# canonical strings have the form /[+-]\d+E[+-]\d+/ +# Input values can have inbedded whitespace +# Error returns +# 'NaN' An input parameter was "Not a Number" or +# divide by zero or sqrt of negative number +# Division is computed to +# max($div_scale,length(dividend).length(divisor)) +# digits by default. +# Also used for default sqrt scale + +$div_scale = 40; + +# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'. + +$rnd_mode = 'even'; + +# bigfloat routines +# +# fadd(NSTR, NSTR) return NSTR addition +# fsub(NSTR, NSTR) return NSTR subtraction +# fmul(NSTR, NSTR) return NSTR multiplication +# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places +# fneg(NSTR) return NSTR negation +# fabs(NSTR) return NSTR absolute value +# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0 +# fround(NSTR, SCALE) return NSTR round to SCALE digits +# ffround(NSTR, SCALE) return NSTR round at SCALEth place +# fnorm(NSTR) return (NSTR) normalize +# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places + +# Convert a number to canonical string form. +# Takes something that looks like a number and converts it to +# the form /^[+-]\d+E[+-]\d+$/. +sub main'fnorm { #(string) return fnum_str + local($_) = @_; + s/\s+//g; # strip white space + if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') { + &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6)); + } else { + 'NaN'; + } +} + +# normalize number -- for internal use +sub norm { #(mantissa, exponent) return fnum_str + local($_, $exp) = @_; + if ($_ eq 'NaN') { + 'NaN'; + } else { + s/^([+-])0+/$1/; # strip leading zeros + if (length($_) == 1) { + '+0E+0'; + } else { + $exp += length($1) if (s/(0+)$//); # strip trailing zeros + sprintf("%sE%+ld", $_, $exp); + } + } +} + +# negation +sub main'fneg { #(fnum_str) return fnum_str + local($_) = &'fnorm($_[0]); + vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign + s/^H/N/; + $_; +} + +# absolute value +sub main'fabs { #(fnum_str) return fnum_str + local($_) = &'fnorm($_[0]); + s/^-/+/; # mash sign + $_; +} + +# multiplication +sub main'fmul { #(fnum_str, fnum_str) return fnum_str + local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1])); + if ($x eq 'NaN' || $y eq 'NaN') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + local($ym,$ye) = split('E',$y); + &norm(&'bmul($xm,$ym),$xe+$ye); + } +} + +# addition +sub main'fadd { #(fnum_str, fnum_str) return fnum_str + local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1])); + if ($x eq 'NaN' || $y eq 'NaN') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + local($ym,$ye) = split('E',$y); + ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye); + &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye); + } +} + +# subtraction +sub main'fsub { #(fnum_str, fnum_str) return fnum_str + &'fadd($_[0],&'fneg($_[1])); +} + +# division +# args are dividend, divisor, scale (optional) +# result has at most max(scale, length(dividend), length(divisor)) digits +sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str +{ + local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]); + if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + local($ym,$ye) = split('E',$y); + $scale = $div_scale if (!$scale); + $scale = length($xm)-1 if (length($xm)-1 > $scale); + $scale = length($ym)-1 if (length($ym)-1 > $scale); + $scale = $scale + length($ym) - length($xm); + &norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym), + $xe-$ye-$scale); + } +} + +# round int $q based on fraction $r/$base using $rnd_mode +sub round { #(int_str, int_str, int_str) return int_str + local($q,$r,$base) = @_; + if ($q eq 'NaN' || $r eq 'NaN') { + 'NaN'; + } elsif ($rnd_mode eq 'trunc') { + $q; # just truncate + } else { + local($cmp) = &'bcmp(&'bmul($r,'+2'),$base); + if ( $cmp < 0 || + ($cmp == 0 && + ( $rnd_mode eq 'zero' || + ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) || + ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) || + ($rnd_mode eq 'even' && $q =~ /[24680]$/) || + ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) { + $q; # round down + } else { + &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1')); + # round up + } + } +} + +# round the mantissa of $x to $scale digits +sub main'fround { #(fnum_str, scale) return fnum_str + local($x,$scale) = (&'fnorm($_[0]),$_[1]); + if ($x eq 'NaN' || $scale <= 0) { + $x; + } else { + local($xm,$xe) = split('E',$x); + if (length($xm)-1 <= $scale) { + $x; + } else { + &norm(&round(substr($xm,0,$scale+1), + "+0".substr($xm,$scale+1,1),"+10"), + $xe+length($xm)-$scale-1); + } + } +} + +# round $x at the 10 to the $scale digit place +sub main'ffround { #(fnum_str, scale) return fnum_str + local($x,$scale) = (&'fnorm($_[0]),$_[1]); + if ($x eq 'NaN') { + 'NaN'; + } else { + local($xm,$xe) = split('E',$x); + if ($xe >= $scale) { + $x; + } else { + $xe = length($xm)+$xe-$scale; + if ($xe < 1) { + '+0E+0'; + } elsif ($xe == 1) { + &norm(&round('+0',"+0".substr($xm,1,1),"+10"), $scale); + } else { + &norm(&round(substr($xm,0,$trunc), + "+0".substr($xm,$trunc,1),"+10"), $scale); + } + } + } +} + +# compare 2 values returns one of undef, <0, =0, >0 +# returns undef if either or both input value are not numbers +sub main'fcmp #(fnum_str, fnum_str) return cond_code +{ + local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1])); + if ($x eq "NaN" || $y eq "NaN") { + undef; + } else { + ord($y) <=> ord($x) + || + ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"), + (($xe <=> $ye) * (substr($x,0,1).'1') + || &bigint'cmp($xm,$ym)) + ); + } +} + +# square root by Newtons method. +sub main'fsqrt { #(fnum_str[, scale]) return fnum_str + local($x, $scale) = (&'fnorm($_[0]), $_[1]); + if ($x eq 'NaN' || $x =~ /^-/) { + 'NaN'; + } elsif ($x eq '+0E+0') { + '+0E+0'; + } else { + local($xm, $xe) = split('E',$x); + $scale = $div_scale if (!$scale); + $scale = length($xm)-1 if ($scale < length($xm)-1); + local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2)); + while ($gs < 2*$scale) { + $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5"); + $gs *= 2; + } + &'fround($guess, $scale); + } +} + +1; diff --git a/gnu/usr.bin/perl/lib/bigint.pl b/gnu/usr.bin/perl/lib/bigint.pl new file mode 100644 index 0000000..5c79da9 --- /dev/null +++ b/gnu/usr.bin/perl/lib/bigint.pl @@ -0,0 +1,271 @@ +package bigint; + +# arbitrary size integer math package +# +# by Mark Biggar +# +# Canonical Big integer value are strings of the form +# /^[+-]\d+$/ with leading zeros suppressed +# Input values to these routines may be strings of the form +# /^\s*[+-]?[\d\s]+$/. +# Examples: +# '+0' canonical zero value +# ' -123 123 123' canonical value '-123123123' +# '1 23 456 7890' canonical value '+1234567890' +# Output values always always in canonical form +# +# Actual math is done in an internal format consisting of an array +# whose first element is the sign (/^[+-]$/) and whose remaining +# elements are base 100000 digits with the least significant digit first. +# The string 'NaN' is used to represent the result when input arguments +# are not numbers, as well as the result of dividing by zero +# +# routines provided are: +# +# bneg(BINT) return BINT negation +# babs(BINT) return BINT absolute value +# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0) +# badd(BINT,BINT) return BINT addition +# bsub(BINT,BINT) return BINT subtraction +# bmul(BINT,BINT) return BINT multiplication +# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar +# bmod(BINT,BINT) return BINT modulus +# bgcd(BINT,BINT) return BINT greatest common divisor +# bnorm(BINT) return BINT normalization +# + +# normalize string form of number. Strip leading zeros. Strip any +# white space and add a sign, if missing. +# Strings that are not numbers result the value 'NaN'. +sub main'bnorm { #(num_str) return num_str + local($_) = @_; + s/\s+//g; # strip white space + if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number + substr($_,0,0) = '+' unless $1; # Add missing sign + s/^-0/+0/; + $_; + } else { + 'NaN'; + } +} + +# Convert a number from string format to internal base 100000 format. +# Assumes normalized value as input. +sub internal { #(num_str) return int_num_array + local($d) = @_; + ($is,$il) = (substr($d,0,1),length($d)-2); + substr($d,0,1) = ''; + ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d))); +} + +# Convert a number from internal base 100000 format to string format. +# This routine scribbles all over input array. +sub external { #(int_num_array) return num_str + $es = shift; + grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad + &'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize +} + +# Negate input value. +sub main'bneg { #(num_str) return num_str + local($_) = &'bnorm(@_); + vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0'; + s/^H/N/; + $_; +} + +# Returns the absolute value of the input. +sub main'babs { #(num_str) return num_str + &abs(&'bnorm(@_)); +} + +sub abs { # post-normalized abs for internal use + local($_) = @_; + s/^-/+/; + $_; +} + +# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) +sub main'bcmp { #(num_str, num_str) return cond_code + local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1])); + if ($x eq 'NaN') { + undef; + } elsif ($y eq 'NaN') { + undef; + } else { + &cmp($x,$y); + } +} + +sub cmp { # post-normalized compare for internal use + local($cx, $cy) = @_; + $cx cmp $cy + && + ( + ord($cy) <=> ord($cx) + || + ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx) + ); +} + +sub main'badd { #(num_str, num_str) return num_str + local(*x, *y); ($x, $y) = (&'bnorm($_[0]),&'bnorm($_[1])); + if ($x eq 'NaN') { + 'NaN'; + } elsif ($y eq 'NaN') { + 'NaN'; + } else { + @x = &internal($x); # convert to internal form + @y = &internal($y); + local($sx, $sy) = (shift @x, shift @y); # get signs + if ($sx eq $sy) { + &external($sx, &add(*x, *y)); # if same sign add + } else { + ($x, $y) = (&abs($x),&abs($y)); # make abs + if (&cmp($y,$x) > 0) { + &external($sy, &sub(*y, *x)); + } else { + &external($sx, &sub(*x, *y)); + } + } + } +} + +sub main'bsub { #(num_str, num_str) return num_str + &'badd($_[0],&'bneg($_[1])); +} + +# GCD -- Euclids algorithm Knuth Vol 2 pg 296 +sub main'bgcd { #(num_str, num_str) return num_str + local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1])); + if ($x eq 'NaN' || $y eq 'NaN') { + 'NaN'; + } else { + ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0'; + $x; + } +} + +# routine to add two base 1e5 numbers +# stolen from Knuth Vol 2 Algorithm A pg 231 +# there are separate routines to add and sub as per Kunth pg 233 +sub add { #(int_num_array, int_num_array) return int_num_array + local(*x, *y) = @_; + $car = 0; + for $x (@x) { + last unless @y || $car; + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); + } + for $y (@y) { + last unless $car; + $y -= 1e5 if $car = (($y += $car) >= 1e5); + } + (@x, @y, $car); +} + +# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y +sub sub { #(int_num_array, int_num_array) return int_num_array + local(*sx, *sy) = @_; + $bar = 0; + for $sx (@sx) { + last unless @y || $bar; + $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); + } + @sx; +} + +# multiply two numbers -- stolen from Knuth Vol 2 pg 233 +sub main'bmul { #(num_str, num_str) return num_str + local(*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1])); + if ($x eq 'NaN') { + 'NaN'; + } elsif ($y eq 'NaN') { + 'NaN'; + } else { + @x = &internal($x); + @y = &internal($y); + local($signr) = (shift @x ne shift @y) ? '-' : '+'; + @prod = (); + for $x (@x) { + ($car, $cty) = (0, 0); + for $y (@y) { + $prod = $x * $y + $prod[$cty] + $car; + $prod[$cty++] = + $prod - ($car = int($prod * 1e-5)) * 1e5; + } + $prod[$cty] += $car if $car; + $x = shift @prod; + } + &external($signr, @x, @prod); + } +} + +# modulus +sub main'bmod { #(num_str, num_str) return num_str + (&'bdiv(@_))[1]; +} + +sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str + local (*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1])); + return wantarray ? ('NaN','NaN') : 'NaN' + if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0'); + return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0); + @x = &internal($x); @y = &internal($y); + $srem = $y[0]; + $sr = (shift @x ne shift @y) ? '-' : '+'; + $car = $bar = $prd = 0; + if (($dd = int(1e5/($y[$#y]+1))) != 1) { + for $x (@x) { + $x = $x * $dd + $car; + $x -= ($car = int($x * 1e-5)) * 1e5; + } + push(@x, $car); $car = 0; + for $y (@y) { + $y = $y * $dd + $car; + $y -= ($car = int($y * 1e-5)) * 1e5; + } + } + else { + push(@x, 0); + } + @q = (); ($v2,$v1) = @y[$#y-1,$#y]; + while ($#x > $#y) { + ($u2,$u1,$u0) = @x[($#x-2)..$#x]; + $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1)); + --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2); + if ($q) { + ($car, $bar) = (0,0); + for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) { + $prd = $q * $y[$y] + $car; + $prd -= ($car = int($prd * 1e-5)) * 1e5; + $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0)); + } + if ($x[$#x] < $car + $bar) { + $car = 0; --$q; + for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) { + $x[$x] -= 1e5 + if ($car = (($x[$x] += $y[$y] + $car) > 1e5)); + } + } + } + pop(@x); unshift(@q, $q); + } + if (wantarray) { + @d = (); + if ($dd != 1) { + $car = 0; + for $x (reverse @x) { + $prd = $car * 1e5 + $x; + $car = $prd - ($tmp = int($prd / $dd)) * $dd; + unshift(@d, $tmp); + } + } + else { + @d = @x; + } + (&external($sr, @q), &external($srem, @d, 0)); + } else { + &external($sr, @q); + } +} +1; diff --git a/gnu/usr.bin/perl/lib/bigrat.pl b/gnu/usr.bin/perl/lib/bigrat.pl new file mode 100644 index 0000000..fb10cf3 --- /dev/null +++ b/gnu/usr.bin/perl/lib/bigrat.pl @@ -0,0 +1,148 @@ +package bigrat; +require "bigint.pl"; + +# Arbitrary size rational math package +# +# by Mark Biggar +# +# Input values to these routines consist of strings of the form +# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|. +# Examples: +# "+0/1" canonical zero value +# "3" canonical value "+3/1" +# " -123/123 123" canonical value "-1/1001" +# "123 456/7890" canonical value "+20576/1315" +# Output values always include a sign and no leading zeros or +# white space. +# This package makes use of the bigint package. +# The string 'NaN' is used to represent the result when input arguments +# that are not numbers, as well as the result of dividing by zero and +# the sqrt of a negative number. +# Extreamly naive algorthims are used. +# +# Routines provided are: +# +# rneg(RAT) return RAT negation +# rabs(RAT) return RAT absolute value +# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0) +# radd(RAT,RAT) return RAT addition +# rsub(RAT,RAT) return RAT subtraction +# rmul(RAT,RAT) return RAT multiplication +# rdiv(RAT,RAT) return RAT division +# rmod(RAT) return (RAT,RAT) integer and fractional parts +# rnorm(RAT) return RAT normalization +# rsqrt(RAT, cycles) return RAT square root + +# Convert a number to the canonical string form m|^[+-]\d+/\d+|. +sub main'rnorm { #(string) return rat_num + local($_) = @_; + s/\s+//g; + if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) { + &norm($1, $3 ? $3 : '+1'); + } else { + 'NaN'; + } +} + +# Normalize by reducing to lowest terms +sub norm { #(bint, bint) return rat_num + local($num,$dom) = @_; + if ($num eq 'NaN') { + 'NaN'; + } elsif ($dom eq 'NaN') { + 'NaN'; + } elsif ($dom =~ /^[+-]?0+$/) { + 'NaN'; + } else { + local($gcd) = &'bgcd($num,$dom); + if ($gcd ne '+1') { + $num = &'bdiv($num,$gcd); + $dom = &'bdiv($dom,$gcd); + } else { + $num = &'bnorm($num); + $dom = &'bnorm($dom); + } + substr($dom,0,1) = ''; + "$num/$dom"; + } +} + +# negation +sub main'rneg { #(rat_num) return rat_num + local($_) = &'rnorm($_[0]); + tr/-+/+-/ if ($_ ne '+0/1'); + $_; +} + +# absolute value +sub main'rabs { #(rat_num) return $rat_num + local($_) = &'rnorm($_[0]); + substr($_,0,1) = '+' unless $_ eq 'NaN'; + $_; +} + +# multipication +sub main'rmul { #(rat_num, rat_num) return rat_num + local($xn,$xd) = split('/',&'rnorm($_[0])); + local($yn,$yd) = split('/',&'rnorm($_[1])); + &norm(&'bmul($xn,$yn),&'bmul($xd,$yd)); +} + +# division +sub main'rdiv { #(rat_num, rat_num) return rat_num + local($xn,$xd) = split('/',&'rnorm($_[0])); + local($yn,$yd) = split('/',&'rnorm($_[1])); + &norm(&'bmul($xn,$yd),&'bmul($xd,$yn)); +} + +# addition +sub main'radd { #(rat_num, rat_num) return rat_num + local($xn,$xd) = split('/',&'rnorm($_[0])); + local($yn,$yd) = split('/',&'rnorm($_[1])); + &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd)); +} + +# subtraction +sub main'rsub { #(rat_num, rat_num) return rat_num + local($xn,$xd) = split('/',&'rnorm($_[0])); + local($yn,$yd) = split('/',&'rnorm($_[1])); + &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd)); +} + +# comparison +sub main'rcmp { #(rat_num, rat_num) return cond_code + local($xn,$xd) = split('/',&'rnorm($_[0])); + local($yn,$yd) = split('/',&'rnorm($_[1])); + &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd)); +} + +# int and frac parts +sub main'rmod { #(rat_num) return (rat_num,rat_num) + local($xn,$xd) = split('/',&'rnorm($_[0])); + local($i,$f) = &'bdiv($xn,$xd); + if (wantarray) { + ("$i/1", "$f/$xd"); + } else { + "$i/1"; + } +} + +# square root by Newtons method. +# cycles specifies the number of iterations default: 5 +sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str + local($x, $scale) = (&'rnorm($_[0]), $_[1]); + if ($x eq 'NaN') { + 'NaN'; + } elsif ($x =~ /^-/) { + 'NaN'; + } else { + local($gscale, $guess) = (0, '+1/1'); + $scale = 5 if (!$scale); + while ($gscale++ < $scale) { + $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2"); + } + "$guess"; # quotes necessary due to perl bug + } +} + +1; diff --git a/gnu/usr.bin/perl/lib/cacheout.pl b/gnu/usr.bin/perl/lib/cacheout.pl new file mode 100644 index 0000000..513c25b --- /dev/null +++ b/gnu/usr.bin/perl/lib/cacheout.pl @@ -0,0 +1,40 @@ +# Open in their package. + +sub cacheout'open { + open($_[0], $_[1]); +} + +# But only this sub name is visible to them. + +sub cacheout { + package cacheout; + + ($file) = @_; + if (!$isopen{$file}) { + if (++$numopen > $maxopen) { + local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen); + splice(@lru, $maxopen / 3); + $numopen -= @lru; + for (@lru) { close $_; delete $isopen{$_}; } + } + &open($file, ($saw{$file}++ ? '>>' : '>') . $file) + || die "Can't create $file: $!\n"; + } + $isopen{$file} = ++$seq; +} + +package cacheout; + +$seq = 0; +$numopen = 0; + +if (open(PARAM,'/usr/include/sys/param.h')) { + local($.); + while () { + $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/; + } + close PARAM; +} +$maxopen = 16 unless $maxopen; + +1; diff --git a/gnu/usr.bin/perl/lib/chat2.pl b/gnu/usr.bin/perl/lib/chat2.pl new file mode 100644 index 0000000..662872c --- /dev/null +++ b/gnu/usr.bin/perl/lib/chat2.pl @@ -0,0 +1,339 @@ +## chat.pl: chat with a server +## V2.01.alpha.7 91/06/16 +## Randal L. Schwartz + +package chat; + +$sockaddr = 'S n a4 x8'; +chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4]; +$thisproc = pack($sockaddr, 2, 0, $thisaddr); + +# *S = symbol for current I/O, gets assigned *chatsymbol.... +$next = "chatsymbol000000"; # next one +$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++ + + +## $handle = &chat'open_port("server.address",$port_number); +## opens a named or numbered TCP server + +sub open_port { ## public + local($server, $port) = @_; + + local($serveraddr,$serverproc); + + *S = ++$next; + if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) { + $serveraddr = pack('C4', $1, $2, $3, $4); + } else { + local(@x) = gethostbyname($server); + return undef unless @x; + $serveraddr = $x[4]; + } + $serverproc = pack($sockaddr, 2, $port, $serveraddr); + unless (socket(S, 2, 1, 6)) { + # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp' + # but who the heck would change these anyway? (:-) + ($!) = ($!, close(S)); # close S while saving $! + return undef; + } + unless (bind(S, $thisproc)) { + ($!) = ($!, close(S)); # close S while saving $! + return undef; + } + unless (connect(S, $serverproc)) { + ($!) = ($!, close(S)); # close S while saving $! + return undef; + } + select((select(S), $| = 1)[0]); + $next; # return symbol for switcharound +} + +## ($host, $port, $handle) = &chat'open_listen([$port_number]); +## opens a TCP port on the current machine, ready to be listened to +## if $port_number is absent or zero, pick a default port number +## process must be uid 0 to listen to a low port number + +sub open_listen { ## public + + *S = ++$next; + local($thisport) = shift || 0; + local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr); + local(*NS) = "__" . time; + unless (socket(NS, 2, 1, 6)) { + # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp' + # but who the heck would change these anyway? (:-) + ($!) = ($!, close(NS)); + return undef; + } + unless (bind(NS, $thisproc_local)) { + ($!) = ($!, close(NS)); + return undef; + } + unless (listen(NS, 1)) { + ($!) = ($!, close(NS)); + return undef; + } + select((select(NS), $| = 1)[0]); + local($family, $port, @myaddr) = + unpack("S n C C C C x8", getsockname(NS)); + $S{"needs_accept"} = *NS; # so expect will open it + (@myaddr, $port, $next); # returning this +} + +## $handle = &chat'open_proc("command","arg1","arg2",...); +## opens a /bin/sh on a pseudo-tty + +sub open_proc { ## public + local(@cmd) = @_; + + *S = ++$next; + local(*TTY) = "__TTY" . time; + local($pty,$tty) = &_getpty(S,TTY); + die "Cannot find a new pty" unless defined $pty; + local($pid) = fork; + die "Cannot fork: $!" unless defined $pid; + unless ($pid) { + close STDIN; close STDOUT; close STDERR; + setpgrp(0,$$); + if (open(DEVTTY, "/dev/tty")) { + ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY + close DEVTTY; + } + open(STDIN,"<&TTY"); + open(STDOUT,">&TTY"); + open(STDERR,">&STDOUT"); + die "Oops" unless fileno(STDERR) == 2; # sanity + close(S); + exec @cmd; + die "Cannot exec @cmd: $!"; + } + close(TTY); + $PID{$next} = $pid; + $next; # return symbol for switcharound +} + +# $S is the read-ahead buffer + +## $return = &chat'expect([$handle,] $timeout_time, +## $pat1, $body1, $pat2, $body2, ... ) +## $handle is from previous &chat'open_*(). +## $timeout_time is the time (either relative to the current time, or +## absolute, ala time(2)) at which a timeout event occurs. +## $pat1, $pat2, and so on are regexs which are matched against the input +## stream. If a match is found, the entire matched string is consumed, +## and the corresponding body eval string is evaled. +## +## Each pat is a regular-expression (probably enclosed in single-quotes +## in the invocation). ^ and $ will work, respecting the current value of $*. +## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded. +## If pat is 'EOF', the body is executed if the process exits before +## the other patterns are seen. +## +## Pats are scanned in the order given, so later pats can contain +## general defaults that won't be examined unless the earlier pats +## have failed. +## +## The result of eval'ing body is returned as the result of +## the invocation. Recursive invocations are not thought +## through, and may work only accidentally. :-) +## +## undef is returned if either a timeout or an eof occurs and no +## corresponding body has been defined. +## I/O errors of any sort are treated as eof. + +$nextsubname = "expectloop000000"; # used for subroutines + +sub expect { ## public + if ($_[0] =~ /$nextpat/) { + *S = shift; + } + local($endtime) = shift; + + local($timeout,$eof) = (1,1); + local($caller) = caller; + local($rmask, $nfound, $timeleft, $thisbuf); + local($cases, $pattern, $action, $subname); + $endtime += time if $endtime < 600_000_000; + + if (defined $S{"needs_accept"}) { # is it a listen socket? + local(*NS) = $S{"needs_accept"}; + delete $S{"needs_accept"}; + $S{"needs_close"} = *NS; + unless(accept(S,NS)) { + ($!) = ($!, close(S), close(NS)); + return undef; + } + select((select(S), $| = 1)[0]); + } + + # now see whether we need to create a new sub: + + unless ($subname = $expect_subname{$caller,@_}) { + # nope. make a new one: + $expect_subname{$caller,@_} = $subname = $nextsubname++; + + $cases .= <<"EDQ"; # header is funny to make everything elsif's +sub $subname { + LOOP: { + if (0) { ; } +EDQ + while (@_) { + ($pattern,$action) = splice(@_,0,2); + if ($pattern =~ /^eof$/i) { + $cases .= <<"EDQ"; + elsif (\$eof) { + package $caller; + $action; + } +EDQ + $eof = 0; + } elsif ($pattern =~ /^timeout$/i) { + $cases .= <<"EDQ"; + elsif (\$timeout) { + package $caller; + $action; + } +EDQ + $timeout = 0; + } else { + $pattern =~ s#/#\\/#g; + $cases .= <<"EDQ"; + elsif (\$S =~ /$pattern/) { + \$S = \$'; + package $caller; + $action; + } +EDQ + } + } + $cases .= <<"EDQ" if $eof; + elsif (\$eof) { + undef; + } +EDQ + $cases .= <<"EDQ" if $timeout; + elsif (\$timeout) { + undef; + } +EDQ + $cases .= <<'ESQ'; + else { + $rmask = ""; + vec($rmask,fileno(S),1) = 1; + ($nfound, $rmask) = + select($rmask, undef, undef, $endtime - time); + if ($nfound) { + $nread = sysread(S, $thisbuf, 1024); + if ($nread > 0) { + $S .= $thisbuf; + } else { + $eof++, redo LOOP; # any error is also eof + } + } else { + $timeout++, redo LOOP; # timeout + } + redo LOOP; + } + } +} +ESQ + eval $cases; die "$cases:\n$@" if $@; + } + $eof = $timeout = 0; + do $subname(); +} + +## &chat'print([$handle,] @data) +## $handle is from previous &chat'open(). +## like print $handle @data + +sub print { ## public + if ($_[0] =~ /$nextpat/) { + *S = shift; + } + print S @_; +} + +## &chat'close([$handle,]) +## $handle is from previous &chat'open(). +## like close $handle + +sub close { ## public + local($pid); + if ($_[0] =~ /$nextpat/) { + $pid = $PID{$_[0]}; + *S = shift; + } else { + $pid = $PID{$next}; + } + close(S); + waitpid($pid,0); + if (defined $S{"needs_close"}) { # is it a listen socket? + local(*NS) = $S{"needs_close"}; + delete $S{"needs_close"}; + close(NS); + } +} + +## @ready_handles = &chat'select($timeout, @handles) +## select()'s the handles with a timeout value of $timeout seconds. +## Returns an array of handles that are ready for I/O. +## Both user handles and chat handles are supported (but beware of +## stdio's buffering for user handles). + +sub select { ## public + local($timeout) = shift; + local(@handles) = @_; + local(%handlename) = (); + local(%ready) = (); + local($caller) = caller; + local($rmask) = ""; + for (@handles) { + if (/$nextpat/o) { # one of ours... see if ready + local(*SYM) = $_; + if (length($SYM)) { + $timeout = 0; # we have a winner + $ready{$_}++; + } + $handlename{fileno($_)} = $_; + } else { + $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_; + } + } + for (sort keys %handlename) { + vec($rmask, $_, 1) = 1; + } + select($rmask, undef, undef, $timeout); + for (sort keys %handlename) { + $ready{$handlename{$_}}++ if vec($rmask,$_,1); + } + sort keys %ready; +} + +# ($pty,$tty) = $chat'_getpty(PTY,TTY): +# internal procedure to get the next available pty. +# opens pty on handle PTY, and matching tty on handle TTY. +# returns undef if can't find a pty. + +sub _getpty { ## private + local($_PTY,$_TTY) = @_; + $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; + $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e; + local($pty,$tty); + for $bank (112..127) { + next unless -e sprintf("/dev/pty%c0", $bank); + for $unit (48..57) { + $pty = sprintf("/dev/pty%c%c", $bank, $unit); + open($_PTY,"+>$pty") || next; + select((select($_PTY), $| = 1)[0]); + ($tty = $pty) =~ s/pty/tty/; + open($_TTY,"+>$tty") || next; + select((select($_TTY), $| = 1)[0]); + system "stty nl>$tty"; + return ($pty,$tty); + } + } + undef; +} + +1; diff --git a/gnu/usr.bin/perl/lib/complete.pl b/gnu/usr.bin/perl/lib/complete.pl new file mode 100644 index 0000000..dabf8f6 --- /dev/null +++ b/gnu/usr.bin/perl/lib/complete.pl @@ -0,0 +1,110 @@ +;# +;# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91 +;# +;# Author: Wayne Thompson +;# +;# Description: +;# This routine provides word completion. +;# (TAB) attempts word completion. +;# (^D) prints completion list. +;# (These may be changed by setting $Complete'complete, etc.) +;# +;# Diagnostics: +;# Bell when word completion fails. +;# +;# Dependencies: +;# The tty driver is put into raw mode. +;# +;# Bugs: +;# +;# Usage: +;# $input = &Complete('prompt_string', *completion_list); +;# or +;# $input = &Complete('prompt_string', @completion_list); +;# + +CONFIG: { + package Complete; + + $complete = "\004"; + $kill = "\025"; + $erase1 = "\177"; + $erase2 = "\010"; +} + +sub Complete { + package Complete; + + local($[) = 0; + if ($_[1] =~ /^StB\0/) { + ($prompt, *_) = @_; + } + else { + $prompt = shift(@_); + } + @cmp_lst = sort(@_); + + system('stty raw -echo'); + LOOP: { + print($prompt, $return); + while (($_ = getc(STDIN)) ne "\r") { + CASE: { + # (TAB) attempt completion + $_ eq "\t" && do { + @match = grep(/^$return/, @cmp_lst); + $l = length($test = shift(@match)); + unless ($#match < 0) { + foreach $cmp (@match) { + until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { + $l--; + } + } + print("\a"); + } + print($test = substr($test, $r, $l - $r)); + $r = length($return .= $test); + last CASE; + }; + + # (^D) completion list + $_ eq $complete && do { + print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n"); + redo LOOP; + }; + + # (^U) kill + $_ eq $kill && do { + if ($r) { + undef($r, $return); + print("\r\n"); + redo LOOP; + } + last CASE; + }; + + # (DEL) || (BS) erase + ($_ eq $erase1 || $_ eq $erase2) && do { + if($r) { + print("\b \b"); + chop($return); + $r--; + } + last CASE; + }; + + # printable char + ord >= 32 && do { + $return .= $_; + $r++; + print; + last CASE; + }; + } + } + } + system('stty -raw echo'); + print("\n"); + $return; +} + +1; diff --git a/gnu/usr.bin/perl/lib/ctime.pl b/gnu/usr.bin/perl/lib/ctime.pl new file mode 100644 index 0000000..4c59754 --- /dev/null +++ b/gnu/usr.bin/perl/lib/ctime.pl @@ -0,0 +1,51 @@ +;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function. +;# +;# Waldemar Kebsch, Federal Republic of Germany, November 1988 +;# kebsch.pad@nixpbe.UUCP +;# Modified March 1990, Feb 1991 to properly handle timezones +;# $RCSfile: ctime.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $ +;# Marion Hakanson (hakanson@cse.ogi.edu) +;# Oregon Graduate Institute of Science and Technology +;# +;# usage: +;# +;# #include # see the -P and -I option in perl.man +;# $Date = &ctime(time); + +CONFIG: { + package ctime; + + @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); + @MoY = ('Jan','Feb','Mar','Apr','May','Jun', + 'Jul','Aug','Sep','Oct','Nov','Dec'); +} + +sub ctime { + package ctime; + + local($time) = @_; + local($[) = 0; + local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst); + + # Determine what time zone is in effect. + # Use GMT if TZ is defined as null, local time if TZ undefined. + # There's no portable way to find the system default timezone. + + $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : ''; + ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = + ($TZ eq 'GMT') ? gmtime($time) : localtime($time); + + # Hack to deal with 'PST8PDT' format of TZ + # Note that this can't deal with all the esoteric forms, but it + # does recognize the most common: [:]STDoff[DST[off][,rule]] + + if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){ + $TZ = $isdst ? $4 : $1; + } + $TZ .= ' ' unless $TZ eq ''; + + $year += ($year < 70) ? 2000 : 1900; + sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n", + $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year); +} +1; diff --git a/gnu/usr.bin/perl/lib/dumpvar.pl b/gnu/usr.bin/perl/lib/dumpvar.pl new file mode 100644 index 0000000..5427494 --- /dev/null +++ b/gnu/usr.bin/perl/lib/dumpvar.pl @@ -0,0 +1,37 @@ +package dumpvar; + +# translate control chars to ^X - Randal Schwartz +sub unctrl { + local($_) = @_; + s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg; + $_; +} +sub main'dumpvar { + ($package,@vars) = @_; + local(*stab) = eval("*_$package"); + while (($key,$val) = each(%stab)) { + { + next if @vars && !grep($key eq $_,@vars); + local(*entry) = $val; + if (defined $entry) { + print "\$$key = '",&unctrl($entry),"'\n"; + } + if (defined @entry) { + print "\@$key = (\n"; + foreach $num ($[ .. $#entry) { + print " $num\t'",&unctrl($entry[$num]),"'\n"; + } + print ")\n"; + } + if ($key ne "_$package" && $key ne "_DB" && defined %entry) { + print "\%$key = (\n"; + foreach $key (sort keys(%entry)) { + print " $key\t'",&unctrl($entry{$key}),"'\n"; + } + print ")\n"; + } + } + } +} + +1; diff --git a/gnu/usr.bin/perl/lib/exceptions.pl b/gnu/usr.bin/perl/lib/exceptions.pl new file mode 100644 index 0000000..02c4498 --- /dev/null +++ b/gnu/usr.bin/perl/lib/exceptions.pl @@ -0,0 +1,54 @@ +# exceptions.pl +# tchrist@convex.com +# +# Here's a little code I use for exception handling. It's really just +# glorfied eval/die. The way to use use it is when you might otherwise +# exit, use &throw to raise an exception. The first enclosing &catch +# handler looks at the exception and decides whether it can catch this kind +# (catch takes a list of regexps to catch), and if so, it returns the one it +# caught. If it *can't* catch it, then it will reraise the exception +# for someone else to possibly see, or to die otherwise. +# +# I use oddly named variables in order to make darn sure I don't conflict +# with my caller. I also hide in my own package, and eval the code in his. +# +# The EXCEPTION: prefix is so you can tell whether it's a user-raised +# exception or a perl-raised one (eval error). +# +# --tom +# +# examples: +# if (&catch('/$user_input/', 'regexp', 'syntax error') { +# warn "oops try again"; +# redo; +# } +# +# if ($error = &catch('&subroutine()')) { # catches anything +# +# &throw('bad input') if /^$/; + +sub catch { + package exception; + local($__code__, @__exceptions__) = @_; + local($__package__) = caller; + local($__exception__); + + eval "package $__package__; $__code__"; + if ($__exception__ = &'thrown) { + for (@__exceptions__) { + return $__exception__ if /$__exception__/; + } + &'throw($__exception__); + } +} + +sub throw { + local($exception) = @_; + die "EXCEPTION: $exception\n"; +} + +sub thrown { + $@ =~ /^(EXCEPTION: )+(.+)/ && $2; +} + +1; diff --git a/gnu/usr.bin/perl/lib/fastcwd.pl b/gnu/usr.bin/perl/lib/fastcwd.pl new file mode 100644 index 0000000..6b452e8 --- /dev/null +++ b/gnu/usr.bin/perl/lib/fastcwd.pl @@ -0,0 +1,35 @@ +# By John Bazik +# +# Usage: $cwd = &fastcwd; +# +# This is a faster version of getcwd. It's also more dangerous because +# you might chdir out of a directory that you can't chdir back into. + +sub fastcwd { + local($odev, $oino, $cdev, $cino, $tdev, $tino); + local(@path, $path); + local(*DIR); + + ($cdev, $cino) = stat('.'); + for (;;) { + ($odev, $oino) = ($cdev, $cino); + chdir('..'); + ($cdev, $cino) = stat('.'); + last if $odev == $cdev && $oino == $cino; + opendir(DIR, '.'); + for (;;) { + $_ = readdir(DIR); + next if $_ eq '.'; + next if $_ eq '..'; + + last unless $_; + ($tdev, $tino) = lstat($_); + last unless $tdev != $odev || $tino != $oino; + } + closedir(DIR); + unshift(@path, $_); + } + chdir($path = '/' . join('/', @path)); + $path; +} +1; diff --git a/gnu/usr.bin/perl/lib/find.pl b/gnu/usr.bin/perl/lib/find.pl new file mode 100644 index 0000000..8dab054 --- /dev/null +++ b/gnu/usr.bin/perl/lib/find.pl @@ -0,0 +1,106 @@ +# Usage: +# require "find.pl"; +# +# &find('/foo','/bar'); +# +# sub wanted { ... } +# where wanted does whatever you want. $dir contains the +# current directory name, and $_ the current filename within +# that directory. $name contains "$dir/$_". You are cd'ed +# to $dir when the function is called. The function may +# set $prune to prune the tree. +# +# This library is primarily for find2perl, which, when fed +# +# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune +# +# spits out something like this +# +# sub wanted { +# /^\.nfs.*$/ && +# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && +# int(-M _) > 7 && +# unlink($_) +# || +# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && +# $dev < 0 && +# ($prune = 1); +# } + +sub find { + chop($cwd = `pwd`); + foreach $topdir (@_) { + (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) + || (warn("Can't stat $topdir: $!\n"), next); + if (-d _) { + if (chdir($topdir)) { + ($dir,$_) = ($topdir,'.'); + $name = $topdir; + &wanted; + $topdir =~ s,/$,, ; + &finddir($topdir,$topnlink); + } + else { + warn "Can't cd to $topdir: $!\n"; + } + } + else { + unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { + ($dir,$_) = ('.', $topdir); + } + $name = $topdir; + chdir $dir && &wanted; + } + chdir $cwd; + } +} + +sub finddir { + local($dir,$nlink) = @_; + local($dev,$ino,$mode,$subcount); + local($name); + + # Get the list of files in the current directory. + + opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return); + local(@filenames) = readdir(DIR); + closedir(DIR); + + if ($nlink == 2) { # This dir has no subdirectories. + for (@filenames) { + next if $_ eq '.'; + next if $_ eq '..'; + $name = "$dir/$_"; + $nlink = 0; + &wanted; + } + } + else { # This dir has subdirectories. + $subcount = $nlink - 2; + for (@filenames) { + next if $_ eq '.'; + next if $_ eq '..'; + $nlink = $prune = 0; + $name = "$dir/$_"; + &wanted; + if ($subcount > 0) { # Seen all the subdirs? + + # Get link count and check for directoriness. + + ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink; + + if (-d _) { + + # It really is a directory, so do it recursively. + + if (!$prune && chdir $_) { + &finddir($name,$nlink); + chdir '..'; + } + --$subcount; + } + } + } + } +} +1; diff --git a/gnu/usr.bin/perl/lib/finddepth.pl b/gnu/usr.bin/perl/lib/finddepth.pl new file mode 100644 index 0000000..15e4daf --- /dev/null +++ b/gnu/usr.bin/perl/lib/finddepth.pl @@ -0,0 +1,105 @@ +# Usage: +# require "finddepth.pl"; +# +# &finddepth('/foo','/bar'); +# +# sub wanted { ... } +# where wanted does whatever you want. $dir contains the +# current directory name, and $_ the current filename within +# that directory. $name contains "$dir/$_". You are cd'ed +# to $dir when the function is called. The function may +# set $prune to prune the tree. +# +# This library is primarily for find2perl, which, when fed +# +# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune +# +# spits out something like this +# +# sub wanted { +# /^\.nfs.*$/ && +# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && +# int(-M _) > 7 && +# unlink($_) +# || +# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && +# $dev < 0 && +# ($prune = 1); +# } + +sub finddepth { + chop($cwd = `pwd`); + foreach $topdir (@_) { + (($topdev,$topino,$topmode,$topnlink) = stat($topdir)) + || (warn("Can't stat $topdir: $!\n"), next); + if (-d _) { + if (chdir($topdir)) { + $topdir =~ s,/$,, ; + &finddepthdir($topdir,$topnlink); + ($dir,$_) = ($topdir,'.'); + $name = $topdir; + &wanted; + } + else { + warn "Can't cd to $topdir: $!\n"; + } + } + else { + unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { + ($dir,$_) = ('.', $topdir); + } + chdir $dir && &wanted; + } + chdir $cwd; + } +} + +sub finddepthdir { + local($dir,$nlink) = @_; + local($dev,$ino,$mode,$subcount); + local($name); + + # Get the list of files in the current directory. + + opendir(DIR,'.') || warn "Can't open $dir: $!\n"; + local(@filenames) = readdir(DIR); + closedir(DIR); + + if ($nlink == 2) { # This dir has no subdirectories. + for (@filenames) { + next if $_ eq '.'; + next if $_ eq '..'; + $name = "$dir/$_"; + $nlink = 0; + &wanted; + } + } + else { # This dir has subdirectories. + $subcount = $nlink - 2; + for (@filenames) { + next if $_ eq '.'; + next if $_ eq '..'; + $nlink = $prune = 0; + $name = "$dir/$_"; + if ($subcount > 0) { # Seen all the subdirs? + + # Get link count and check for directoriness. + + ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink; + + if (-d _) { + + # It really is a directory, so do it recursively. + + if (!$prune && chdir $_) { + &finddepthdir($name,$nlink); + chdir '..'; + } + --$subcount; + } + } + &wanted; + } + } +} +1; diff --git a/gnu/usr.bin/perl/lib/flush.pl b/gnu/usr.bin/perl/lib/flush.pl new file mode 100644 index 0000000..55002b9 --- /dev/null +++ b/gnu/usr.bin/perl/lib/flush.pl @@ -0,0 +1,23 @@ +;# Usage: &flush(FILEHANDLE) +;# flushes the named filehandle + +;# Usage: &printflush(FILEHANDLE, "prompt: ") +;# prints arguments and flushes filehandle + +sub flush { + local($old) = select(shift); + $| = 1; + print ""; + $| = 0; + select($old); +} + +sub printflush { + local($old) = select(shift); + $| = 1; + print @_; + $| = 0; + select($old); +} + +1; diff --git a/gnu/usr.bin/perl/lib/getcwd.pl b/gnu/usr.bin/perl/lib/getcwd.pl new file mode 100644 index 0000000..a3214ba --- /dev/null +++ b/gnu/usr.bin/perl/lib/getcwd.pl @@ -0,0 +1,62 @@ +# By Brandon S. Allbery +# +# Usage: $cwd = &getcwd; + +sub getcwd +{ + local($dotdots, $cwd, @pst, @cst, $dir, @tst); + + unless (@cst = stat('.')) + { + warn "stat(.): $!"; + return ''; + } + $cwd = ''; + do + { + $dotdots .= '/' if $dotdots; + $dotdots .= '..'; + @pst = @cst; + unless (opendir(getcwd'PARENT, $dotdots)) #')) + { + warn "opendir($dotdots): $!"; + return ''; + } + unless (@cst = stat($dotdots)) + { + warn "stat($dotdots): $!"; + closedir(getcwd'PARENT); #'); + return ''; + } + if ($pst[$[] == $cst[$[] && $pst[$[ + 1] == $cst[$[ + 1]) + { + $dir = ''; + } + else + { + do + { + unless ($dir = readdir(getcwd'PARENT)) #')) + { + warn "readdir($dotdots): $!"; + closedir(getcwd'PARENT); #'); + return ''; + } + unless (@tst = lstat("$dotdots/$dir")) + { + warn "lstat($dotdots/$dir): $!"; + closedir(getcwd'PARENT); #'); + return ''; + } + } + while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] || + $tst[$[ + 1] != $pst[$[ + 1]); + } + $cwd = "$dir/$cwd"; + closedir(getcwd'PARENT); #'); + } while ($dir); + chop($cwd); + $cwd; +} + +1; diff --git a/gnu/usr.bin/perl/lib/getopt.pl b/gnu/usr.bin/perl/lib/getopt.pl new file mode 100644 index 0000000..6772d54 --- /dev/null +++ b/gnu/usr.bin/perl/lib/getopt.pl @@ -0,0 +1,41 @@ +;# $RCSfile: getopt.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $ + +;# Process single-character switches with switch clustering. Pass one argument +;# which is a string containing all switches that take an argument. For each +;# switch found, sets $opt_x (where x is the switch name) to the value of the +;# argument, or 1 if no argument. Switches which take an argument don't care +;# whether there is a space between the switch and the argument. + +;# Usage: +;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + +sub Getopt { + local($argumentative) = @_; + local($_,$first,$rest); + local($[) = 0; + + while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + if (index($argumentative,$first) >= $[) { + if ($rest ne '') { + shift(@ARGV); + } + else { + shift(@ARGV); + $rest = shift(@ARGV); + } + eval "\$opt_$first = \$rest;"; + } + else { + eval "\$opt_$first = 1;"; + if ($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift(@ARGV); + } + } + } +} + +1; diff --git a/gnu/usr.bin/perl/lib/getopts.pl b/gnu/usr.bin/perl/lib/getopts.pl new file mode 100644 index 0000000..a0818d1 --- /dev/null +++ b/gnu/usr.bin/perl/lib/getopts.pl @@ -0,0 +1,50 @@ +;# getopts.pl - a better getopt.pl + +;# Usage: +;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a +;# # side effect. + +sub Getopts { + local($argumentative) = @_; + local(@args,$_,$first,$rest); + local($errs) = 0; + local($[) = 0; + + @args = split( / */, $argumentative ); + while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + $pos = index($argumentative,$first); + if($pos >= $[) { + if($args[$pos+1] eq ':') { + shift(@ARGV); + if($rest eq '') { + ++$errs unless @ARGV; + $rest = shift(@ARGV); + } + eval "\$opt_$first = \$rest;"; + } + else { + eval "\$opt_$first = 1"; + if($rest eq '') { + shift(@ARGV); + } + else { + $ARGV[0] = "-$rest"; + } + } + } + else { + print STDERR "Unknown option: $first\n"; + ++$errs; + if($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift(@ARGV); + } + } + } + $errs == 0; +} + +1; diff --git a/gnu/usr.bin/perl/lib/importenv.pl b/gnu/usr.bin/perl/lib/importenv.pl new file mode 100644 index 0000000..c9ad330 --- /dev/null +++ b/gnu/usr.bin/perl/lib/importenv.pl @@ -0,0 +1,16 @@ +;# $Header: /home/cvs/386BSD/ports/lang/perl/lib/importenv.pl,v 1.1.1.1 1993/08/23 21:29:53 nate Exp $ + +;# This file, when interpreted, pulls the environment into normal variables. +;# Usage: +;# require 'importenv.pl'; +;# or +;# #include + +local($tmp,$key) = ''; + +foreach $key (keys(ENV)) { + $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; +} +eval $tmp; + +1; diff --git a/gnu/usr.bin/perl/lib/look.pl b/gnu/usr.bin/perl/lib/look.pl new file mode 100644 index 0000000..4c14e64 --- /dev/null +++ b/gnu/usr.bin/perl/lib/look.pl @@ -0,0 +1,44 @@ +;# Usage: &look(*FILEHANDLE,$key,$dict,$fold) + +;# Sets file position in FILEHANDLE to be first line greater than or equal +;# (stringwise) to $key. Pass flags for dictionary order and case folding. + +sub look { + local(*FH,$key,$dict,$fold) = @_; + local($max,$min,$mid,$_); + local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(FH); + $blksize = 8192 unless $blksize; + $key =~ s/[^\w\s]//g if $dict; + $key =~ y/A-Z/a-z/ if $fold; + $max = int($size / $blksize); + while ($max - $min > 1) { + $mid = int(($max + $min) / 2); + seek(FH,$mid * $blksize,0); + $_ = if $mid; # probably a partial line + $_ = ; + chop; + s/[^\w\s]//g if $dict; + y/A-Z/a-z/ if $fold; + if ($_ lt $key) { + $min = $mid; + } + else { + $max = $mid; + } + } + $min *= $blksize; + seek(FH,$min,0); + if $min; + while () { + chop; + s/[^\w\s]//g if $dict; + y/A-Z/a-z/ if $fold; + last if $_ ge $key; + $min = tell(FH); + } + seek(FH,$min,0); + $min; +} + +1; diff --git a/gnu/usr.bin/perl/lib/newgetopt.pl b/gnu/usr.bin/perl/lib/newgetopt.pl new file mode 100644 index 0000000..0e4cbfd --- /dev/null +++ b/gnu/usr.bin/perl/lib/newgetopt.pl @@ -0,0 +1,271 @@ +# newgetopt.pl -- new options parsing + +# SCCS Status : @(#)@ newgetopt.pl 1.13 +# Author : Johan Vromans +# Created On : Tue Sep 11 15:00:12 1990 +# Last Modified By: Johan Vromans +# Last Modified On: Tue Jun 2 11:24:03 1992 +# Update Count : 75 +# Status : Okay + +# This package implements a new getopt function. This function adheres +# to the new syntax (long option names, no bundling). +# +# Arguments to the function are: +# +# - a list of possible options. These should designate valid perl +# identifiers, optionally followed by an argument specifier ("=" +# for mandatory arguments or ":" for optional arguments) and an +# argument type specifier: "n" or "i" for integer numbers, "f" for +# real (fix) numbers or "s" for strings. +# If an "@" sign is appended, the option is treated as an array. +# Value(s) are not set, but pushed. +# +# - if the first option of the list consists of non-alphanumeric +# characters only, it is interpreted as a generic option starter. +# Everything starting with one of the characters from the starter +# will be considered an option. +# Likewise, a double occurrence (e.g. "--") signals end of +# the options list. +# The default value for the starter is "-", "--" or "+". +# +# Upon return, the option variables, prefixed with "opt_", are defined +# and set to the respective option arguments, if any. +# Options that do not take an argument are set to 1. Note that an +# option with an optional argument will be defined, but set to '' if +# no actual argument has been supplied. +# A return status of 0 (false) indicates that the function detected +# one or more errors. +# +# Special care is taken to give a correct treatment to optional arguments. +# +# E.g. if option "one:i" (i.e. takes an optional integer argument), +# then the following situations are handled: +# +# -one -two -> $opt_one = '', -two is next option +# -one -2 -> $opt_one = -2 +# +# Also, assume "foo=s" and "bar:s" : +# +# -bar -xxx -> $opt_bar = '', '-xxx' is next option +# -foo -bar -> $opt_foo = '-bar' +# -foo -- -> $opt_foo = '--' +# +# HISTORY +# 2-Jun-1992 Johan Vromans +# Do not use //o to allow multiple NGetOpt calls with different delimeters. +# Prevent typeless option from using previous $array state. +# Prevent empty option from being eaten as a (negative) number. + +# 25-May-1992 Johan Vromans +# Add array options. "foo=s@" will return an array @opt_foo that +# contains all values that were supplied. E.g. "-foo one -foo -two" will +# return @opt_foo = ("one", "-two"); +# Correct bug in handling options that allow for a argument when followed +# by another option. + +# 4-May-1992 Johan Vromans +# Add $ignorecase to match options in either case. +# Allow '' option. + +# 19-Mar-1992 Johan Vromans +# Allow require from packages. +# NGetOpt is now defined in the package that requires it. +# @ARGV and $opt_... are taken from the package that calls it. +# Use standard (?) option prefixes: -, -- and +. + +# 20-Sep-1990 Johan Vromans +# Set options w/o argument to 1. +# Correct the dreadful semicolon/require bug. + + +{ package newgetopt; + $debug = 0; # for debugging + $ignorecase = 1; # ignore case when matching options +} + +sub NGetOpt { + + @newgetopt'optionlist = @_; + *newgetopt'ARGV = *ARGV; + + package newgetopt; + + local ($[) = 0; + local ($genprefix) = "(--|-|\\+)"; + local ($argend) = "--"; + local ($error) = 0; + local ($opt, $optx, $arg, $type, $mand, %opctl); + local ($pkg) = (caller)[0]; + + print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug; + + # See if the first element of the optionlist contains option + # starter characters. + if ( $optionlist[0] =~ /^\W+$/ ) { + $genprefix = shift (@optionlist); + # Turn into regexp. + $genprefix =~ s/(\W)/\\\1/g; + $genprefix = "[" . $genprefix . "]"; + undef $argend; + } + + # Verify correctness of optionlist. + %opctl = (); + foreach $opt ( @optionlist ) { + $opt =~ tr/A-Z/a-z/ if $ignorecase; + if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) { + print STDERR ("Error in option spec: \"", $opt, "\"\n"); + $error++; + next; + } + $opctl{$1} = defined $2 ? $2 : ""; + } + + return 0 if $error; + + if ( $debug ) { + local ($arrow, $k, $v); + $arrow = "=> "; + while ( ($k,$v) = each(%opctl) ) { + print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n"); + $arrow = " "; + } + } + + # Process argument list + + while ( $#ARGV >= 0 ) { + + # >>> See also the continue block <<< + + # Get next argument + $opt = shift (@ARGV); + print STDERR ("=> option \"", $opt, "\"\n") if $debug; + $arg = undef; + + # Check for exhausted list. + if ( $opt =~ /^$genprefix/ ) { + # Double occurrence is terminator + return ($error == 0) + if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend); + $opt = $'; # option name (w/o prefix) + } + else { + # Apparently not an option - push back and exit. + unshift (@ARGV, $opt); + return ($error == 0); + } + + # Look it up. + $opt =~ tr/A-Z/a-z/ if $ignorecase; + unless ( defined ( $type = $opctl{$opt} ) ) { + print STDERR ("Unknown option: ", $opt, "\n"); + $error++; + next; + } + + # Determine argument status. + print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug; + + # If it is an option w/o argument, we're almost finished with it. + if ( $type eq "" ) { + $arg = 1; # supply explicit value + $array = 0; + next; + } + + # Get mandatory status and type info. + ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/; + + # Check if the argument list is exhausted. + if ( $#ARGV < 0 ) { + + # Complain if this option needs an argument. + if ( $mand eq "=" ) { + print STDERR ("Option ", $opt, " requires an argument\n"); + $error++; + } + if ( $mand eq ":" ) { + $arg = $type eq "s" ? "" : 0; + } + next; + } + + # Get (possibly optional) argument. + $arg = shift (@ARGV); + + # Check if it is a valid argument. A mandatory string takes + # anything. + if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) { + + # Check for option list terminator. + if ( $arg eq "$+$+" || + ((defined $argend) && $arg eq $argend)) { + # Push back so the outer loop will terminate. + unshift (@ARGV, $arg); + # Complain if an argument is required. + if ($mand eq "=") { + print STDERR ("Option ", $opt, " requires an argument\n"); + $error++; + undef $arg; # don't assign it + } + else { + # Supply empty value. + $arg = $type eq "s" ? "" : 0; + } + next; + } + + # Maybe the optional argument is the next option? + if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) { + # Yep. Push back. + unshift (@ARGV, $arg); + $arg = $type eq "s" ? "" : 0; + next; + } + } + + if ( $type eq "n" || $type eq "i" ) { # numeric/integer + if ( $arg !~ /^-?[0-9]+$/ ) { + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (number expected)\n"); + $error++; + undef $arg; # don't assign it + } + next; + } + + if ( $type eq "f" ) { # fixed real number, int is also ok + if ( $arg !~ /^-?[0-9.]+$/ ) { + print STDERR ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); + $error++; + undef $arg; # don't assign it + } + next; + } + + if ( $type eq "s" ) { # string + next; + } + + } + continue { + if ( defined $arg ) { + if ( $array ) { + print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n") + if $debug; + eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);"); + } + else { + print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n") + if $debug; + eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;"); + } + } + } + + return ($error == 0); +} +1; diff --git a/gnu/usr.bin/perl/lib/open2.pl b/gnu/usr.bin/perl/lib/open2.pl new file mode 100644 index 0000000..dcd68a8 --- /dev/null +++ b/gnu/usr.bin/perl/lib/open2.pl @@ -0,0 +1,54 @@ +# &open2: tom christiansen, +# +# usage: $pid = &open2('rdr', 'wtr', 'some cmd and args'); +# or $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); +# +# spawn the given $cmd and connect $rdr for +# reading and $wtr for writing. return pid +# of child, or 0 on failure. +# +# WARNING: this is dangerous, as you may block forever +# unless you are very careful. +# +# $wtr is left unbuffered. +# +# abort program if +# rdr or wtr are null +# pipe or fork or exec fails + +package open2; +$fh = 'FHOPEN000'; # package static in case called more than once + +sub main'open2 { + local($kidpid); + local($dad_rdr, $dad_wtr, @cmd) = @_; + + $dad_rdr ne '' || die "open2: rdr should not be null"; + $dad_wtr ne '' || die "open2: wtr should not be null"; + + # force unqualified filehandles into callers' package + local($package) = caller; + $dad_rdr =~ s/^[^']+$/$package'$&/; + $dad_wtr =~ s/^[^']+$/$package'$&/; + + local($kid_rdr) = ++$fh; + local($kid_wtr) = ++$fh; + + pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!"; + pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!"; + + if (($kidpid = fork) < 0) { + die "open2: fork failed: $!"; + } elsif ($kidpid == 0) { + close $dad_rdr; close $dad_wtr; + open(STDIN, "<&$kid_rdr"); + open(STDOUT, ">&$kid_wtr"); + warn "execing @cmd\n" if $debug; + exec @cmd; + die "open2: exec of @cmd failed"; + } + close $kid_rdr; close $kid_wtr; + select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe + $kidpid; +} +1; # so require is happy diff --git a/gnu/usr.bin/perl/lib/perldb.pl b/gnu/usr.bin/perl/lib/perldb.pl new file mode 100644 index 0000000..1aadb93 --- /dev/null +++ b/gnu/usr.bin/perl/lib/perldb.pl @@ -0,0 +1,598 @@ +package DB; + +# modified Perl debugger, to be run from Emacs in perldb-mode +# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 +# Johan Vromans -- upgrade to 4.0 pl 10 + +$header = '$RCSfile: perldb.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:51 $'; +# +# This file is automatically included if you do perl -d. +# It's probably not useful to include this yourself. +# +# Perl supplies the values for @line and %sub. It effectively inserts +# a do DB'DB(); in front of every place that can +# have a breakpoint. It also inserts a do 'perldb.pl' before the first line. +# +# $Log: perldb.pl,v $ +# Revision 1.1.1.1 1993/08/23 21:29:51 nate +# PERL! +# +# Revision 4.0.1.3 92/06/08 13:43:57 lwall +# patch20: support for MSDOS folded into perldb.pl +# patch20: perldb couldn't debug file containing '-', such as STDIN designator +# +# Revision 4.0.1.2 91/11/05 17:55:58 lwall +# patch11: perldb.pl modified to run within emacs in perldb-mode +# +# Revision 4.0.1.1 91/06/07 11:17:44 lwall +# patch4: added $^P variable to control calling of perldb routines +# patch4: debugger sometimes listed wrong number of lines for a statement +# +# Revision 4.0 91/03/20 01:25:50 lwall +# 4.0 baseline. +# +# Revision 3.0.1.6 91/01/11 18:08:58 lwall +# patch42: @_ couldn't be accessed from debugger +# +# Revision 3.0.1.5 90/11/10 01:40:26 lwall +# patch38: the debugger wouldn't stop correctly or do action routines +# +# Revision 3.0.1.4 90/10/15 17:40:38 lwall +# patch29: added caller +# patch29: the debugger now understands packages and evals +# patch29: scripts now run at almost full speed under the debugger +# patch29: more variables are settable from debugger +# +# Revision 3.0.1.3 90/08/09 04:00:58 lwall +# patch19: debugger now allows continuation lines +# patch19: debugger can now dump lists of variables +# patch19: debugger can now add aliases easily from prompt +# +# Revision 3.0.1.2 90/03/12 16:39:39 lwall +# patch13: perl -d didn't format stack traces of *foo right +# patch13: perl -d wiped out scalar return values of subroutines +# +# Revision 3.0.1.1 89/10/26 23:14:02 lwall +# patch1: RCS expanded an unintended $Header in lib/perldb.pl +# +# Revision 3.0 89/10/18 15:19:46 lwall +# 3.0 baseline +# +# Revision 2.0 88/06/05 00:09:45 root +# Baseline version 2.0. +# +# + +if (-e "/dev/tty") { + $console = "/dev/tty"; + $rcfile=".perldb"; +} +else { + $console = "con"; + $rcfile="perldb.ini"; +} + +open(IN, "<$console") || open(IN, "<&STDIN"); # so we don't dingle stdin +open(OUT,">$console") || open(OUT, ">&STDOUT"); # so we don't dongle stdout +select(OUT); +$| = 1; # for DB'OUT +select(STDOUT); +$| = 1; # for real STDOUT +$sub = ''; + +# Is Perl being run from Emacs? +$emacs = $main'ARGV[$[] eq '-emacs'; +shift(@main'ARGV) if $emacs; + +$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; +print OUT "\nLoading DB routines from $header\n"; +print OUT ("Emacs support ", + $emacs ? "enabled" : "available", + ".\n"); +print OUT "\nEnter h for help.\n\n"; + +sub DB { + &save; + ($package, $filename, $line) = caller; + $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' . + "package $package;"; # this won't let them modify, alas + local($^P) = 0; # don't debug our own evals + local(*dbline) = "_<$filename"; + $max = $#dbline; + if (($stop,$action) = split(/\0/,$dbline{$line})) { + if ($stop eq '1') { + $signal |= 1; + } + else { + $evalarg = "\$DB'signal |= do {$stop;}"; &eval; + $dbline{$line} =~ s/;9($|\0)/$1/; + } + } + if ($single || $trace || $signal) { + if ($emacs) { + print OUT "\032\032$filename:$line:0\n"; + } else { + print OUT "$package'" unless $sub =~ /'/; + print OUT "$sub($filename:$line):\t",$dbline[$line]; + for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { + last if $dbline[$i] =~ /^\s*(}|#|\n)/; + print OUT "$sub($filename:$i):\t",$dbline[$i]; + } + } + } + $evalarg = $action, &eval if $action; + if ($single || $signal) { + $evalarg = $pre, &eval if $pre; + print OUT $#stack . " levels deep in subroutine calls!\n" + if $single & 4; + $start = $line; + CMD: + while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) { + { + $single = 0; + $signal = 0; + $cmd eq '' && exit 0; + chop($cmd); + $cmd =~ s/\\$// && do { + print OUT " cont: "; + $cmd .= &gets; + redo CMD; + }; + $cmd =~ /^q$/ && exit 0; + $cmd =~ /^$/ && ($cmd = $laststep); + push(@hist,$cmd) if length($cmd) > 1; + ($i) = split(/\s+/,$cmd); + eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; + $cmd =~ /^h$/ && do { + print OUT " +T Stack trace. +s Single step. +n Next, steps over subroutine calls. +r Return from current subroutine. +c [line] Continue; optionally inserts a one-time-only breakpoint + at the specified line. + Repeat last n or s. +l min+incr List incr+1 lines starting at min. +l min-max List lines. +l line List line; +l List next window. +- List previous window. +w line List window around line. +l subname List subroutine. +f filename Switch to filename. +/pattern/ Search forwards for pattern; final / is optional. +?pattern? Search backwards for pattern. +L List breakpoints and actions. +S List subroutine names. +t Toggle trace mode. +b [line] [condition] + Set breakpoint; line defaults to the current execution line; + condition breaks if it evaluates to true, defaults to \'1\'. +b subname [condition] + Set breakpoint at first line of subroutine. +d [line] Delete breakpoint. +D Delete all breakpoints. +a [line] command + Set an action to be done before the line is executed. + Sequence is: check for breakpoint, print line if necessary, + do action, prompt user if breakpoint or step, evaluate line. +A Delete all actions. +V [pkg [vars]] List some (default all) variables in package (default current). +X [vars] Same as \"V currentpackage [vars]\". +< command Define command before prompt. +> command Define command after prompt. +! number Redo command (default previous command). +! -number Redo number\'th to last command. +H -number Display last number commands (default all). +q or ^D Quit. +p expr Same as \"print DB'OUT expr\" in current package. += [alias value] Define a command alias, or list current aliases. +command Execute as a perl statement in current package. + +"; + next CMD; }; + $cmd =~ /^t$/ && do { + $trace = !$trace; + print OUT "Trace = ".($trace?"on":"off")."\n"; + next CMD; }; + $cmd =~ /^S$/ && do { + foreach $subname (sort(keys %sub)) { + print OUT $subname,"\n"; + } + next CMD; }; + $cmd =~ s/^X\b/V $package/; + $cmd =~ /^V$/ && do { + $cmd = 'V $package'; }; + $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do { + $packname = $1; + @vars = split(' ',$2); + do 'dumpvar.pl' unless defined &main'dumpvar; + if (defined &main'dumpvar) { + &main'dumpvar($packname,@vars); + } + else { + print DB'OUT "dumpvar.pl not available.\n"; + } + next CMD; }; + $cmd =~ /^f\b\s*(.*)/ && do { + $file = $1; + if (!$file) { + print OUT "The old f command is now the r command.\n"; + print OUT "The new f command switches filenames.\n"; + next CMD; + } + if (!defined $_main{'_<' . $file}) { + if (($try) = grep(m#^_<.*$file#, keys %_main)) { + $file = substr($try,2); + print "\n$file:\n"; + } + } + if (!defined $_main{'_<' . $file}) { + print OUT "There's no code here anything matching $file.\n"; + next CMD; + } + elsif ($file ne $filename) { + *dbline = "_<$file"; + $max = $#dbline; + $filename = $file; + $start = 1; + $cmd = "l"; + } }; + $cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do { + $subname = $1; + $subname = "main'" . $subname unless $subname =~ /'/; + $subname = "main" . $subname if substr($subname,0,1) eq "'"; + ($file,$subrange) = split(/:/,$sub{$subname}); + if ($file ne $filename) { + *dbline = "_<$file"; + $max = $#dbline; + $filename = $file; + } + if ($subrange) { + if (eval($subrange) < -$window) { + $subrange =~ s/-.*/+/; + } + $cmd = "l $subrange"; + } else { + print OUT "Subroutine $1 not found.\n"; + next CMD; + } }; + $cmd =~ /^w\b\s*(\d*)$/ && do { + $incr = $window - 1; + $start = $1 if $1; + $start -= $preview; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^-$/ && do { + $incr = $window - 1; + $cmd = 'l ' . ($start-$window*2) . '+'; }; + $cmd =~ /^l$/ && do { + $incr = $window - 1; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do { + $start = $1 if $1; + $incr = $2; + $incr = $window - 1 unless $incr; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { + $end = (!$2) ? $max : ($4 ? $4 : $2); + $end = $max if $end > $max; + $i = $2; + $i = $line if $i eq '.'; + $i = 1 if $i < 1; + if ($emacs) { + print OUT "\032\032$filename:$i:0\n"; + $i = $end; + } else { + for (; $i <= $end; $i++) { + print OUT "$i:\t", $dbline[$i]; + last if $signal; + } + } + $start = $i; # remember in case they want more + $start = $max if $start > $max; + next CMD; }; + $cmd =~ /^D$/ && do { + print OUT "Deleting all breakpoints...\n"; + for ($i = 1; $i <= $max ; $i++) { + if (defined $dbline{$i}) { + $dbline{$i} =~ s/^[^\0]+//; + if ($dbline{$i} =~ s/^\0?$//) { + delete $dbline{$i}; + } + } + } + next CMD; }; + $cmd =~ /^L$/ && do { + for ($i = 1; $i <= $max; $i++) { + if (defined $dbline{$i}) { + print OUT "$i:\t", $dbline[$i]; + ($stop,$action) = split(/\0/, $dbline{$i}); + print OUT " break if (", $stop, ")\n" + if $stop; + print OUT " action: ", $action, "\n" + if $action; + last if $signal; + } + } + next CMD; }; + $cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do { + $subname = $1; + $cond = $2 || '1'; + $subname = "$package'" . $subname unless $subname =~ /'/; + $subname = "main" . $subname if substr($subname,0,1) eq "'"; + ($filename,$i) = split(/:/, $sub{$subname}); + $i += 0; + if ($i) { + *dbline = "_<$filename"; + ++$i while $dbline[$i] == 0 && $i < $#dbline; + $dbline{$i} =~ s/^[^\0]*/$cond/; + } else { + print OUT "Subroutine $subname not found.\n"; + } + next CMD; }; + $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do { + $i = ($1?$1:$line); + $cond = $2 || '1'; + if ($dbline[$i] == 0) { + print OUT "Line $i not breakable.\n"; + } else { + $dbline{$i} =~ s/^[^\0]*/$cond/; + } + next CMD; }; + $cmd =~ /^d\b\s*(\d+)?/ && do { + $i = ($1?$1:$line); + $dbline{$i} =~ s/^[^\0]*//; + delete $dbline{$i} if $dbline{$i} eq ''; + next CMD; }; + $cmd =~ /^A$/ && do { + for ($i = 1; $i <= $max ; $i++) { + if (defined $dbline{$i}) { + $dbline{$i} =~ s/\0[^\0]*//; + delete $dbline{$i} if $dbline{$i} eq ''; + } + } + next CMD; }; + $cmd =~ /^<\s*(.*)/ && do { + $pre = do action($1); + next CMD; }; + $cmd =~ /^>\s*(.*)/ && do { + $post = do action($1); + next CMD; }; + $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do { + $i = $1; + if ($dbline[$i] == 0) { + print OUT "Line $i may not have an action.\n"; + } else { + $dbline{$i} =~ s/\0[^\0]*//; + $dbline{$i} .= "\0" . do action($3); + } + next CMD; }; + $cmd =~ /^n$/ && do { + $single = 2; + $laststep = $cmd; + last CMD; }; + $cmd =~ /^s$/ && do { + $single = 1; + $laststep = $cmd; + last CMD; }; + $cmd =~ /^c\b\s*(\d*)\s*$/ && do { + $i = $1; + if ($i) { + if ($dbline[$i] == 0) { + print OUT "Line $i not breakable.\n"; + next CMD; + } + $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p. + } + for ($i=0; $i <= $#stack; ) { + $stack[$i++] &= ~1; + } + last CMD; }; + $cmd =~ /^r$/ && do { + $stack[$#stack] |= 2; + last CMD; }; + $cmd =~ /^T$/ && do { + local($p,$f,$l,$s,$h,$a,@a,@sub); + for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { + @a = @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"); + last if $signal; + } + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + print OUT $sub[$i]; + } + next CMD; }; + $cmd =~ /^\/(.*)$/ && do { + $inpat = $1; + $inpat =~ s:([^\\])/$:$1:; + if ($inpat ne "") { + eval '$inpat =~ m'."\n$inpat\n"; + if ($@ ne "") { + print OUT "$@"; + next CMD; + } + $pat = $inpat; + } + $end = $start; + eval ' + for (;;) { + ++$start; + $start = 1 if ($start > $max); + last if ($start == $end); + if ($dbline[$start] =~ m'."\n$pat\n".'i) { + if ($emacs) { + print OUT "\032\032$filename:$start:0\n"; + } else { + print OUT "$start:\t", $dbline[$start], "\n"; + } + last; + } + } '; + print OUT "/$pat/: not found\n" if ($start == $end); + next CMD; }; + $cmd =~ /^\?(.*)$/ && do { + $inpat = $1; + $inpat =~ s:([^\\])\?$:$1:; + if ($inpat ne "") { + eval '$inpat =~ m'."\n$inpat\n"; + if ($@ ne "") { + print OUT "$@"; + next CMD; + } + $pat = $inpat; + } + $end = $start; + eval ' + for (;;) { + --$start; + $start = $max if ($start <= 0); + last if ($start == $end); + if ($dbline[$start] =~ m'."\n$pat\n".'i) { + if ($emacs) { + print OUT "\032\032$filename:$start:0\n"; + } else { + print OUT "$start:\t", $dbline[$start], "\n"; + } + last; + } + } '; + print OUT "?$pat?: not found\n" if ($start == $end); + next CMD; }; + $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { + pop(@hist) if length($cmd) > 1; + $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); + $cmd = $hist[$i] . "\n"; + print OUT $cmd; + redo CMD; }; + $cmd =~ /^!(.+)$/ && do { + $pat = "^$1"; + pop(@hist) if length($cmd) > 1; + for ($i = $#hist; $i; --$i) { + last if $hist[$i] =~ $pat; + } + if (!$i) { + print OUT "No such command!\n\n"; + next CMD; + } + $cmd = $hist[$i] . "\n"; + print OUT $cmd; + redo CMD; }; + $cmd =~ /^H\b\s*(-(\d+))?/ && do { + $end = $2?($#hist-$2):0; + $hist = 0 if $hist < 0; + for ($i=$#hist; $i>$end; $i--) { + print OUT "$i: ",$hist[$i],"\n" + unless $hist[$i] =~ /^.?$/; + }; + next CMD; }; + $cmd =~ s/^p( .*)?$/print DB'OUT$1/; + $cmd =~ /^=/ && do { + if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { + $alias{$k}="s~$k~$v~"; + print OUT "$k = $v\n"; + } elsif ($cmd =~ /^=\s*$/) { + foreach $k (sort keys(%alias)) { + if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { + print OUT "$k = $v\n"; + } else { + print OUT "$k\t$alias{$k}\n"; + }; + }; + }; + next CMD; }; + } + $evalarg = $cmd; &eval; + print OUT "\n"; + } + if ($post) { + $evalarg = $post; &eval; + } + } + ($@, $!, $[, $,, $/, $\) = @saved; +} + +sub save { + @saved = ($@, $!, $[, $,, $/, $\); + $[ = 0; $, = ""; $/ = "\n"; $\ = ""; +} + +# The following takes its argument via $evalarg to preserve current @_ + +sub eval { + eval "$usercontext $evalarg; &DB'save"; + print OUT $@; +} + +sub action { + local($action) = @_; + while ($action =~ s/\\$//) { + print OUT "+ "; + $action .= &gets; + } + $action; +} + +sub gets { + local($.); + ; +} + +sub catch { + $signal = 1; +} + +sub sub { + push(@stack, $single); + $single &= 1; + $single |= 4 if $#stack == $deep; + if (wantarray) { + @i = &$sub; + $single |= pop(@stack); + @i; + } + else { + $i = &$sub; + $single |= pop(@stack); + $i; + } +} + +$single = 1; # so it stops on first executable statement +@hist = ('?'); +$SIG{'INT'} = "DB'catch"; +$deep = 100; # warning if stack gets this deep +$window = 10; +$preview = 3; + +@stack = (0); +@ARGS = @ARGV; +for (@args) { + s/'/\\'/g; + s/(.*)/'$1'/ unless /^-?[\d.]+$/; +} + +if (-f $rcfile) { + do "./$rcfile"; +} +elsif (-f "$ENV{'LOGDIR'}/$rcfile") { + do "$ENV{'LOGDIR'}/$rcfile"; +} +elsif (-f "$ENV{'HOME'}/$rcfile") { + do "$ENV{'HOME'}/$rcfile"; +} + +1; diff --git a/gnu/usr.bin/perl/lib/pwd.pl b/gnu/usr.bin/perl/lib/pwd.pl new file mode 100644 index 0000000..16baadc --- /dev/null +++ b/gnu/usr.bin/perl/lib/pwd.pl @@ -0,0 +1,72 @@ +;# pwd.pl - keeps track of current working directory in PWD environment var +;# +;# $RCSfile: pwd.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $ +;# +;# $Log: pwd.pl,v $ +# Revision 1.1.1.1 1993/08/23 21:29:52 nate +# PERL! +# +;# Revision 4.0.1.1 92/06/08 13:45:22 lwall +;# patch20: support added to pwd.pl to strip automounter crud +;# +;# Revision 4.0 91/03/20 01:26:03 lwall +;# 4.0 baseline. +;# +;# Revision 3.0.1.2 91/01/11 18:09:24 lwall +;# patch42: some .pl files were missing their trailing 1; +;# +;# Revision 3.0.1.1 90/08/09 04:01:24 lwall +;# patch19: Initial revision +;# +;# +;# Usage: +;# require "pwd.pl"; +;# &initpwd; +;# ... +;# &chdir($newdir); + +package pwd; + +sub main'initpwd { + if ($ENV{'PWD'}) { + local($dd,$di) = stat('.'); + local($pd,$pi) = stat($ENV{'PWD'}); + if ($di != $pi || $dd != $pd) { + chop($ENV{'PWD'} = `pwd`); + } + } + else { + chop($ENV{'PWD'} = `pwd`); + } + if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { + local($pd,$pi) = stat($2); + local($dd,$di) = stat($1); + if ($di == $pi && $dd == $pd) { + $ENV{'PWD'}="$2$3"; + } + } +} + +sub main'chdir { + local($newdir) = shift; + if (chdir $newdir) { + if ($newdir =~ m#^/#) { + $ENV{'PWD'} = $newdir; + } + else { + local(@curdir) = split(m#/#,$ENV{'PWD'}); + @curdir = '' unless @curdir; + foreach $component (split(m#/#, $newdir)) { + next if $component eq '.'; + pop(@curdir),next if $component eq '..'; + push(@curdir,$component); + } + $ENV{'PWD'} = join('/',@curdir) || '/'; + } + } + else { + 0; + } +} + +1; diff --git a/gnu/usr.bin/perl/lib/shellwords.pl b/gnu/usr.bin/perl/lib/shellwords.pl new file mode 100644 index 0000000..5d593da --- /dev/null +++ b/gnu/usr.bin/perl/lib/shellwords.pl @@ -0,0 +1,48 @@ +;# shellwords.pl +;# +;# Usage: +;# require 'shellwords.pl'; +;# @words = &shellwords($line); +;# or +;# @words = &shellwords(@lines); +;# or +;# @words = &shellwords; # defaults to $_ (and clobbers it) + +sub shellwords { + package shellwords; + local($_) = join('', @_) if @_; + local(@words,$snippet,$field); + + s/^\s+//; + while ($_ ne '') { + $field = ''; + for (;;) { + if (s/^"(([^"\\]|\\[\\"])*)"//) { + ($snippet = $1) =~ s#\\(.)#$1#g; + } + elsif (/^"/) { + die "Unmatched double quote: $_\n"; + } + elsif (s/^'(([^'\\]|\\[\\'])*)'//) { + ($snippet = $1) =~ s#\\(.)#$1#g; + } + elsif (/^'/) { + die "Unmatched single quote: $_\n"; + } + elsif (s/^\\(.)//) { + $snippet = $1; + } + elsif (s/^([^\s\\'"]+)//) { + $snippet = $1; + } + else { + s/^\s+//; + last; + } + $field .= $snippet; + } + push(@words, $field); + } + @words; +} +1; diff --git a/gnu/usr.bin/perl/lib/stat.pl b/gnu/usr.bin/perl/lib/stat.pl new file mode 100644 index 0000000..6186f54 --- /dev/null +++ b/gnu/usr.bin/perl/lib/stat.pl @@ -0,0 +1,31 @@ +;# $Header: /home/cvs/386BSD/ports/lang/perl/lib/stat.pl,v 1.1.1.1 1993/08/23 21:29:53 nate Exp $ + +;# Usage: +;# require 'stat.pl'; +;# @ary = stat(foo); +;# $st_dev = @ary[$ST_DEV]; +;# +$ST_DEV = 0 + $[; +$ST_INO = 1 + $[; +$ST_MODE = 2 + $[; +$ST_NLINK = 3 + $[; +$ST_UID = 4 + $[; +$ST_GID = 5 + $[; +$ST_RDEV = 6 + $[; +$ST_SIZE = 7 + $[; +$ST_ATIME = 8 + $[; +$ST_MTIME = 9 + $[; +$ST_CTIME = 10 + $[; +$ST_BLKSIZE = 11 + $[; +$ST_BLOCKS = 12 + $[; + +;# Usage: +;# require 'stat.pl'; +;# do Stat('foo'); # sets st_* as a side effect +;# +sub Stat { + ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size, + $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_)); +} + +1; diff --git a/gnu/usr.bin/perl/lib/syslog.pl b/gnu/usr.bin/perl/lib/syslog.pl new file mode 100644 index 0000000..94a4f6a --- /dev/null +++ b/gnu/usr.bin/perl/lib/syslog.pl @@ -0,0 +1,224 @@ +# +# syslog.pl +# +# $Log: syslog.pl,v $ +# Revision 1.1.1.1 1993/08/23 21:29:51 nate +# PERL! +# +# Revision 4.0.1.1 92/06/08 13:48:05 lwall +# patch20: new warning for ambiguous use of unary operators +# +# Revision 4.0 91/03/20 01:26:24 lwall +# 4.0 baseline. +# +# Revision 3.0.1.4 90/11/10 01:41:11 lwall +# patch38: syslog.pl was referencing an absolute path +# +# Revision 3.0.1.3 90/10/15 17:42:18 lwall +# patch29: various portability fixes +# +# Revision 3.0.1.1 90/08/09 03:57:17 lwall +# patch19: Initial revision +# +# Revision 1.2 90/06/11 18:45:30 18:45:30 root () +# - Changed 'warn' to 'mail|warning' in test call (to give example of +# facility specification, and because 'warn' didn't work on HP-UX). +# - Fixed typo in &openlog ("ncons" should be "cons"). +# - Added (package-global) $maskpri, and &setlogmask. +# - In &syslog: +# - put argument test ahead of &connect (why waste cycles?), +# - allowed facility to be specified in &syslog's first arg (temporarily +# overrides any $facility set in &openlog), just as in syslog(3C), +# - do a return 0 when bit for $numpri not set in log mask (see syslog(3C)), +# - changed $whoami code to use getlogin, getpwuid($<) and 'syslog' +# (in that order) when $ident is null, +# - made PID logging consistent with syslog(3C) and subject to $lo_pid only, +# - fixed typo in "print CONS" statement ($ +# modified to use sockets by Larry Wall +# NOTE: openlog now takes three arguments, just like openlog(3) +# +# call syslog() with a string priority and a list of printf() args +# like syslog(3) +# +# usage: require 'syslog.pl'; +# +# then (put these all in a script to test function) +# +# +# do openlog($program,'cons,pid','user'); +# do syslog('info','this is another test'); +# do syslog('mail|warning','this is a better test: %d', time); +# do closelog(); +# +# do syslog('debug','this is the last test'); +# do openlog("$program $$",'ndelay','user'); +# do syslog('notice','fooprogram: this is really done'); +# +# $! = 55; +# do syslog('info','problem was %m'); # %m == $! in syslog(3) + +package syslog; + +$host = 'localhost' unless $host; # set $syslog'host to change + +require 'syslog.ph'; + +$maskpri = &LOG_UPTO(&LOG_DEBUG); + +sub main'openlog { + ($ident, $logopt, $facility) = @_; # package vars + $lo_pid = $logopt =~ /\bpid\b/; + $lo_ndelay = $logopt =~ /\bndelay\b/; + $lo_cons = $logopt =~ /\bcons\b/; + $lo_nowait = $logopt =~ /\bnowait\b/; + &connect if $lo_ndelay; +} + +sub main'closelog { + $facility = $ident = ''; + &disconnect; +} + +sub main'setlogmask { + local($oldmask) = $maskpri; + $maskpri = shift; + $oldmask; +} + +sub main'syslog { + local($priority) = shift; + local($mask) = shift; + local($message, $whoami); + local(@words, $num, $numpri, $numfac, $sum); + local($facility) = $facility; # may need to change temporarily. + + die "syslog: expected both priority and mask" unless $mask && $priority; + + @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". + undef $numpri; + undef $numfac; + foreach (@words) { + $num = &xlate($_); # Translate word to number. + if (/^kern$/ || $num < 0) { + die "syslog: invalid level/facility: $_\n"; + } + elsif ($num <= &LOG_PRIMASK) { + die "syslog: too many levels given: $_\n" if defined($numpri); + $numpri = $num; + return 0 unless &LOG_MASK($numpri) & $maskpri; + } + else { + die "syslog: too many facilities given: $_\n" if defined($numfac); + $facility = $_; + $numfac = $num; + } + } + + die "syslog: level must be given\n" unless defined($numpri); + + if (!defined($numfac)) { # Facility not specified in this call. + $facility = 'user' unless $facility; + $numfac = &xlate($facility); + } + + &connect unless $connected; + + $whoami = $ident; + + if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { + $whoami = $1; + $mask = $2; + } + + unless ($whoami) { + ($whoami = getlogin) || + ($whoami = getpwuid($<)) || + ($whoami = 'syslog'); + } + + $whoami .= "[$$]" if $lo_pid; + + $mask =~ s/%m/$!/g; + $mask .= "\n" unless $mask =~ /\n$/; + $message = sprintf ($mask, @_); + + $sum = $numpri + $numfac; + unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { + if ($lo_cons) { + if ($pid = fork) { + unless ($lo_nowait) { + do {$died = wait;} until $died == $pid || $died < 0; + } + } + else { + open(CONS,">/dev/console"); + print CONS "<$facility.$priority>$whoami: $message\r"; + exit if defined $pid; # if fork failed, we're parent + close CONS; + } + } + } +} + +sub xlate { + local($name) = @_; + $name =~ y/a-z/A-Z/; + $name = "LOG_$name" unless $name =~ /^LOG_/; + $name = "syslog'$name"; + eval(&$name) || -1; +} + +sub connect { + $pat = 'S n C4 x8'; + + $af_unix = 1; + $af_inet = 2; + + $stream = 1; + $datagram = 2; + + ($name,$aliases,$proto) = getprotobyname('udp'); + $udp = $proto; + + ($name,$aliase,$port,$proto) = getservbyname('syslog','udp'); + $syslog = $port; + + if (chop($myname = `hostname`)) { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); + die "Can't lookup $myname\n" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + else { + @bytes = (0,0,0,0); + } + $this = pack($pat, $af_inet, 0, @bytes); + + if ($host =~ /^\d+\./) { + @bytes = split(/\./,$host); + } + else { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); + die "Can't lookup $host\n" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + $that = pack($pat,$af_inet,$syslog,@bytes); + + socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n"; + bind(SYSLOG,$this) || die "bind: $!\n"; + connect(SYSLOG,$that) || die "connect: $!\n"; + + local($old) = select(SYSLOG); $| = 1; select($old); + $connected = 1; +} + +sub disconnect { + close SYSLOG; + $connected = 0; +} + +1; diff --git a/gnu/usr.bin/perl/lib/termcap.pl b/gnu/usr.bin/perl/lib/termcap.pl new file mode 100644 index 0000000..81556db --- /dev/null +++ b/gnu/usr.bin/perl/lib/termcap.pl @@ -0,0 +1,165 @@ +;# $RCSfile: termcap.pl,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:52 $ +;# +;# Usage: +;# require 'ioctl.pl'; +;# ioctl(TTY,$TIOCGETP,$foo); +;# ($ispeed,$ospeed) = unpack('cc',$foo); +;# require 'termcap.pl'; +;# &Tgetent('vt100'); # sets $TC{'cm'}, etc. +;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE'); +;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); +;# +sub Tgetent { + local($TERM) = @_; + local($TERMCAP,$_,$entry,$loop,$field); + + warn "Tgetent: no ospeed set" unless $ospeed; + foreach $key (keys(TC)) { + delete $TC{$key}; + } + $TERM = $ENV{'TERM'} unless $TERM; + $TERMCAP = $ENV{'TERMCAP'}; + $TERMCAP = '/etc/termcap' unless $TERMCAP; + if ($TERMCAP !~ m:^/:) { + if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) { + $TERMCAP = '/etc/termcap'; + } + } + if ($TERMCAP =~ m:^/:) { + $entry = ''; + do { + $loop = " + open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\"; + while () { + next if /^#/; + next if /^\t/; + if (/(^|\\|)$TERM[:\\|]/) { + chop; + while (chop eq '\\\\') { + \$_ .= ; + chop; + } + \$_ .= ':'; + last; + } + } + close TERMCAP; + \$entry .= \$_; + "; + eval $loop; + } while s/:tc=([^:]+):/:/ && ($TERM = $1); + $TERMCAP = $entry; + } + + foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { + if ($field =~ /^\w\w$/) { + $TC{$field} = 1; + } + elsif ($field =~ /^(\w\w)#(.*)/) { + $TC{$1} = $2 if $TC{$1} eq ''; + } + elsif ($field =~ /^(\w\w)=(.*)/) { + $entry = $1; + $_ = $2; + s/\\E/\033/g; + s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; + s/\\n/\n/g; + s/\\r/\r/g; + s/\\t/\t/g; + s/\\b/\b/g; + s/\\f/\f/g; + s/\\\^/\377/g; + s/\^\?/\177/g; + s/\^(.)/pack('c',ord($1) & 31)/eg; + s/\\(.)/$1/g; + s/\377/^/g; + $TC{$entry} = $_ if $TC{$entry} eq ''; + } + } + $TC{'pc'} = "\0" if $TC{'pc'} eq ''; + $TC{'bc'} = "\b" if $TC{'bc'} eq ''; +} + +@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); + +sub Tputs { + local($string,$affcnt,$FH) = @_; + local($ms); + if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { + $ms = $1; + $ms *= $affcnt if $2; + $string = $3; + $decr = $Tputs[$ospeed]; + if ($decr > .1) { + $ms += $decr / 2; + $string .= $TC{'pc'} x ($ms / $decr); + } + } + print $FH $string if $FH; + $string; +} + +sub Tgoto { + local($string) = shift(@_); + local($result) = ''; + local($after) = ''; + local($code,$tmp) = @_; + local(@tmp); + @tmp = ($tmp,$code); + local($online) = 0; + while ($string =~ /^([^%]*)%(.)(.*)/) { + $result .= $1; + $code = $2; + $string = $3; + if ($code eq 'd') { + $result .= sprintf("%d",shift(@tmp)); + } + elsif ($code eq '.') { + $tmp = shift(@tmp); + if ($tmp == 0 || $tmp == 4 || $tmp == 10) { + if ($online) { + ++$tmp, $after .= $TC{'up'} if $TC{'up'}; + } + else { + ++$tmp, $after .= $TC{'bc'}; + } + } + $result .= sprintf("%c",$tmp); + $online = !$online; + } + elsif ($code eq '+') { + $result .= sprintf("%c",shift(@tmp)+ord($string)); + $string = substr($string,1,99); + $online = !$online; + } + elsif ($code eq 'r') { + ($code,$tmp) = @tmp; + @tmp = ($tmp,$code); + $online = !$online; + } + elsif ($code eq '>') { + ($code,$tmp,$string) = unpack("CCa99",$string); + if ($tmp[$[] > $code) { + $tmp[$[] += $tmp; + } + } + elsif ($code eq '2') { + $result .= sprintf("%02d",shift(@tmp)); + $online = !$online; + } + elsif ($code eq '3') { + $result .= sprintf("%03d",shift(@tmp)); + $online = !$online; + } + elsif ($code eq 'i') { + ($code,$tmp) = @tmp; + @tmp = ($code+1,$tmp+1); + } + else { + return "OOPS"; + } + } + $result . $string . $after; +} + +1; diff --git a/gnu/usr.bin/perl/lib/timelocal.pl b/gnu/usr.bin/perl/lib/timelocal.pl new file mode 100644 index 0000000..b7367fa --- /dev/null +++ b/gnu/usr.bin/perl/lib/timelocal.pl @@ -0,0 +1,82 @@ +;# timelocal.pl +;# +;# Usage: +;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year); +;# $time = timegm($sec,$min,$hours,$mday,$mon,$year); + +;# These routines are quite efficient and yet are always guaranteed to agree +;# with localtime() and gmtime(). We manage this by caching the start times +;# of any months we've seen before. If we know the start time of the month, +;# we can always calculate any time within the month. The start times +;# themselves are guessed by successive approximation starting at the +;# current time, since most dates seen in practice are close to the +;# current date. Unlike algorithms that do a binary search (calling gmtime +;# once for each bit of the time value, resulting in 32 calls), this algorithm +;# calls it at most 6 times, and usually only once or twice. If you hit +;# the month cache, of course, it doesn't call it at all. + +;# timelocal is implemented using the same cache. We just assume that we're +;# translating a GMT time, and then fudge it when we're done for the timezone +;# and daylight savings arguments. The timezone is determined by examining +;# the result of localtime(0) when the package is initialized. The daylight +;# savings offset is currently assumed to be one hour. + +CONFIG: { + package timelocal; + + local($[) = 0; + @epoch = localtime(0); + $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT + if ($tzmin > 0) { + $tzmin = 24 * 60 - $tzmin; # minutes west of GMT + $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line + } + + $SEC = 1; + $MIN = 60 * $SEC; + $HR = 60 * $MIN; + $DAYS = 24 * $HR; + $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; +} + +sub timegm { + package timelocal; + + local($[) = 0; + $ym = pack(C2, @_[5,4]); + $cheat = $cheat{$ym} || &cheat; + $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS; +} + +sub timelocal { + package timelocal; + + local($[) = 0; + $time = &main'timegm + $tzmin*$MIN; + @test = localtime($time); + $time -= $HR if $test[2] != $_[2]; + $time; +} + +package timelocal; + +sub cheat { + $year = $_[5]; + $month = $_[4]; + die "Month out of range 0..11 in ctime.pl\n" if $month > 11; + $guess = $^T; + @g = gmtime($guess); + $year += $YearFix if $year < $epoch[5]; + while ($diff = $year - $g[5]) { + $guess += $diff * (363 * $DAYS); + @g = gmtime($guess); + } + while ($diff = $month - $g[4]) { + $guess += $diff * (27 * $DAYS); + @g = gmtime($guess); + } + $g[3]--; + $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS; + $cheat{$ym} = $guess; +} +1; diff --git a/gnu/usr.bin/perl/lib/validate.pl b/gnu/usr.bin/perl/lib/validate.pl new file mode 100644 index 0000000..4b901b6 --- /dev/null +++ b/gnu/usr.bin/perl/lib/validate.pl @@ -0,0 +1,104 @@ +;# $Header: /home/cvs/386BSD/ports/lang/perl/lib/validate.pl,v 1.1.1.1 1993/08/23 21:29:51 nate Exp $ + +;# The validate routine takes a single multiline string consisting of +;# lines containing a filename plus a file test to try on it. (The +;# file test may also be a 'cd', causing subsequent relative filenames +;# to be interpreted relative to that directory.) After the file test +;# you may put '|| die' to make it a fatal error if the file test fails. +;# The default is '|| warn'. The file test may optionally have a ! prepended +;# to test for the opposite condition. If you do a cd and then list some +;# relative filenames, you may want to indent them slightly for readability. +;# If you supply your own "die" or "warn" message, you can use $file to +;# interpolate the filename. + +;# Filetests may be bunched: -rwx tests for all of -r, -w and -x. +;# Only the first failed test of the bunch will produce a warning. + +;# The routine returns the number of warnings issued. + +;# Usage: +;# require "validate.pl"; +;# $warnings += do validate(' +;# /vmunix -e || die +;# /boot -e || die +;# /bin cd +;# csh -ex +;# csh !-ug +;# sh -ex +;# sh !-ug +;# /usr -d || warn "What happened to $file?\n" +;# '); + +sub validate { + local($file,$test,$warnings,$oldwarnings); + foreach $check (split(/\n/,$_[0])) { + next if $check =~ /^#/; + next if $check =~ /^$/; + ($file,$test) = split(' ',$check,2); + if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { + $testlist = $2; + @testlist = split(//,$testlist); + } + else { + @testlist = ('Z'); + } + $oldwarnings = $warnings; + foreach $one (@testlist) { + $this = $test; + $this =~ s/(-\w\b)/$1 \$file/g; + $this =~ s/-Z/-$one/; + $this .= ' || warn' unless $this =~ /\|\|/; + $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/; + $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; + eval $this; + last if $warnings > $oldwarnings; + } + } + $warnings; +} + +sub valmess { + local($disposition,$this) = @_; + $file = $cwd . '/' . $file unless $file =~ m|^/|; + if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { + $neg = $1; + $tmp = $2; + $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); + $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); + $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); + $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); + $tmp eq 'R' && ($mess = "$file is not readable by you."); + $tmp eq 'W' && ($mess = "$file is not writable by you."); + $tmp eq 'X' && ($mess = "$file is not executable by you."); + $tmp eq 'O' && ($mess = "$file is not owned by you."); + $tmp eq 'e' && ($mess = "$file does not exist."); + $tmp eq 'z' && ($mess = "$file does not have zero size."); + $tmp eq 's' && ($mess = "$file does not have non-zero size."); + $tmp eq 'f' && ($mess = "$file is not a plain file."); + $tmp eq 'd' && ($mess = "$file is not a directory."); + $tmp eq 'l' && ($mess = "$file is not a symbolic link."); + $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); + $tmp eq 'S' && ($mess = "$file is not a socket."); + $tmp eq 'b' && ($mess = "$file is not a block special file."); + $tmp eq 'c' && ($mess = "$file is not a character special file."); + $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); + $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); + $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); + $tmp eq 'T' && ($mess = "$file is not a text file."); + $tmp eq 'B' && ($mess = "$file is not a binary file."); + if ($neg eq '!') { + $mess =~ s/ is not / should not be / || + $mess =~ s/ does not / should not / || + $mess =~ s/ not / /; + } + print stderr $mess,"\n"; + } + else { + $this =~ s/\$file/'$file'/g; + print stderr "Can't do $this.\n"; + } + if ($disposition eq 'die') { exit 1; } + ++$warnings; +} + +1; diff --git a/gnu/usr.bin/perl/misc/c2ph b/gnu/usr.bin/perl/misc/c2ph new file mode 100644 index 0000000..0e06c9c --- /dev/null +++ b/gnu/usr.bin/perl/misc/c2ph @@ -0,0 +1,1071 @@ +#!/usr/gnu/bin/perl +# +# +# c2ph (aka pstruct) +# Tom Christiansen, +# +# As pstruct, dump C structures as generated from 'cc -g -S' stabs. +# As c2ph, do this PLUS generate perl code for getting at the structures. +# +# See the usage message for more. If this isn't enough, read the code. +# + +$RCSID = '$RCSfile: c2ph,v $$Revision: 1.2 $$Date: 1994/03/05 01:28:15 $'; + + +###################################################################### + +# some handy data definitions. many of these can be reset later. + +$bitorder = 'b'; # ascending; set to B for descending bit fields + +%intrinsics = +%template = ( + 'char', 'c', + 'unsigned char', 'C', + 'short', 's', + 'short int', 's', + 'unsigned short', 'S', + 'unsigned short int', 'S', + 'short unsigned int', 'S', + 'int', 'i', + 'unsigned int', 'I', + 'long', 'l', + 'long int', 'l', + 'unsigned long', 'L', + 'unsigned long', 'L', + 'long unsigned int', 'L', + 'unsigned long int', 'L', + 'long long', 'q', + 'long long int', 'q', + 'unsigned long long', 'Q', + 'unsigned long long int', 'Q', + 'float', 'f', + 'double', 'd', + 'pointer', 'p', + 'null', 'x', + 'neganull', 'X', + 'bit', $bitorder, +); + +&buildscrunchlist; +delete $intrinsics{'neganull'}; +delete $intrinsics{'bit'}; +delete $intrinsics{'null'}; + +# use -s to recompute sizes +%sizeof = ( + 'char', '1', + 'unsigned char', '1', + 'short', '2', + 'short int', '2', + 'unsigned short', '2', + 'unsigned short int', '2', + 'short unsigned int', '2', + 'int', '4', + 'unsigned int', '4', + 'long', '4', + 'long int', '4', + 'unsigned long', '4', + 'unsigned long int', '4', + 'long unsigned int', '4', + 'long long', '8', + 'long long int', '8', + 'unsigned long long', '8', + 'unsigned long long int', '8', + 'float', '4', + 'double', '8', + 'pointer', '4', +); + +($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); + +($offset_fmt, $size_fmt) = ('d', 'd'); + +$indent = 2; + +$CC = 'cc'; +$CFLAGS = '-g -S'; +$DEFINES = ''; + +$perl++ if $0 =~ m#/?c2ph$#; + +require 'getopts.pl'; + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +&Getopts('aixdpvtnws:') || &usage(0); + +$opt_d && $debug++; +$opt_t && $trace++; +$opt_p && $perl++; +$opt_v && $verbose++; +$opt_n && ($perl = 0); + +if ($opt_w) { + ($type_width, $member_width, $offset_width) = (45, 35, 8); +} +if ($opt_x) { + ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); +} + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +sub PLUMBER { + select(STDERR); + print "oops, apperent pager foulup\n"; + $isatty++; + &usage(1); +} + +sub usage { + local($oops) = @_; + unless (-t STDOUT) { + select(STDERR); + } elsif (!$oops) { + $isatty++; + $| = 1; + print "hit for further explanation: "; + ; + open (PIPE, "|". ($ENV{PAGER} || 'more')); + $SIG{PIPE} = PLUMBER; + select(PIPE); + } + + print "usage: $0 [-dpnP] [var=val] [files ...]\n"; + + exit unless $isatty; + + print < 1) { + warn "Only one *.s file allowed!\n"; + &usage; + } + } + elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { + local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; + $chdir = "cd $dir; " if $dir; + &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; + $ARGV[0] =~ s/\.c$/.s/; + } + else { + $TMP = "/tmp/c2ph.$$.c"; + &system("cat @ARGV > $TMP") && exit 1; + &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1; + unlink $TMP; + $TMP =~ s/\.c$/.s/; + @ARGV = ($TMP); + } +} + +if ($opt_s) { + for (split(/[\s,]+/, $opt_s)) { + $interested{$_}++; + } +} + + +$| = 1 if $debug; + +main: { + + if ($trace) { + if (-t && !@ARGV) { + print STDERR "reading from your keyboard: "; + } else { + print STDERR "reading from " . (@ARGV ? "@ARGV" : "").": "; + } + } + +STAB: while (<>) { + if ($trace && !($. % 10)) { + $lineno = $..''; + print STDERR $lineno, "\b" x length($lineno); + } + next unless /^\s*\.stabs\s+/; + $line = $_; + s/^\s*\.stabs\s+//; + &stab; + } + print STDERR "$.\n" if $trace; + unlink $TMP if $TMP; + + &compute_intrinsics if $perl && !$opt_i; + + print STDERR "resolving types\n" if $trace; + + &resolve_types; + &adjust_start_addrs; + + $sum = 2 + $type_width + $member_width; + $pmask1 = "%-${type_width}s %-${member_width}s"; + $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; + + if ($perl) { + # resolve template -- should be in stab define order, but even this isn't enough. + print STDERR "\nbuilding type templates: " if $trace; + for $i (reverse 0..$#type) { + next unless defined($name = $type[$i]); + next unless defined $struct{$name}; + $build_recursed = 0; + &build_template($name) unless defined $template{&psou($name)} || + $opt_s && !$interested{$name}; + } + print STDERR "\n\n" if $trace; + } + + print STDERR "dumping structs: " if $trace; + + + foreach $name (sort keys %struct) { + next if $opt_s && !$interested{$name}; + print STDERR "$name " if $trace; + + undef @sizeof; + undef @typedef; + undef @offsetof; + undef @indices; + undef @typeof; + + $mname = &munge($name); + + $fname = &psou($name); + + print "# " if $perl && $verbose; + $pcode = ''; + print "$fname {\n" if !$perl || $verbose; + $template{$fname} = &scrunch($template{$fname}) if $perl; + &pstruct($name,$name,0); + print "# " if $perl && $verbose; + print "}\n" if !$perl || $verbose; + print "\n" if $perl && $verbose; + + if ($perl) { + print "$pcode"; + + printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); + + print < $sizeof{$b}; } + + + foreach $name (sort keys %intrinsics) { + print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; + } + + print "\n1;\n"; + + exit; +} + +######################################################################################## + + +sub stab { + next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun + s/"// || next; + s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; + + next if /^\s*$/; + + $size = $3 if $3; + + + $line = $_; + + if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { + print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; + &pdecl($pdecl); + next; + } + + + + if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { + local($ident) = $2; + push(@intrinsics, $ident); + $typeno = &typeno($3); + $type[$typeno] = $ident; + print STDERR "intrinsic $ident in new type $typeno\n" if $debug; + next; + } + + if (($name, $typeordef, $typeno, $extra, $struct, $_) + = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) + { + $typeno = &typeno($typeno); # sun foolery + } + elsif (/^[\$\w]+:/) { + next; # variable + } + else { + warn "can't grok stab: <$_> in: $line " if $_; + next; + } + + #warn "got size $size for $name\n"; + $sizeof{$name} = $size if $size; + + s/;[-\d]*;[-\d]*;$//; # we don't care about ranges + + $typenos{$name} = $typeno; + + unless (defined $type[$typeno]) { + &panic("type 0??") unless $typeno; + $type[$typeno] = $name unless defined $type[$typeno]; + printf "new type $typeno is $name" if $debug; + if ($extra =~ /\*/ && defined $type[$struct]) { + print ", a typedef for a pointer to " , $type[$struct] if $debug; + } + } else { + printf "%s is type %d", $name, $typeno if $debug; + print ", a typedef for " , $type[$typeno] if $debug; + } + print "\n" if $debug; + #next unless $extra =~ /[su*]/; + + #$type[$struct] = $name; + + if ($extra =~ /[us*]/) { + &sou($name, $extra); + $_ = &sdecl($name, $_, 0); + } + elsif (/^=ar/) { + print "it's a bare array typedef -- that's pretty sick\n" if $debug; + $_ = "$typeno$_"; + $scripts = ''; + $_ = &adecl($_,1); + + } + elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc + push(@intrinsics, $2); + $typeno = &typeno($3); + $type[$typeno] = $2; + print STDERR "intrinsic $2 in new type $typeno\n" if $debug; + } + elsif (s/^=e//) { # blessed by thy compiler; mine won't do this + &edecl; + } + else { + warn "Funny remainder for $name on line $_ left in $line " if $_; + } +} + +sub typeno { # sun thinks types are (0,27) instead of just 27 + local($_) = @_; + s/\(\d+,(\d+)\)/$1/; + $_; +} + +sub pstruct { + local($what,$prefix,$base) = @_; + local($field, $fieldname, $typeno, $count, $offset, $entry); + local($fieldtype); + local($type, $tname); + local($mytype, $mycount, $entry2); + local($struct_count) = 0; + local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); + local($bits,$bytes); + local($template); + + + local($mname) = &munge($name); + + sub munge { + local($_) = @_; + s/[\s\$\.]/_/g; + $_; + } + + local($sname) = &psou($what); + + $nesting++; + + for $field (split(/;/, $struct{$what})) { + $pad = $prepad = 0; + $entry = ''; + ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); + + $type = $type[$typeno]; + + $type =~ /([^[]*)(\[.*\])?/; + $mytype = $1; + $count .= $2; + $fieldtype = &psou($mytype); + + local($fname) = &psou($name); + + if ($build_templates) { + + $pad = ($offset - ($lastoffset + $lastlength))/8 + if defined $lastoffset; + + if (! $finished_template{$sname}) { + if ($isaunion{$what}) { + $template{$sname} .= 'X' x $revpad . ' ' if $revpad; + } else { + $template{$sname} .= 'x' x $pad . ' ' if $pad; + } + } + + $template = &fetch_template($type) x + ($count ? &scripts2count($count) : 1); + + if (! $finished_template{$sname}) { + $template{$sname} .= $template; + } + + $revpad = $length/8 if $isaunion{$what}; + + ($lastoffset, $lastlength) = ($offset, $length); + + } else { + print '# ' if $perl && $verbose; + $entry = sprintf($pmask1, + ' ' x ($nesting * $indent) . $fieldtype, + "$prefix.$fieldname" . $count); + + $entry =~ s/(\*+)( )/$2$1/; + + printf $pmask2, + $entry, + ($base+$offset)/8, + ($bits = ($base+$offset)%8) ? ".$bits" : " ", + $length/8, + ($bits = $length % 8) ? ".$bits": "" + if !$perl || $verbose; + + + if ($perl && $nesting == 1) { + $template = &scrunch(&fetch_template($type) x + ($count ? &scripts2count($count) : 1)); + push(@sizeof, int($length/8) .",\t# $fieldname"); + push(@offsetof, int($offset/8) .",\t# $fieldname"); + push(@typedef, "'$template', \t# $fieldname"); + $type =~ s/(struct|union) //; + push(@typeof, "'$type" . ($count ? $count : '') . + "',\t# $fieldname"); + } + + print ' ', ' ' x $indent x $nesting, $template + if $perl && $verbose; + + print "\n" if !$perl || $verbose; + + } + if ($perl) { + local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; + $mycount *= &scripts2count($count) if $count; + if ($nesting==1 && !$build_templates) { + $pcode .= sprintf("sub %-32s { %4d; }\n", + "${mname}'${fieldname}", $struct_count); + push(@indices, $struct_count); + } + $struct_count += $mycount; + } + + + &pstruct($type, "$prefix.$fieldname", $base+$offset) + if $recurse && defined $struct{$type}; + } + + $countof{$what} = $struct_count unless defined $countof{$whati}; + + $template{$sname} .= '$' if $build_templates; + $finished_template{$sname}++; + + if ($build_templates && !defined $sizeof{$name}) { + local($fmt) = &scrunch($template{$sname}); + print STDERR "no size for $name, punting with $fmt..." if $debug; + eval '$sizeof{$name} = length(pack($fmt, ()))'; + if ($@) { + chop $@; + warn "couldn't get size for \$name: $@"; + } else { + print STDERR $sizeof{$name}, "\n" if $debUg; + } + } + + --$nesting; +} + + +sub psize { + local($me) = @_; + local($amstruct) = $struct{$me} ? 'struct ' : ''; + + print '$sizeof{\'', $amstruct, $me, '\'} = '; + printf "%d;\n", $sizeof{$me}; +} + +sub pdecl { + local($pdecl) = @_; + local(@pdecls); + local($tname); + + warn "pdecl: $pdecl\n" if $debug; + + $pdecl =~ s/\(\d+,(\d+)\)/$1/g; + $pdecl =~ s/\*//g; + @pdecls = split(/=/, $pdecl); + $typeno = $pdecls[0]; + $tname = pop @pdecls; + + if ($tname =~ s/^f//) { $tname = "$tname&"; } + #else { $tname = "$tname*"; } + + for (reverse @pdecls) { + $tname .= s/^f// ? "&" : "*"; + #$tname =~ s/^f(.*)/$1&/; + print "type[$_] is $tname\n" if $debug; + $type[$_] = $tname unless defined $type[$_]; + } +} + + + +sub adecl { + ($arraytype, $unknown, $lower, $upper) = (); + #local($typeno); + # global $typeno, @type + local($_, $typedef) = @_; + + while (s/^((\d+)=)?ar(\d+);//) { + ($arraytype, $unknown) = ($2, $3); + if (s/^(\d+);(\d+);//) { + ($lower, $upper) = ($1, $2); + $scripts .= '[' . ($upper+1) . ']'; + } else { + warn "can't find array bounds: $_"; + } + } + if (s/^([\d*f=]*),(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + local($whatis) = $1; + if ($whatis =~ /^(\d+)=/) { + $typeno = $1; + &pdecl($whatis); + } else { + $typeno = $whatis; + } + } elsif (s/^(\d+)(=[*suf]\d*)//) { + local($whatis) = $2; + + if ($whatis =~ /[f*]/) { + &pdecl($whatis); + } elsif ($whatis =~ /[su]/) { # + print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" + if $debug; + #$type[$typeno] = $name unless defined $type[$typeno]; + ##printf "new type $typeno is $name" if $debug; + $typeno = $1; + $type[$typeno] = "$prefix.$fieldname"; + local($name) = $type[$typeno]; + &sou($name, $whatis); + $_ = &sdecl($name, $_, $start+$offset); + 1; + $start = $start{$name}; + $offset = $sizeof{$name}; + $length = $offset; + } else { + warn "what's this? $whatis in $line "; + } + } elsif (/^\d+$/) { + $typeno = $_; + } else { + warn "bad array stab: $_ in $line "; + next STAB; + } + #local($wasdef) = defined($type[$typeno]) && $debug; + #if ($typedef) { + #print "redefining $type[$typeno] to " if $wasdef; + #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; + #print "$type[$typeno]\n" if $wasdef; + #} else { + #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; + #} + $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; + print "type[$arraytype] is $type[$arraytype]\n" if $debug; + print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; + $_; +} + + + +sub sdecl { + local($prefix, $_, $offset) = @_; + + local($fieldname, $scripts, $type, $arraytype, $unknown, + $whatis, $pdecl, $upper,$lower, $start,$length) = (); + local($typeno,$sou); + + +SFIELD: + while (/^([^;]+);/) { + $scripts = ''; + warn "sdecl $_\n" if $debug; + if (s/^([\$\w]+)://) { + $fieldname = $1; + } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # + $typeno = &typeno($1); + $type[$typeno] = "$prefix.$fieldname"; + local($name) = "$prefix.$fieldname"; + &sou($name,$2); + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $offset += $sizeof{$name}; + #print "done with anon, start is $start, offset is $offset\n"; + #next SFIELD; + } else { + warn "weird field $_ of $line" if $debug; + next STAB; + #$fieldname = &gensym; + #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + } + + if (/^\d+=ar/) { + $_ = &adecl($_); + } + elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + &panic("no length?") unless $length; + $typeno = &typeno($1) if $1; + } + elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { + ($pdecl, $start, $length) = ($1,$5,$6); + &pdecl($pdecl); + } + elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct + ($typeno, $sou) = ($1, $2); + $typeno = &typeno($typeno); + if (defined($type[$typeno])) { + warn "now how did we get type $1 in $fieldname of $line?"; + } else { + print "anon type $typeno is $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; + }; + local($name) = "$prefix.$fieldname"; + &sou($name,$sou); + print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname"; + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $length = $sizeof{$name}; + } + else { + warn "can't grok stab for $name ($_) in line $line "; + next STAB; + } + + &panic("no length for $prefix.$fieldname") unless $length; + $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; + } + if (s/;\d*,(\d+),(\d+);//) { + local($start, $size) = ($1, $2); + $sizeof{$prefix} = $size; + print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; + $start{$prefix} = $start; + } + $_; +} + +sub edecl { + s/;$//; + $enum{$name} = $_; + $_ = ''; +} + +sub resolve_types { + local($sou); + for $i (0 .. $#type) { + next unless defined $type[$i]; + $_ = $type[$i]; + unless (/\d/) { + print "type[$i] $type[$i]\n" if $debug; + next; + } + print "type[$i] $_ ==> " if $debug; + s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; + s/^(\d+)\&/&type($1)/e; + s/^(\d+)/&type($1)/e; + s/(\*+)([^*]+)(\*+)/$1$3$2/; + s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; + s/^(\d+)([\*\[].*)/&type($1).$2/e; + #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; + $type[$i] = $_; + print "$_\n" if $debug; + } +} +sub type { &psou($type[$_[0]] || ""); } + +sub adjust_start_addrs { + for (sort keys %start) { + ($basename = $_) =~ s/\.[^.]+$//; + $start{$_} += $start{$basename}; + print "start: $_ @ $start{$_}\n" if $debug; + } +} + +sub sou { + local($what, $_) = @_; + /u/ && $isaunion{$what}++; + /s/ && $isastruct{$what}++; +} + +sub psou { + local($what) = @_; + local($prefix) = ''; + if ($isaunion{$what}) { + $prefix = 'union '; + } elsif ($isastruct{$what}) { + $prefix = 'struct '; + } + $prefix . $what; +} + +sub scrunch { + local($_) = @_; + + study; + + s/\$//g; + s/ / /g; + 1 while s/(\w) \1/$1$1/g; + + # i wanna say this, but perl resists my efforts: + # s/(\w)(\1+)/$2 . length($1)/ge; + + &quick_scrunch; + + s/ $//; + + $_; +} + +sub buildscrunchlist { + $scrunch_code = "sub quick_scrunch {\n"; + for (values %intrinsics) { + $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n"; + } + $scrunch_code .= "}\n"; + print "$scrunch_code" if $debug; + eval $scrunch_code; + &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; +} + +sub fetch_template { + local($mytype) = @_; + local($fmt); + local($count) = 1; + + &panic("why do you care?") unless $perl; + + if ($mytype =~ s/(\[\d+\])+$//) { + $count .= $1; + } + + if ($mytype =~ /\*/) { + $fmt = $template{'pointer'}; + } + elsif (defined $template{$mytype}) { + $fmt = $template{$mytype}; + } + elsif (defined $struct{$mytype}) { + if (!defined $template{&psou($mytype)}) { + &build_template($mytype) unless $mytype eq $name; + } + elsif ($template{&psou($mytype)} !~ /\$$/) { + #warn "incomplete template for $mytype\n"; + } + $fmt = $template{&psou($mytype)} || '?'; + } + else { + warn "unknown fmt for $mytype\n"; + $fmt = '?'; + } + + $fmt x $count . ' '; +} + +sub compute_intrinsics { + local($TMP) = "/tmp/c2ph-i.$$.c"; + open (TMP, ">$TMP") || die "can't open $TMP: $!"; + select(TMP); + + print STDERR "computing intrinsic sizes: " if $trace; + + undef %intrinsics; + + print <<'EOF'; +main() { + char *mask = "%d %s\n"; +EOF + + for $type (@intrinsics) { + next if $type eq 'void'; + print <<"EOF"; + printf(mask,sizeof($type), "$type"); +EOF + } + + print <<'EOF'; + printf(mask,sizeof(char *), "pointer"); + exit(0); +} +EOF + close TMP; + + select(STDOUT); + open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|"); + while () { + chop; + split(' ',$_,2);; + print "intrinsic $_[1] is size $_[0]\n" if $debug; + $sizeof{$_[1]} = $_[0]; + $intrinsics{$_[1]} = $template{$_[0]}; + } + close(PIPE) || die "couldn't read intrinsics!"; + unlink($TMP, '/tmp/a.out'); + print STDERR "done\n" if $trace; +} + +sub scripts2count { + local($_) = @_; + + s/^\[//; + s/\]$//; + s/\]\[/*/g; + $_ = eval; + &panic("$_: $@") if $@; + $_; +} + +sub system { + print STDERR "@_\n" if $trace; + system @_; +} + +sub build_template { + local($name) = @_; + + &panic("already got a template for $name") if defined $template{$name}; + + local($build_templates) = 1; + + local($lparen) = '(' x $build_recursed; + local($rparen) = ')' x $build_recursed; + + print STDERR "$lparen$name$rparen " if $trace; + $build_recursed++; + &pstruct($name,$name,0); + print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; + --$build_recursed; +} + + +sub panic { + + select(STDERR); + + print "\npanic: @_\n"; + + exit 1 if $] <= 4.003; # caller broken + + 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"); + last if $signal; + } + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + print $sub[$i]; + } + exit 1; +} + +sub squishseq { + local($num); + local($last) = -1e8; + local($string); + local($seq) = '..'; + + while (defined($num = shift)) { + if ($num == ($last + 1)) { + $string .= $seq unless $inseq++; + $last = $num; + next; + } elsif ($inseq) { + $string .= $last unless $last == -1e8; + } + + $string .= ',' if defined $string; + $string .= $num; + $last = $num; + $inseq = 0; + } + $string .= $last if $inseq && $last != -e18; + $string; +} diff --git a/gnu/usr.bin/perl/misc/c2ph.1 b/gnu/usr.bin/perl/misc/c2ph.1 new file mode 100644 index 0000000..0c3eaee --- /dev/null +++ b/gnu/usr.bin/perl/misc/c2ph.1 @@ -0,0 +1,191 @@ +Article 484 of comp.lang.perl: +Xref: netlabs comp.lang.perl:484 comp.lang.c:983 alt.sources:134 +Path: netlabs!psinntp!iggy.GW.Vitalink.COM!lll-winken!sun-barr!cronkite.Central.Sun.COM!spdev!texsun!convex!tchrist +From: tchrist@convex.com (Tom Christiansen) +Newsgroups: comp.lang.perl,comp.lang.c,alt.sources +Subject: pstruct -- a C structure formatter; AKA c2ph, a C to perl header translator +Keywords: C perl tranlator +Message-ID: <1991Jul25.081021.8104@convex.com> +Date: 25 Jul 91 08:10:21 GMT +Sender: usenet@convex.com (news access account) +Followup-To: comp.lang.perl +Organization: CONVEX Computer Corporation, Richardson, Tx., USA +Lines: 1208 +Nntp-Posting-Host: pixel.convex.com + +Once upon a time, I wrote a program called pstruct. It was a perl +program that tried to parse out C structures and display their member +offsets for you. This was especially useful for people looking at +binary dumps or poking around the kernel. + +Pstruct was not a pretty program. Neither was it particularly robust. +The problem, you see, was that the C compiler was much better at parsing +C than I could ever hope to be. + +So I got smart: I decided to be lazy and let the C compiler parse the C, +which would spit out debugger stabs for me to read. These were much +easier to parse. It's still not a pretty program, but at least it's more +robust. + +Pstruct takes any .c or .h files, or preferably .s ones, since that's +the format it is going to massage them into anyway, and spits out +listings like this: + +struct tty { + int tty.t_locker 000 4 + int tty.t_mutex_index 004 4 + struct tty * tty.t_tp_virt 008 4 + struct clist tty.t_rawq 00c 20 + int tty.t_rawq.c_cc 00c 4 + int tty.t_rawq.c_cmax 010 4 + int tty.t_rawq.c_cfx 014 4 + int tty.t_rawq.c_clx 018 4 + struct tty * tty.t_rawq.c_tp_cpu 01c 4 + struct tty * tty.t_rawq.c_tp_iop 020 4 + unsigned char * tty.t_rawq.c_buf_cpu 024 4 + unsigned char * tty.t_rawq.c_buf_iop 028 4 + struct clist tty.t_canq 02c 20 + int tty.t_canq.c_cc 02c 4 + int tty.t_canq.c_cmax 030 4 + int tty.t_canq.c_cfx 034 4 + int tty.t_canq.c_clx 038 4 + struct tty * tty.t_canq.c_tp_cpu 03c 4 + struct tty * tty.t_canq.c_tp_iop 040 4 + unsigned char * tty.t_canq.c_buf_cpu 044 4 + unsigned char * tty.t_canq.c_buf_iop 048 4 + struct clist tty.t_outq 04c 20 + int tty.t_outq.c_cc 04c 4 + int tty.t_outq.c_cmax 050 4 + int tty.t_outq.c_cfx 054 4 + int tty.t_outq.c_clx 058 4 + struct tty * tty.t_outq.c_tp_cpu 05c 4 + struct tty * tty.t_outq.c_tp_iop 060 4 + unsigned char * tty.t_outq.c_buf_cpu 064 4 + unsigned char * tty.t_outq.c_buf_iop 068 4 + (*int)() tty.t_oproc_cpu 06c 4 + (*int)() tty.t_oproc_iop 070 4 + (*int)() tty.t_stopproc_cpu 074 4 + (*int)() tty.t_stopproc_iop 078 4 + struct thread * tty.t_rsel 07c 4 + + etc. + + +Actually, this was generated by a particular set of options. You can control +the formatting of each column, whether you prefer wide or fat, hex or decimal, +leading zeroes or whatever. + +All you need to be able to use this is a C compiler than generates +BSD/GCC-style stabs. The -g option on native BSD compilers and GCC +should get this for you. + +To learn more, just type a bogus option, like -\?, and a long usage message +will be provided. There are a fair number of possibilities. + +If you're only a C programmer, than this is the end of the message for you. +You can quit right now, and if you care to, save off the source and run it +when you feel like it. Or not. + + + +But if you're a perl programmer, then for you I have something much more +wondrous than just a structure offset printer. + +You see, if you call pstruct by its other incybernation, c2ph, you have a code +generator that translates C code into perl code! Well, structure and union +declarations at least, but that's quite a bit. + +Prior to this point, anyone programming in perl who wanted to interact +with C programs, like the kernel, was forced to guess the layouts of the C +strutures, and then hardwire these into his program. Of course, when you +took your wonderfully to a system where the sgtty structure was laid out +differently, you program broke. Which is a shame. + +We've had Larry's h2ph translator, which helped, but that only works on +cpp symbols, not real C, which was also very much needed. What I offer +you is a symbolic way of getting at all the C structures. I've couched +them in terms of packages and functions. Consider the following program: + + #!/usr/local/bin/perl + + require 'syscall.ph'; + require 'sys/time.ph'; + require 'sys/resource.ph'; + + $ru = "\0" x &rusage'sizeof(); + + syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!"; + + @ru = unpack($t = &rusage'typedef(), $ru); + + $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ] + + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6; + + $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ] + + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6; + + printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime; + + +As you see, the name of the package is the name of the structure. Regular +fields are just their own names. Plus the follwoing accessor functions are +provided for your convenience: + + struct This takes no arguments, and is merely the number of first-level + elements in the structure. You would use this for indexing + into arrays of structures, perhaps like this + + + $usec = $u[ &user'u_utimer + + (&ITIMER_VIRTUAL * &itimerval'struct) + + &itimerval'it_value + + &timeval'tv_usec + ]; + + sizeof Returns the bytes in the structure, or the member if + you pass it an argument, such as + + &rusage'sizeof(&rusage'ru_utime) + + typedef This is the perl format definition for passing to pack and + unpack. If you ask for the typedef of a nothing, you get + the whole structure, otherwise you get that of the member + you ask for. Padding is taken care of, as is the magic to + guarantee that a union is unpacked into all its aliases. + Bitfields are not quite yet supported however. + + offsetof This function is the byte offset into the array of that + member. You may wish to use this for indexing directly + into the packed structure with vec() if you're too lazy + to unpack it. + + typeof Not to be confused with the typedef accessor function, this + one returns the C type of that field. This would allow + you to print out a nice structured pretty print of some + structure without knoning anything about it beforehand. + No args to this one is a noop. Someday I'll post such + a thing to dump out your u structure for you. + + +The way I see this being used is like basically this: + + % h2ph /usr/lib/perl/tmp.ph + % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph + % install + +It's a little tricker with c2ph because you have to get the includes right. +I can't know this for your system, but it's not usually too terribly difficult. + +The code isn't pretty as I mentioned -- I never thought it would be a 1000- +line program when I started, or I might not have begun. :-) But I would have +been less cavalier in how the parts of the program communicated with each +other, etc. It might also have helped if I didn't have to divine the makeup +of the stabs on the fly, and then account for micro differences between my +compiler and gcc. + +Anyway, here it is. Should run on perl v4 or greater. Maybe less. + + +--tom + + diff --git a/gnu/usr.bin/perl/misc/pstruct b/gnu/usr.bin/perl/misc/pstruct new file mode 100644 index 0000000..1009d29 --- /dev/null +++ b/gnu/usr.bin/perl/misc/pstruct @@ -0,0 +1,1071 @@ +#!/usr/gnu/bin/perl +# +# +# c2ph (aka pstruct) +# Tom Christiansen, +# +# As pstruct, dump C structures as generated from 'cc -g -S' stabs. +# As c2ph, do this PLUS generate perl code for getting at the structures. +# +# See the usage message for more. If this isn't enough, read the code. +# + +$RCSID = '$RCSfile: pstruct,v $$Revision: 1.2 $$Date: 1994/03/05 01:28:22 $'; + + +###################################################################### + +# some handy data definitions. many of these can be reset later. + +$bitorder = 'b'; # ascending; set to B for descending bit fields + +%intrinsics = +%template = ( + 'char', 'c', + 'unsigned char', 'C', + 'short', 's', + 'short int', 's', + 'unsigned short', 'S', + 'unsigned short int', 'S', + 'short unsigned int', 'S', + 'int', 'i', + 'unsigned int', 'I', + 'long', 'l', + 'long int', 'l', + 'unsigned long', 'L', + 'unsigned long', 'L', + 'long unsigned int', 'L', + 'unsigned long int', 'L', + 'long long', 'q', + 'long long int', 'q', + 'unsigned long long', 'Q', + 'unsigned long long int', 'Q', + 'float', 'f', + 'double', 'd', + 'pointer', 'p', + 'null', 'x', + 'neganull', 'X', + 'bit', $bitorder, +); + +&buildscrunchlist; +delete $intrinsics{'neganull'}; +delete $intrinsics{'bit'}; +delete $intrinsics{'null'}; + +# use -s to recompute sizes +%sizeof = ( + 'char', '1', + 'unsigned char', '1', + 'short', '2', + 'short int', '2', + 'unsigned short', '2', + 'unsigned short int', '2', + 'short unsigned int', '2', + 'int', '4', + 'unsigned int', '4', + 'long', '4', + 'long int', '4', + 'unsigned long', '4', + 'unsigned long int', '4', + 'long unsigned int', '4', + 'long long', '8', + 'long long int', '8', + 'unsigned long long', '8', + 'unsigned long long int', '8', + 'float', '4', + 'double', '8', + 'pointer', '4', +); + +($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5); + +($offset_fmt, $size_fmt) = ('d', 'd'); + +$indent = 2; + +$CC = 'cc'; +$CFLAGS = '-g -S'; +$DEFINES = ''; + +$perl++ if $0 =~ m#/?c2ph$#; + +require 'getopts.pl'; + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +&Getopts('aixdpvtnws:') || &usage(0); + +$opt_d && $debug++; +$opt_t && $trace++; +$opt_p && $perl++; +$opt_v && $verbose++; +$opt_n && ($perl = 0); + +if ($opt_w) { + ($type_width, $member_width, $offset_width) = (45, 35, 8); +} +if ($opt_x) { + ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 ); +} + +eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift; + +sub PLUMBER { + select(STDERR); + print "oops, apperent pager foulup\n"; + $isatty++; + &usage(1); +} + +sub usage { + local($oops) = @_; + unless (-t STDOUT) { + select(STDERR); + } elsif (!$oops) { + $isatty++; + $| = 1; + print "hit for further explanation: "; + ; + open (PIPE, "|". ($ENV{PAGER} || 'more')); + $SIG{PIPE} = PLUMBER; + select(PIPE); + } + + print "usage: $0 [-dpnP] [var=val] [files ...]\n"; + + exit unless $isatty; + + print < 1) { + warn "Only one *.s file allowed!\n"; + &usage; + } + } + elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) { + local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#; + $chdir = "cd $dir; " if $dir; + &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1; + $ARGV[0] =~ s/\.c$/.s/; + } + else { + $TMP = "/tmp/c2ph.$$.c"; + &system("cat @ARGV > $TMP") && exit 1; + &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1; + unlink $TMP; + $TMP =~ s/\.c$/.s/; + @ARGV = ($TMP); + } +} + +if ($opt_s) { + for (split(/[\s,]+/, $opt_s)) { + $interested{$_}++; + } +} + + +$| = 1 if $debug; + +main: { + + if ($trace) { + if (-t && !@ARGV) { + print STDERR "reading from your keyboard: "; + } else { + print STDERR "reading from " . (@ARGV ? "@ARGV" : "").": "; + } + } + +STAB: while (<>) { + if ($trace && !($. % 10)) { + $lineno = $..''; + print STDERR $lineno, "\b" x length($lineno); + } + next unless /^\s*\.stabs\s+/; + $line = $_; + s/^\s*\.stabs\s+//; + &stab; + } + print STDERR "$.\n" if $trace; + unlink $TMP if $TMP; + + &compute_intrinsics if $perl && !$opt_i; + + print STDERR "resolving types\n" if $trace; + + &resolve_types; + &adjust_start_addrs; + + $sum = 2 + $type_width + $member_width; + $pmask1 = "%-${type_width}s %-${member_width}s"; + $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s"; + + if ($perl) { + # resolve template -- should be in stab define order, but even this isn't enough. + print STDERR "\nbuilding type templates: " if $trace; + for $i (reverse 0..$#type) { + next unless defined($name = $type[$i]); + next unless defined $struct{$name}; + $build_recursed = 0; + &build_template($name) unless defined $template{&psou($name)} || + $opt_s && !$interested{$name}; + } + print STDERR "\n\n" if $trace; + } + + print STDERR "dumping structs: " if $trace; + + + foreach $name (sort keys %struct) { + next if $opt_s && !$interested{$name}; + print STDERR "$name " if $trace; + + undef @sizeof; + undef @typedef; + undef @offsetof; + undef @indices; + undef @typeof; + + $mname = &munge($name); + + $fname = &psou($name); + + print "# " if $perl && $verbose; + $pcode = ''; + print "$fname {\n" if !$perl || $verbose; + $template{$fname} = &scrunch($template{$fname}) if $perl; + &pstruct($name,$name,0); + print "# " if $perl && $verbose; + print "}\n" if !$perl || $verbose; + print "\n" if $perl && $verbose; + + if ($perl) { + print "$pcode"; + + printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name}); + + print < $sizeof{$b}; } + + + foreach $name (sort keys %intrinsics) { + print '$',&munge($name),"'typedef = '", $template{$name}, "';\n"; + } + + print "\n1;\n"; + + exit; +} + +######################################################################################## + + +sub stab { + next unless /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun + s/"// || next; + s/",([x\d]+),([x\d]+),([x\d]+),.*// || next; + + next if /^\s*$/; + + $size = $3 if $3; + + + $line = $_; + + if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) { + print "$name is a typedef for some funky pointers: $pdecl\n" if $debug; + &pdecl($pdecl); + next; + } + + + + if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) { + local($ident) = $2; + push(@intrinsics, $ident); + $typeno = &typeno($3); + $type[$typeno] = $ident; + print STDERR "intrinsic $ident in new type $typeno\n" if $debug; + next; + } + + if (($name, $typeordef, $typeno, $extra, $struct, $_) + = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/) + { + $typeno = &typeno($typeno); # sun foolery + } + elsif (/^[\$\w]+:/) { + next; # variable + } + else { + warn "can't grok stab: <$_> in: $line " if $_; + next; + } + + #warn "got size $size for $name\n"; + $sizeof{$name} = $size if $size; + + s/;[-\d]*;[-\d]*;$//; # we don't care about ranges + + $typenos{$name} = $typeno; + + unless (defined $type[$typeno]) { + &panic("type 0??") unless $typeno; + $type[$typeno] = $name unless defined $type[$typeno]; + printf "new type $typeno is $name" if $debug; + if ($extra =~ /\*/ && defined $type[$struct]) { + print ", a typedef for a pointer to " , $type[$struct] if $debug; + } + } else { + printf "%s is type %d", $name, $typeno if $debug; + print ", a typedef for " , $type[$typeno] if $debug; + } + print "\n" if $debug; + #next unless $extra =~ /[su*]/; + + #$type[$struct] = $name; + + if ($extra =~ /[us*]/) { + &sou($name, $extra); + $_ = &sdecl($name, $_, 0); + } + elsif (/^=ar/) { + print "it's a bare array typedef -- that's pretty sick\n" if $debug; + $_ = "$typeno$_"; + $scripts = ''; + $_ = &adecl($_,1); + + } + elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc + push(@intrinsics, $2); + $typeno = &typeno($3); + $type[$typeno] = $2; + print STDERR "intrinsic $2 in new type $typeno\n" if $debug; + } + elsif (s/^=e//) { # blessed by thy compiler; mine won't do this + &edecl; + } + else { + warn "Funny remainder for $name on line $_ left in $line " if $_; + } +} + +sub typeno { # sun thinks types are (0,27) instead of just 27 + local($_) = @_; + s/\(\d+,(\d+)\)/$1/; + $_; +} + +sub pstruct { + local($what,$prefix,$base) = @_; + local($field, $fieldname, $typeno, $count, $offset, $entry); + local($fieldtype); + local($type, $tname); + local($mytype, $mycount, $entry2); + local($struct_count) = 0; + local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt); + local($bits,$bytes); + local($template); + + + local($mname) = &munge($name); + + sub munge { + local($_) = @_; + s/[\s\$\.]/_/g; + $_; + } + + local($sname) = &psou($what); + + $nesting++; + + for $field (split(/;/, $struct{$what})) { + $pad = $prepad = 0; + $entry = ''; + ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field); + + $type = $type[$typeno]; + + $type =~ /([^[]*)(\[.*\])?/; + $mytype = $1; + $count .= $2; + $fieldtype = &psou($mytype); + + local($fname) = &psou($name); + + if ($build_templates) { + + $pad = ($offset - ($lastoffset + $lastlength))/8 + if defined $lastoffset; + + if (! $finished_template{$sname}) { + if ($isaunion{$what}) { + $template{$sname} .= 'X' x $revpad . ' ' if $revpad; + } else { + $template{$sname} .= 'x' x $pad . ' ' if $pad; + } + } + + $template = &fetch_template($type) x + ($count ? &scripts2count($count) : 1); + + if (! $finished_template{$sname}) { + $template{$sname} .= $template; + } + + $revpad = $length/8 if $isaunion{$what}; + + ($lastoffset, $lastlength) = ($offset, $length); + + } else { + print '# ' if $perl && $verbose; + $entry = sprintf($pmask1, + ' ' x ($nesting * $indent) . $fieldtype, + "$prefix.$fieldname" . $count); + + $entry =~ s/(\*+)( )/$2$1/; + + printf $pmask2, + $entry, + ($base+$offset)/8, + ($bits = ($base+$offset)%8) ? ".$bits" : " ", + $length/8, + ($bits = $length % 8) ? ".$bits": "" + if !$perl || $verbose; + + + if ($perl && $nesting == 1) { + $template = &scrunch(&fetch_template($type) x + ($count ? &scripts2count($count) : 1)); + push(@sizeof, int($length/8) .",\t# $fieldname"); + push(@offsetof, int($offset/8) .",\t# $fieldname"); + push(@typedef, "'$template', \t# $fieldname"); + $type =~ s/(struct|union) //; + push(@typeof, "'$type" . ($count ? $count : '') . + "',\t# $fieldname"); + } + + print ' ', ' ' x $indent x $nesting, $template + if $perl && $verbose; + + print "\n" if !$perl || $verbose; + + } + if ($perl) { + local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1; + $mycount *= &scripts2count($count) if $count; + if ($nesting==1 && !$build_templates) { + $pcode .= sprintf("sub %-32s { %4d; }\n", + "${mname}'${fieldname}", $struct_count); + push(@indices, $struct_count); + } + $struct_count += $mycount; + } + + + &pstruct($type, "$prefix.$fieldname", $base+$offset) + if $recurse && defined $struct{$type}; + } + + $countof{$what} = $struct_count unless defined $countof{$whati}; + + $template{$sname} .= '$' if $build_templates; + $finished_template{$sname}++; + + if ($build_templates && !defined $sizeof{$name}) { + local($fmt) = &scrunch($template{$sname}); + print STDERR "no size for $name, punting with $fmt..." if $debug; + eval '$sizeof{$name} = length(pack($fmt, ()))'; + if ($@) { + chop $@; + warn "couldn't get size for \$name: $@"; + } else { + print STDERR $sizeof{$name}, "\n" if $debUg; + } + } + + --$nesting; +} + + +sub psize { + local($me) = @_; + local($amstruct) = $struct{$me} ? 'struct ' : ''; + + print '$sizeof{\'', $amstruct, $me, '\'} = '; + printf "%d;\n", $sizeof{$me}; +} + +sub pdecl { + local($pdecl) = @_; + local(@pdecls); + local($tname); + + warn "pdecl: $pdecl\n" if $debug; + + $pdecl =~ s/\(\d+,(\d+)\)/$1/g; + $pdecl =~ s/\*//g; + @pdecls = split(/=/, $pdecl); + $typeno = $pdecls[0]; + $tname = pop @pdecls; + + if ($tname =~ s/^f//) { $tname = "$tname&"; } + #else { $tname = "$tname*"; } + + for (reverse @pdecls) { + $tname .= s/^f// ? "&" : "*"; + #$tname =~ s/^f(.*)/$1&/; + print "type[$_] is $tname\n" if $debug; + $type[$_] = $tname unless defined $type[$_]; + } +} + + + +sub adecl { + ($arraytype, $unknown, $lower, $upper) = (); + #local($typeno); + # global $typeno, @type + local($_, $typedef) = @_; + + while (s/^((\d+)=)?ar(\d+);//) { + ($arraytype, $unknown) = ($2, $3); + if (s/^(\d+);(\d+);//) { + ($lower, $upper) = ($1, $2); + $scripts .= '[' . ($upper+1) . ']'; + } else { + warn "can't find array bounds: $_"; + } + } + if (s/^([\d*f=]*),(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + local($whatis) = $1; + if ($whatis =~ /^(\d+)=/) { + $typeno = $1; + &pdecl($whatis); + } else { + $typeno = $whatis; + } + } elsif (s/^(\d+)(=[*suf]\d*)//) { + local($whatis) = $2; + + if ($whatis =~ /[f*]/) { + &pdecl($whatis); + } elsif ($whatis =~ /[su]/) { # + print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n" + if $debug; + #$type[$typeno] = $name unless defined $type[$typeno]; + ##printf "new type $typeno is $name" if $debug; + $typeno = $1; + $type[$typeno] = "$prefix.$fieldname"; + local($name) = $type[$typeno]; + &sou($name, $whatis); + $_ = &sdecl($name, $_, $start+$offset); + 1; + $start = $start{$name}; + $offset = $sizeof{$name}; + $length = $offset; + } else { + warn "what's this? $whatis in $line "; + } + } elsif (/^\d+$/) { + $typeno = $_; + } else { + warn "bad array stab: $_ in $line "; + next STAB; + } + #local($wasdef) = defined($type[$typeno]) && $debug; + #if ($typedef) { + #print "redefining $type[$typeno] to " if $wasdef; + #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno]; + #print "$type[$typeno]\n" if $wasdef; + #} else { + #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype]; + #} + $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno]; + print "type[$arraytype] is $type[$arraytype]\n" if $debug; + print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug; + $_; +} + + + +sub sdecl { + local($prefix, $_, $offset) = @_; + + local($fieldname, $scripts, $type, $arraytype, $unknown, + $whatis, $pdecl, $upper,$lower, $start,$length) = (); + local($typeno,$sou); + + +SFIELD: + while (/^([^;]+);/) { + $scripts = ''; + warn "sdecl $_\n" if $debug; + if (s/^([\$\w]+)://) { + $fieldname = $1; + } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # + $typeno = &typeno($1); + $type[$typeno] = "$prefix.$fieldname"; + local($name) = "$prefix.$fieldname"; + &sou($name,$2); + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $offset += $sizeof{$name}; + #print "done with anon, start is $start, offset is $offset\n"; + #next SFIELD; + } else { + warn "weird field $_ of $line" if $debug; + next STAB; + #$fieldname = &gensym; + #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + } + + if (/^\d+=ar/) { + $_ = &adecl($_); + } + elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) { + ($start, $length) = ($2, $3); + &panic("no length?") unless $length; + $typeno = &typeno($1) if $1; + } + elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) { + ($pdecl, $start, $length) = ($1,$5,$6); + &pdecl($pdecl); + } + elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct + ($typeno, $sou) = ($1, $2); + $typeno = &typeno($typeno); + if (defined($type[$typeno])) { + warn "now how did we get type $1 in $fieldname of $line?"; + } else { + print "anon type $typeno is $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno]; + }; + local($name) = "$prefix.$fieldname"; + &sou($name,$sou); + print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug; + $type[$typeno] = "$prefix.$fieldname"; + $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset); + $start = $start{$name}; + $length = $sizeof{$name}; + } + else { + warn "can't grok stab for $name ($_) in line $line "; + next STAB; + } + + &panic("no length for $prefix.$fieldname") unless $length; + $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';'; + } + if (s/;\d*,(\d+),(\d+);//) { + local($start, $size) = ($1, $2); + $sizeof{$prefix} = $size; + print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug; + $start{$prefix} = $start; + } + $_; +} + +sub edecl { + s/;$//; + $enum{$name} = $_; + $_ = ''; +} + +sub resolve_types { + local($sou); + for $i (0 .. $#type) { + next unless defined $type[$i]; + $_ = $type[$i]; + unless (/\d/) { + print "type[$i] $type[$i]\n" if $debug; + next; + } + print "type[$i] $_ ==> " if $debug; + s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e; + s/^(\d+)\&/&type($1)/e; + s/^(\d+)/&type($1)/e; + s/(\*+)([^*]+)(\*+)/$1$3$2/; + s/\((\*+)(\w+)(\*+)\)/$3($1$2)/; + s/^(\d+)([\*\[].*)/&type($1).$2/e; + #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge; + $type[$i] = $_; + print "$_\n" if $debug; + } +} +sub type { &psou($type[$_[0]] || ""); } + +sub adjust_start_addrs { + for (sort keys %start) { + ($basename = $_) =~ s/\.[^.]+$//; + $start{$_} += $start{$basename}; + print "start: $_ @ $start{$_}\n" if $debug; + } +} + +sub sou { + local($what, $_) = @_; + /u/ && $isaunion{$what}++; + /s/ && $isastruct{$what}++; +} + +sub psou { + local($what) = @_; + local($prefix) = ''; + if ($isaunion{$what}) { + $prefix = 'union '; + } elsif ($isastruct{$what}) { + $prefix = 'struct '; + } + $prefix . $what; +} + +sub scrunch { + local($_) = @_; + + study; + + s/\$//g; + s/ / /g; + 1 while s/(\w) \1/$1$1/g; + + # i wanna say this, but perl resists my efforts: + # s/(\w)(\1+)/$2 . length($1)/ge; + + &quick_scrunch; + + s/ $//; + + $_; +} + +sub buildscrunchlist { + $scrunch_code = "sub quick_scrunch {\n"; + for (values %intrinsics) { + $scrunch_code .= "\ts/($_{2,})/'$_' . length(\$1)/ge;\n"; + } + $scrunch_code .= "}\n"; + print "$scrunch_code" if $debug; + eval $scrunch_code; + &panic("can't eval scrunch_code $@ \nscrunch_code") if $@; +} + +sub fetch_template { + local($mytype) = @_; + local($fmt); + local($count) = 1; + + &panic("why do you care?") unless $perl; + + if ($mytype =~ s/(\[\d+\])+$//) { + $count .= $1; + } + + if ($mytype =~ /\*/) { + $fmt = $template{'pointer'}; + } + elsif (defined $template{$mytype}) { + $fmt = $template{$mytype}; + } + elsif (defined $struct{$mytype}) { + if (!defined $template{&psou($mytype)}) { + &build_template($mytype) unless $mytype eq $name; + } + elsif ($template{&psou($mytype)} !~ /\$$/) { + #warn "incomplete template for $mytype\n"; + } + $fmt = $template{&psou($mytype)} || '?'; + } + else { + warn "unknown fmt for $mytype\n"; + $fmt = '?'; + } + + $fmt x $count . ' '; +} + +sub compute_intrinsics { + local($TMP) = "/tmp/c2ph-i.$$.c"; + open (TMP, ">$TMP") || die "can't open $TMP: $!"; + select(TMP); + + print STDERR "computing intrinsic sizes: " if $trace; + + undef %intrinsics; + + print <<'EOF'; +main() { + char *mask = "%d %s\n"; +EOF + + for $type (@intrinsics) { + next if $type eq 'void'; + print <<"EOF"; + printf(mask,sizeof($type), "$type"); +EOF + } + + print <<'EOF'; + printf(mask,sizeof(char *), "pointer"); + exit(0); +} +EOF + close TMP; + + select(STDOUT); + open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|"); + while () { + chop; + split(' ',$_,2);; + print "intrinsic $_[1] is size $_[0]\n" if $debug; + $sizeof{$_[1]} = $_[0]; + $intrinsics{$_[1]} = $template{$_[0]}; + } + close(PIPE) || die "couldn't read intrinsics!"; + unlink($TMP, '/tmp/a.out'); + print STDERR "done\n" if $trace; +} + +sub scripts2count { + local($_) = @_; + + s/^\[//; + s/\]$//; + s/\]\[/*/g; + $_ = eval; + &panic("$_: $@") if $@; + $_; +} + +sub system { + print STDERR "@_\n" if $trace; + system @_; +} + +sub build_template { + local($name) = @_; + + &panic("already got a template for $name") if defined $template{$name}; + + local($build_templates) = 1; + + local($lparen) = '(' x $build_recursed; + local($rparen) = ')' x $build_recursed; + + print STDERR "$lparen$name$rparen " if $trace; + $build_recursed++; + &pstruct($name,$name,0); + print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug; + --$build_recursed; +} + + +sub panic { + + select(STDERR); + + print "\npanic: @_\n"; + + exit 1 if $] <= 4.003; # caller broken + + 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"); + last if $signal; + } + for ($i=0; $i <= $#sub; $i++) { + last if $signal; + print $sub[$i]; + } + exit 1; +} + +sub squishseq { + local($num); + local($last) = -1e8; + local($string); + local($seq) = '..'; + + while (defined($num = shift)) { + if ($num == ($last + 1)) { + $string .= $seq unless $inseq++; + $last = $num; + next; + } elsif ($inseq) { + $string .= $last unless $last == -1e8; + } + + $string .= ',' if defined $string; + $string .= $num; + $last = $num; + $inseq = 0; + } + $string .= $last if $inseq && $last != -e18; + $string; +} diff --git a/gnu/usr.bin/perl/perl/EXTERN.h b/gnu/usr.bin/perl/perl/EXTERN.h new file mode 100644 index 0000000..181d50d --- /dev/null +++ b/gnu/usr.bin/perl/perl/EXTERN.h @@ -0,0 +1,26 @@ +/* $RCSfile: EXTERN.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:33 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: EXTERN.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:33 nate + * PERL! + * + * Revision 4.0.1.1 91/06/07 10:10:32 lwall + * patch4: new copyright notice + * + * Revision 4.0 91/03/20 00:58:26 lwall + * 4.0 baseline. + * + */ + +#undef EXT +#define EXT extern + +#undef INIT +#define INIT(x) + +#undef DOINIT diff --git a/gnu/usr.bin/perl/perl/INTERN.h b/gnu/usr.bin/perl/perl/INTERN.h new file mode 100644 index 0000000..21c9026 --- /dev/null +++ b/gnu/usr.bin/perl/perl/INTERN.h @@ -0,0 +1,26 @@ +/* $RCSfile: INTERN.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:33 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: INTERN.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:33 nate + * PERL! + * + * Revision 4.0.1.1 91/06/07 10:10:42 lwall + * patch4: new copyright notice + * + * Revision 4.0 91/03/20 00:58:35 lwall + * 4.0 baseline. + * + */ + +#undef EXT +#define EXT + +#undef INIT +#define INIT(x) = x + +#define DOINIT diff --git a/gnu/usr.bin/perl/perl/Makefile b/gnu/usr.bin/perl/perl/Makefile new file mode 100644 index 0000000..2448324 --- /dev/null +++ b/gnu/usr.bin/perl/perl/Makefile @@ -0,0 +1,20 @@ +# +# + +PROG= 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 malloc.c perl.c perly.c regcomp.c regexec.c +SRCS+= stab.c str.c toke.c util.c usersub.c +CFLAGS+= -I${.CURDIR} +LDADD= -lm +DPADD= ${LIBM} + +.if exists (/usr/lib/libcrypt.a) +DPADD+= ${LIBCRYPT} +LDADD+= -lcrypt +.else +SRCS+= crypt.c +.endif + +.include diff --git a/gnu/usr.bin/perl/perl/arg.h b/gnu/usr.bin/perl/perl/arg.h new file mode 100644 index 0000000..0538e08 --- /dev/null +++ b/gnu/usr.bin/perl/perl/arg.h @@ -0,0 +1,994 @@ +/* $RCSfile: arg.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:34 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: arg.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:34 nate + * PERL! + * + * Revision 4.0.1.3 92/06/08 11:44:06 lwall + * patch20: O_PIPE conflicted with Atari + * patch20: clarified debugging output for literals and double-quoted strings + * + * Revision 4.0.1.2 91/11/05 15:51:05 lwall + * patch11: added eval {} + * patch11: added sort {} LIST + * + * Revision 4.0.1.1 91/06/07 10:18:30 lwall + * patch4: length($`), length($&), length($') now optimized to avoid string copy + * patch4: new copyright notice + * patch4: many, many itty-bitty portability fixes + * + * Revision 4.0 91/03/20 01:03:09 lwall + * 4.0 baseline. + * + */ + +#define O_NULL 0 +#define O_RCAT 1 +#define O_ITEM 2 +#define O_SCALAR 3 +#define O_ITEM2 4 +#define O_ITEM3 5 +#define O_CONCAT 6 +#define O_REPEAT 7 +#define O_MATCH 8 +#define O_NMATCH 9 +#define O_SUBST 10 +#define O_NSUBST 11 +#define O_ASSIGN 12 +#define O_LOCAL 13 +#define O_AASSIGN 14 +#define O_SASSIGN 15 +#define O_CHOP 16 +#define O_DEFINED 17 +#define O_UNDEF 18 +#define O_STUDY 19 +#define O_POW 20 +#define O_MULTIPLY 21 +#define O_DIVIDE 22 +#define O_MODULO 23 +#define O_ADD 24 +#define O_SUBTRACT 25 +#define O_LEFT_SHIFT 26 +#define O_RIGHT_SHIFT 27 +#define O_LT 28 +#define O_GT 29 +#define O_LE 30 +#define O_GE 31 +#define O_EQ 32 +#define O_NE 33 +#define O_NCMP 34 +#define O_BIT_AND 35 +#define O_XOR 36 +#define O_BIT_OR 37 +#define O_AND 38 +#define O_OR 39 +#define O_COND_EXPR 40 +#define O_COMMA 41 +#define O_NEGATE 42 +#define O_NOT 43 +#define O_COMPLEMENT 44 +#define O_SELECT 45 +#define O_WRITE 46 +#define O_DBMOPEN 47 +#define O_DBMCLOSE 48 +#define O_OPEN 49 +#define O_TRANS 50 +#define O_NTRANS 51 +#define O_CLOSE 52 +#define O_EACH 53 +#define O_VALUES 54 +#define O_KEYS 55 +#define O_LARRAY 56 +#define O_ARRAY 57 +#define O_AELEM 58 +#define O_DELETE 59 +#define O_LHASH 60 +#define O_HASH 61 +#define O_HELEM 62 +#define O_LAELEM 63 +#define O_LHELEM 64 +#define O_LSLICE 65 +#define O_ASLICE 66 +#define O_HSLICE 67 +#define O_LASLICE 68 +#define O_LHSLICE 69 +#define O_SPLICE 70 +#define O_PUSH 71 +#define O_POP 72 +#define O_SHIFT 73 +#define O_UNPACK 74 +#define O_SPLIT 75 +#define O_LENGTH 76 +#define O_SPRINTF 77 +#define O_SUBSTR 78 +#define O_PACK 79 +#define O_GREP 80 +#define O_JOIN 81 +#define O_SLT 82 +#define O_SGT 83 +#define O_SLE 84 +#define O_SGE 85 +#define O_SEQ 86 +#define O_SNE 87 +#define O_SCMP 88 +#define O_SUBR 89 +#define O_DBSUBR 90 +#define O_CALLER 91 +#define O_SORT 92 +#define O_REVERSE 93 +#define O_WARN 94 +#define O_DIE 95 +#define O_PRTF 96 +#define O_PRINT 97 +#define O_CHDIR 98 +#define O_EXIT 99 +#define O_RESET 100 +#define O_LIST 101 +#define O_EOF 102 +#define O_GETC 103 +#define O_TELL 104 +#define O_RECV 105 +#define O_READ 106 +#define O_SYSREAD 107 +#define O_SYSWRITE 108 +#define O_SEND 109 +#define O_SEEK 110 +#define O_RETURN 111 +#define O_REDO 112 +#define O_NEXT 113 +#define O_LAST 114 +#define O_DUMP 115 +#define O_GOTO 116 +#define O_INDEX 117 +#define O_RINDEX 118 +#define O_TIME 119 +#define O_TMS 120 +#define O_LOCALTIME 121 +#define O_GMTIME 122 +#define O_TRUNCATE 123 +#define O_LSTAT 124 +#define O_STAT 125 +#define O_CRYPT 126 +#define O_ATAN2 127 +#define O_SIN 128 +#define O_COS 129 +#define O_RAND 130 +#define O_SRAND 131 +#define O_EXP 132 +#define O_LOG 133 +#define O_SQRT 134 +#define O_INT 135 +#define O_ORD 136 +#define O_ALARM 137 +#define O_SLEEP 138 +#define O_RANGE 139 +#define O_F_OR_R 140 +#define O_FLIP 141 +#define O_FLOP 142 +#define O_FORK 143 +#define O_WAIT 144 +#define O_WAITPID 145 +#define O_SYSTEM 146 +#define O_EXEC_OP 147 +#define O_HEX 148 +#define O_OCT 149 +#define O_CHOWN 150 +#define O_KILL 151 +#define O_UNLINK 152 +#define O_CHMOD 153 +#define O_UTIME 154 +#define O_UMASK 155 +#define O_MSGGET 156 +#define O_SHMGET 157 +#define O_SEMGET 158 +#define O_MSGCTL 159 +#define O_SHMCTL 160 +#define O_SEMCTL 161 +#define O_MSGSND 162 +#define O_MSGRCV 163 +#define O_SEMOP 164 +#define O_SHMREAD 165 +#define O_SHMWRITE 166 +#define O_RENAME 167 +#define O_LINK 168 +#define O_MKDIR 169 +#define O_RMDIR 170 +#define O_GETPPID 171 +#define O_GETPGRP 172 +#define O_SETPGRP 173 +#define O_GETPRIORITY 174 +#define O_SETPRIORITY 175 +#define O_CHROOT 176 +#define O_FCNTL 177 +#define O_IOCTL 178 +#define O_FLOCK 179 +#define O_UNSHIFT 180 +#define O_REQUIRE 181 +#define O_DOFILE 182 +#define O_EVAL 183 +#define O_FTRREAD 184 +#define O_FTRWRITE 185 +#define O_FTREXEC 186 +#define O_FTEREAD 187 +#define O_FTEWRITE 188 +#define O_FTEEXEC 189 +#define O_FTIS 190 +#define O_FTEOWNED 191 +#define O_FTROWNED 192 +#define O_FTZERO 193 +#define O_FTSIZE 194 +#define O_FTMTIME 195 +#define O_FTATIME 196 +#define O_FTCTIME 197 +#define O_FTSOCK 198 +#define O_FTCHR 199 +#define O_FTBLK 200 +#define O_FTFILE 201 +#define O_FTDIR 202 +#define O_FTPIPE 203 +#define O_FTLINK 204 +#define O_SYMLINK 205 +#define O_READLINK 206 +#define O_FTSUID 207 +#define O_FTSGID 208 +#define O_FTSVTX 209 +#define O_FTTTY 210 +#define O_FTTEXT 211 +#define O_FTBINARY 212 +#define O_SOCKET 213 +#define O_BIND 214 +#define O_CONNECT 215 +#define O_LISTEN 216 +#define O_ACCEPT 217 +#define O_GHBYNAME 218 +#define O_GHBYADDR 219 +#define O_GHOSTENT 220 +#define O_GNBYNAME 221 +#define O_GNBYADDR 222 +#define O_GNETENT 223 +#define O_GPBYNAME 224 +#define O_GPBYNUMBER 225 +#define O_GPROTOENT 226 +#define O_GSBYNAME 227 +#define O_GSBYPORT 228 +#define O_GSERVENT 229 +#define O_SHOSTENT 230 +#define O_SNETENT 231 +#define O_SPROTOENT 232 +#define O_SSERVENT 233 +#define O_EHOSTENT 234 +#define O_ENETENT 235 +#define O_EPROTOENT 236 +#define O_ESERVENT 237 +#define O_SOCKPAIR 238 +#define O_SHUTDOWN 239 +#define O_GSOCKOPT 240 +#define O_SSOCKOPT 241 +#define O_GETSOCKNAME 242 +#define O_GETPEERNAME 243 +#define O_SSELECT 244 +#define O_FILENO 245 +#define O_BINMODE 246 +#define O_VEC 247 +#define O_GPWNAM 248 +#define O_GPWUID 249 +#define O_GPWENT 250 +#define O_SPWENT 251 +#define O_EPWENT 252 +#define O_GGRNAM 253 +#define O_GGRGID 254 +#define O_GGRENT 255 +#define O_SGRENT 256 +#define O_EGRENT 257 +#define O_GETLOGIN 258 +#define O_OPEN_DIR 259 +#define O_READDIR 260 +#define O_TELLDIR 261 +#define O_SEEKDIR 262 +#define O_REWINDDIR 263 +#define O_CLOSEDIR 264 +#define O_SYSCALL 265 +#define O_PIPE_OP 266 +#define O_TRY 267 +#define O_EVALONCE 268 +#define MAXO 269 + +#ifndef DOINIT +extern char *opname[]; +#else +char *opname[] = { + "NULL", + "RCAT", + "ITEM", + "SCALAR", + "ITEM2", + "ITEM3", + "CONCAT", + "REPEAT", + "MATCH", + "NMATCH", + "SUBST", + "NSUBST", + "ASSIGN", + "LOCAL", + "AASSIGN", + "SASSIGN", + "CHOP", + "DEFINED", + "UNDEF", + "STUDY", + "POW", + "MULTIPLY", + "DIVIDE", + "MODULO", + "ADD", + "SUBTRACT", + "LEFT_SHIFT", + "RIGHT_SHIFT", + "LT", + "GT", + "LE", + "GE", + "EQ", + "NE", + "NCMP", + "BIT_AND", + "XOR", + "BIT_OR", + "AND", + "OR", + "COND_EXPR", + "COMMA", + "NEGATE", + "NOT", + "COMPLEMENT", + "SELECT", + "WRITE", + "DBMOPEN", + "DBMCLOSE", + "OPEN", + "TRANS", + "NTRANS", + "CLOSE", + "EACH", + "VALUES", + "KEYS", + "LARRAY", + "ARRAY", + "AELEM", + "DELETE", + "LHASH", + "HASH", + "HELEM", + "LAELEM", + "LHELEM", + "LSLICE", + "ASLICE", + "HSLICE", + "LASLICE", + "LHSLICE", + "SPLICE", + "PUSH", + "POP", + "SHIFT", + "UNPACK", + "SPLIT", + "LENGTH", + "SPRINTF", + "SUBSTR", + "PACK", + "GREP", + "JOIN", + "SLT", + "SGT", + "SLE", + "SGE", + "SEQ", + "SNE", + "SCMP", + "SUBR", + "DBSUBR", + "CALLER", + "SORT", + "REVERSE", + "WARN", + "DIE", + "PRINTF", + "PRINT", + "CHDIR", + "EXIT", + "RESET", + "LIST", + "EOF", + "GETC", + "TELL", + "RECV", + "READ", + "SYSREAD", + "SYSWRITE", + "SEND", + "SEEK", + "RETURN", + "REDO", + "NEXT", + "LAST", + "DUMP", + "GOTO",/* shudder */ + "INDEX", + "RINDEX", + "TIME", + "TIMES", + "LOCALTIME", + "GMTIME", + "TRUNCATE", + "LSTAT", + "STAT", + "CRYPT", + "ATAN2", + "SIN", + "COS", + "RAND", + "SRAND", + "EXP", + "LOG", + "SQRT", + "INT", + "ORD", + "ALARM", + "SLEEP", + "RANGE", + "FLIP_OR_RANGE", + "FLIP", + "FLOP", + "FORK", + "WAIT", + "WAITPID", + "SYSTEM", + "EXEC", + "HEX", + "OCT", + "CHOWN", + "KILL", + "UNLINK", + "CHMOD", + "UTIME", + "UMASK", + "MSGGET", + "SHMGET", + "SEMGET", + "MSGCTL", + "SHMCTL", + "SEMCTL", + "MSGSND", + "MSGRCV", + "SEMOP", + "SHMREAD", + "SHMWRITE", + "RENAME", + "LINK", + "MKDIR", + "RMDIR", + "GETPPID", + "GETPGRP", + "SETPGRP", + "GETPRIORITY", + "SETPRIORITY", + "CHROOT", + "FCNTL", + "SYSIOCTL", + "FLOCK", + "UNSHIFT", + "REQUIRE", + "DOFILE", + "EVAL", + "FTRREAD", + "FTRWRITE", + "FTREXEC", + "FTEREAD", + "FTEWRITE", + "FTEEXEC", + "FTIS", + "FTEOWNED", + "FTROWNED", + "FTZERO", + "FTSIZE", + "FTMTIME", + "FTATIME", + "FTCTIME", + "FTSOCK", + "FTCHR", + "FTBLK", + "FTFILE", + "FTDIR", + "FTPIPE", + "FTLINK", + "SYMLINK", + "READLINK", + "FTSUID", + "FTSGID", + "FTSVTX", + "FTTTY", + "FTTEXT", + "FTBINARY", + "SOCKET", + "BIND", + "CONNECT", + "LISTEN", + "ACCEPT", + "GHBYNAME", + "GHBYADDR", + "GHOSTENT", + "GNBYNAME", + "GNBYADDR", + "GNETENT", + "GPBYNAME", + "GPBYNUMBER", + "GPROTOENT", + "GSBYNAME", + "GSBYPORT", + "GSERVENT", + "SHOSTENT", + "SNETENT", + "SPROTOENT", + "SSERVENT", + "EHOSTENT", + "ENETENT", + "EPROTOENT", + "ESERVENT", + "SOCKPAIR", + "SHUTDOWN", + "GSOCKOPT", + "SSOCKOPT", + "GETSOCKNAME", + "GETPEERNAME", + "SSELECT", + "FILENO", + "BINMODE", + "VEC", + "GPWNAM", + "GPWUID", + "GPWENT", + "SPWENT", + "EPWENT", + "GGRNAM", + "GGRGID", + "GGRENT", + "SGRENT", + "EGRENT", + "GETLOGIN", + "OPENDIR", + "READDIR", + "TELLDIR", + "SEEKDIR", + "REWINDDIR", + "CLOSEDIR", + "SYSCALL", + "PIPE", + "TRY", + "EVALONCE", + "269" +}; +#endif + +#define A_NULL 0 +#define A_EXPR 1 +#define A_CMD 2 +#define A_STAB 3 +#define A_LVAL 4 +#define A_SINGLE 5 +#define A_DOUBLE 6 +#define A_BACKTICK 7 +#define A_READ 8 +#define A_SPAT 9 +#define A_LEXPR 10 +#define A_ARYLEN 11 +#define A_ARYSTAB 12 +#define A_LARYLEN 13 +#define A_GLOB 14 +#define A_WORD 15 +#define A_INDREAD 16 +#define A_LARYSTAB 17 +#define A_STAR 18 +#define A_LSTAR 19 +#define A_WANTARRAY 20 +#define A_LENSTAB 21 + +#define A_MASK 31 +#define A_DONT 32 /* or this into type to suppress evaluation */ + +#ifndef DOINIT +extern char *argname[]; +#else +char *argname[] = { + "A_NULL", + "EXPR", + "CMD", + "STAB", + "LVAL", + "LITERAL", + "DOUBLEQUOTE", + "BACKTICK", + "READ", + "SPAT", + "LEXPR", + "ARYLEN", + "ARYSTAB", + "LARYLEN", + "GLOB", + "WORD", + "INDREAD", + "LARYSTAB", + "STAR", + "LSTAR", + "WANTARRAY", + "LENSTAB", + "22" +}; +#endif + +#ifndef DOINIT +extern bool hoistable[]; +#else +bool hoistable[] = + {0, /* A_NULL */ + 0, /* EXPR */ + 1, /* CMD */ + 1, /* STAB */ + 0, /* LVAL */ + 1, /* SINGLE */ + 0, /* DOUBLE */ + 0, /* BACKTICK */ + 0, /* READ */ + 0, /* SPAT */ + 0, /* LEXPR */ + 1, /* ARYLEN */ + 1, /* ARYSTAB */ + 0, /* LARYLEN */ + 0, /* GLOB */ + 1, /* WORD */ + 0, /* INDREAD */ + 0, /* LARYSTAB */ + 1, /* STAR */ + 1, /* LSTAR */ + 1, /* WANTARRAY */ + 0, /* LENSTAB */ + 0, /* 21 */ +}; +#endif + +union argptr { + ARG *arg_arg; + char *arg_cval; + STAB *arg_stab; + SPAT *arg_spat; + CMD *arg_cmd; + STR *arg_str; + HASH *arg_hash; +}; + +struct arg { + union argptr arg_ptr; + short arg_len; + unsigned short arg_type; + unsigned short arg_flags; +}; + +#define AF_ARYOK 1 /* op can handle multiple values here */ +#define AF_POST 2 /* post *crement this item */ +#define AF_PRE 4 /* pre *crement this item */ +#define AF_UP 8 /* increment rather than decrement */ +#define AF_COMMON 16 /* left and right have symbols in common */ +#define AF_DEPR 32 /* an older form of the construct */ +#define AF_LISTISH 64 /* turn into list if important */ +#define AF_LOCAL 128 /* list of local variables */ + +/* + * Most of the ARG pointers are used as pointers to arrays of ARG. When + * so used, the 0th element is special, and represents the operator to + * use on the list of arguments following. The arg_len in the 0th element + * gives the maximum argument number, and the arg_str is used to store + * the return value in a more-or-less static location. Sorry it's not + * re-entrant (yet), but it sure makes it efficient. The arg_type of the + * 0th element is an operator (O_*) rather than an argument type (A_*). + */ + +#define Nullarg Null(ARG*) + +#ifndef DOINIT +EXT unsigned short opargs[MAXO+1]; +#else +#define A(e1,e2,e3) (e1+(e2<<2)+(e3<<4)) +#define A5(e1,e2,e3,e4,e5) (e1+(e2<<2)+(e3<<4)+(e4<<6)+(e5<<8)) +unsigned short opargs[MAXO+1] = { + A(0,0,0), /* NULL */ + A(1,1,0), /* RCAT */ + A(1,0,0), /* ITEM */ + A(1,0,0), /* SCALAR */ + A(0,0,0), /* ITEM2 */ + A(0,0,0), /* ITEM3 */ + A(1,1,0), /* CONCAT */ + A(3,1,0), /* REPEAT */ + A(1,0,0), /* MATCH */ + A(1,0,0), /* NMATCH */ + A(1,0,0), /* SUBST */ + A(1,0,0), /* NSUBST */ + A(1,1,0), /* ASSIGN */ + A(1,0,0), /* LOCAL */ + A(3,3,0), /* AASSIGN */ + A(0,0,0), /* SASSIGN */ + A(3,0,0), /* CHOP */ + A(1,0,0), /* DEFINED */ + A(1,0,0), /* UNDEF */ + A(1,0,0), /* STUDY */ + A(1,1,0), /* POW */ + A(1,1,0), /* MULTIPLY */ + A(1,1,0), /* DIVIDE */ + A(1,1,0), /* MODULO */ + A(1,1,0), /* ADD */ + A(1,1,0), /* SUBTRACT */ + A(1,1,0), /* LEFT_SHIFT */ + A(1,1,0), /* RIGHT_SHIFT */ + A(1,1,0), /* LT */ + A(1,1,0), /* GT */ + A(1,1,0), /* LE */ + A(1,1,0), /* GE */ + A(1,1,0), /* EQ */ + A(1,1,0), /* NE */ + A(1,1,0), /* NCMP */ + A(1,1,0), /* BIT_AND */ + A(1,1,0), /* XOR */ + A(1,1,0), /* BIT_OR */ + A(1,0,0), /* AND */ + A(1,0,0), /* OR */ + A(1,0,0), /* COND_EXPR */ + A(1,1,0), /* COMMA */ + A(1,0,0), /* NEGATE */ + A(1,0,0), /* NOT */ + A(1,0,0), /* COMPLEMENT */ + A(1,0,0), /* SELECT */ + A(1,0,0), /* WRITE */ + A(1,1,1), /* DBMOPEN */ + A(1,0,0), /* DBMCLOSE */ + A(1,1,0), /* OPEN */ + A(1,0,0), /* TRANS */ + A(1,0,0), /* NTRANS */ + A(1,0,0), /* CLOSE */ + A(0,0,0), /* EACH */ + A(0,0,0), /* VALUES */ + A(0,0,0), /* KEYS */ + A(0,0,0), /* LARRAY */ + A(0,0,0), /* ARRAY */ + A(0,1,0), /* AELEM */ + A(0,1,0), /* DELETE */ + A(0,0,0), /* LHASH */ + A(0,0,0), /* HASH */ + A(0,1,0), /* HELEM */ + A(0,1,0), /* LAELEM */ + A(0,1,0), /* LHELEM */ + A(0,3,3), /* LSLICE */ + A(0,3,0), /* ASLICE */ + A(0,3,0), /* HSLICE */ + A(0,3,0), /* LASLICE */ + A(0,3,0), /* LHSLICE */ + A(0,3,1), /* SPLICE */ + A(0,3,0), /* PUSH */ + A(0,0,0), /* POP */ + A(0,0,0), /* SHIFT */ + A(1,1,0), /* UNPACK */ + A(1,0,1), /* SPLIT */ + A(1,0,0), /* LENGTH */ + A(3,0,0), /* SPRINTF */ + A(1,1,1), /* SUBSTR */ + A(1,3,0), /* PACK */ + A(0,3,0), /* GREP */ + A(1,3,0), /* JOIN */ + A(1,1,0), /* SLT */ + A(1,1,0), /* SGT */ + A(1,1,0), /* SLE */ + A(1,1,0), /* SGE */ + A(1,1,0), /* SEQ */ + A(1,1,0), /* SNE */ + A(1,1,0), /* SCMP */ + A(0,3,0), /* SUBR */ + A(0,3,0), /* DBSUBR */ + A(1,0,0), /* CALLER */ + A(1,3,0), /* SORT */ + A(0,3,0), /* REVERSE */ + A(0,3,0), /* WARN */ + A(0,3,0), /* DIE */ + A(1,3,0), /* PRINTF */ + A(1,3,0), /* PRINT */ + A(1,0,0), /* CHDIR */ + A(1,0,0), /* EXIT */ + A(1,0,0), /* RESET */ + A(3,0,0), /* LIST */ + A(1,0,0), /* EOF */ + A(1,0,0), /* GETC */ + A(1,0,0), /* TELL */ + A5(1,1,1,1,0), /* RECV */ + A(1,1,3), /* READ */ + A(1,1,3), /* SYSREAD */ + A(1,1,3), /* SYSWRITE */ + A(1,1,3), /* SEND */ + A(1,1,1), /* SEEK */ + A(0,3,0), /* RETURN */ + A(0,0,0), /* REDO */ + A(0,0,0), /* NEXT */ + A(0,0,0), /* LAST */ + A(0,0,0), /* DUMP */ + A(0,0,0), /* GOTO */ + A(1,1,1), /* INDEX */ + A(1,1,1), /* RINDEX */ + A(0,0,0), /* TIME */ + A(0,0,0), /* TIMES */ + A(1,0,0), /* LOCALTIME */ + A(1,0,0), /* GMTIME */ + A(1,1,0), /* TRUNCATE */ + A(1,0,0), /* LSTAT */ + A(1,0,0), /* STAT */ + A(1,1,0), /* CRYPT */ + A(1,1,0), /* ATAN2 */ + A(1,0,0), /* SIN */ + A(1,0,0), /* COS */ + A(1,0,0), /* RAND */ + A(1,0,0), /* SRAND */ + A(1,0,0), /* EXP */ + A(1,0,0), /* LOG */ + A(1,0,0), /* SQRT */ + A(1,0,0), /* INT */ + A(1,0,0), /* ORD */ + A(1,0,0), /* ALARM */ + A(1,0,0), /* SLEEP */ + A(1,1,0), /* RANGE */ + A(1,0,0), /* F_OR_R */ + A(1,0,0), /* FLIP */ + A(0,1,0), /* FLOP */ + A(0,0,0), /* FORK */ + A(0,0,0), /* WAIT */ + A(1,1,0), /* WAITPID */ + A(1,3,0), /* SYSTEM */ + A(1,3,0), /* EXEC */ + A(1,0,0), /* HEX */ + A(1,0,0), /* OCT */ + A(0,3,0), /* CHOWN */ + A(0,3,0), /* KILL */ + A(0,3,0), /* UNLINK */ + A(0,3,0), /* CHMOD */ + A(0,3,0), /* UTIME */ + A(1,0,0), /* UMASK */ + A(1,1,0), /* MSGGET */ + A(1,1,1), /* SHMGET */ + A(1,1,1), /* SEMGET */ + A(1,1,1), /* MSGCTL */ + A(1,1,1), /* SHMCTL */ + A5(1,1,1,1,0), /* SEMCTL */ + A(1,1,1), /* MSGSND */ + A5(1,1,1,1,1), /* MSGRCV */ + A(1,1,1), /* SEMOP */ + A5(1,1,1,1,0), /* SHMREAD */ + A5(1,1,1,1,0), /* SHMWRITE */ + A(1,1,0), /* RENAME */ + A(1,1,0), /* LINK */ + A(1,1,0), /* MKDIR */ + A(1,0,0), /* RMDIR */ + A(0,0,0), /* GETPPID */ + A(1,0,0), /* GETPGRP */ + A(1,1,0), /* SETPGRP */ + A(1,1,0), /* GETPRIORITY */ + A(1,1,1), /* SETPRIORITY */ + A(1,0,0), /* CHROOT */ + A(1,1,1), /* FCNTL */ + A(1,1,1), /* SYSIOCTL */ + A(1,1,0), /* FLOCK */ + A(0,3,0), /* UNSHIFT */ + A(1,0,0), /* REQUIRE */ + A(1,0,0), /* DOFILE */ + A(1,0,0), /* EVAL */ + A(1,0,0), /* FTRREAD */ + A(1,0,0), /* FTRWRITE */ + A(1,0,0), /* FTREXEC */ + A(1,0,0), /* FTEREAD */ + A(1,0,0), /* FTEWRITE */ + A(1,0,0), /* FTEEXEC */ + A(1,0,0), /* FTIS */ + A(1,0,0), /* FTEOWNED */ + A(1,0,0), /* FTROWNED */ + A(1,0,0), /* FTZERO */ + A(1,0,0), /* FTSIZE */ + A(1,0,0), /* FTMTIME */ + A(1,0,0), /* FTATIME */ + A(1,0,0), /* FTCTIME */ + A(1,0,0), /* FTSOCK */ + A(1,0,0), /* FTCHR */ + A(1,0,0), /* FTBLK */ + A(1,0,0), /* FTFILE */ + A(1,0,0), /* FTDIR */ + A(1,0,0), /* FTPIPE */ + A(1,0,0), /* FTLINK */ + A(1,1,0), /* SYMLINK */ + A(1,0,0), /* READLINK */ + A(1,0,0), /* FTSUID */ + A(1,0,0), /* FTSGID */ + A(1,0,0), /* FTSVTX */ + A(1,0,0), /* FTTTY */ + A(1,0,0), /* FTTEXT */ + A(1,0,0), /* FTBINARY */ + A5(1,1,1,1,0), /* SOCKET */ + A(1,1,0), /* BIND */ + A(1,1,0), /* CONNECT */ + A(1,1,0), /* LISTEN */ + A(1,1,0), /* ACCEPT */ + A(1,0,0), /* GHBYNAME */ + A(1,1,0), /* GHBYADDR */ + A(0,0,0), /* GHOSTENT */ + A(1,0,0), /* GNBYNAME */ + A(1,1,0), /* GNBYADDR */ + A(0,0,0), /* GNETENT */ + A(1,0,0), /* GPBYNAME */ + A(1,0,0), /* GPBYNUMBER */ + A(0,0,0), /* GPROTOENT */ + A(1,1,0), /* GSBYNAME */ + A(1,1,0), /* GSBYPORT */ + A(0,0,0), /* GSERVENT */ + A(1,0,0), /* SHOSTENT */ + A(1,0,0), /* SNETENT */ + A(1,0,0), /* SPROTOENT */ + A(1,0,0), /* SSERVENT */ + A(0,0,0), /* EHOSTENT */ + A(0,0,0), /* ENETENT */ + A(0,0,0), /* EPROTOENT */ + A(0,0,0), /* ESERVENT */ + A5(1,1,1,1,1), /* SOCKPAIR */ + A(1,1,0), /* SHUTDOWN */ + A(1,1,1), /* GSOCKOPT */ + A5(1,1,1,1,0), /* SSOCKOPT */ + A(1,0,0), /* GETSOCKNAME */ + A(1,0,0), /* GETPEERNAME */ + A5(1,1,1,1,0), /* SSELECT */ + A(1,0,0), /* FILENO */ + A(1,0,0), /* BINMODE */ + A(1,1,1), /* VEC */ + A(1,0,0), /* GPWNAM */ + A(1,0,0), /* GPWUID */ + A(0,0,0), /* GPWENT */ + A(0,0,0), /* SPWENT */ + A(0,0,0), /* EPWENT */ + A(1,0,0), /* GGRNAM */ + A(1,0,0), /* GGRGID */ + A(0,0,0), /* GGRENT */ + A(0,0,0), /* SGRENT */ + A(0,0,0), /* EGRENT */ + A(0,0,0), /* GETLOGIN */ + A(1,1,0), /* OPENDIR */ + A(1,0,0), /* READDIR */ + A(1,0,0), /* TELLDIR */ + A(1,1,0), /* SEEKDIR */ + A(1,0,0), /* REWINDDIR */ + A(1,0,0), /* CLOSEDIR */ + A(1,3,0), /* SYSCALL */ + A(1,1,0), /* PIPE */ + A(0,0,0), /* TRY */ + A(1,0,0), /* EVALONCE */ + 0 +}; +#undef A +#undef A5 +#endif + +int do_trans(); +int do_split(); +bool do_eof(); +long do_tell(); +bool do_seek(); +int do_tms(); +int do_time(); +int do_stat(); +STR *do_push(); +FILE *nextargv(); +STR *do_fttext(); +int do_slice(); diff --git a/gnu/usr.bin/perl/perl/array.c b/gnu/usr.bin/perl/perl/array.c new file mode 100644 index 0000000..445bc60 --- /dev/null +++ b/gnu/usr.bin/perl/perl/array.c @@ -0,0 +1,287 @@ +/* $RCSfile: array.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:34 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: array.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:34 nate + * PERL! + * + * Revision 4.0.1.3 92/06/08 11:45:05 lwall + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * + * Revision 4.0.1.2 91/11/05 16:00:14 lwall + * patch11: random cleanup + * patch11: passing non-existend array elements to subrouting caused core dump + * + * Revision 4.0.1.1 91/06/07 10:19:08 lwall + * patch4: new copyright notice + * + * Revision 4.0 91/03/20 01:03:32 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +STR * +afetch(ar,key,lval) +register ARRAY *ar; +int key; +int lval; +{ + STR *str; + + if (key < 0 || key > ar->ary_fill) { + if (lval && key >= 0) { + if (ar->ary_flags & ARF_REAL) + str = Str_new(5,0); + else + str = str_mortal(&str_undef); + (void)astore(ar,key,str); + return str; + } + else + return &str_undef; + } + if (!ar->ary_array[key]) { + if (lval) { + str = Str_new(6,0); + (void)astore(ar,key,str); + return str; + } + return &str_undef; + } + return ar->ary_array[key]; +} + +bool +astore(ar,key,val) +register ARRAY *ar; +int key; +STR *val; +{ + int retval; + + if (key < 0) + return FALSE; + if (key > ar->ary_max) { + int newmax; + + if (ar->ary_alloc != ar->ary_array) { + retval = ar->ary_array - ar->ary_alloc; + Move(ar->ary_array, ar->ary_alloc, ar->ary_max+1, STR*); + Zero(ar->ary_alloc+ar->ary_max+1, retval, STR*); + ar->ary_max += retval; + ar->ary_array -= retval; + if (key > ar->ary_max - 10) { + newmax = key + ar->ary_max; + goto resize; + } + } + else { + if (ar->ary_alloc) { + newmax = key + ar->ary_max / 5; + resize: + Renew(ar->ary_alloc,newmax+1, STR*); + Zero(&ar->ary_alloc[ar->ary_max+1], newmax - ar->ary_max, STR*); + } + else { + newmax = key < 4 ? 4 : key; + Newz(2,ar->ary_alloc, newmax+1, STR*); + } + ar->ary_array = ar->ary_alloc; + ar->ary_max = newmax; + } + } + if (ar->ary_flags & ARF_REAL) { + if (ar->ary_fill < key) { + while (++ar->ary_fill < key) { + if (ar->ary_array[ar->ary_fill] != Nullstr) { + str_free(ar->ary_array[ar->ary_fill]); + ar->ary_array[ar->ary_fill] = Nullstr; + } + } + } + retval = (ar->ary_array[key] != Nullstr); + if (retval) + str_free(ar->ary_array[key]); + } + else + retval = 0; + ar->ary_array[key] = val; + return retval; +} + +ARRAY * +anew(stab) +STAB *stab; +{ + register ARRAY *ar; + + New(1,ar,1,ARRAY); + ar->ary_magic = Str_new(7,0); + ar->ary_alloc = ar->ary_array = 0; + str_magic(ar->ary_magic, stab, '#', Nullch, 0); + ar->ary_max = ar->ary_fill = -1; + ar->ary_flags = ARF_REAL; + return ar; +} + +ARRAY * +afake(stab,size,strp) +STAB *stab; +register int size; +register STR **strp; +{ + register ARRAY *ar; + + New(3,ar,1,ARRAY); + New(4,ar->ary_alloc,size+1,STR*); + Copy(strp,ar->ary_alloc,size,STR*); + ar->ary_array = ar->ary_alloc; + ar->ary_magic = Str_new(8,0); + str_magic(ar->ary_magic, stab, '#', Nullch, 0); + ar->ary_fill = size - 1; + ar->ary_max = size - 1; + ar->ary_flags = 0; + while (size--) { + if (*strp) + (*strp)->str_pok &= ~SP_TEMP; + strp++; + } + return ar; +} + +void +aclear(ar) +register ARRAY *ar; +{ + register int key; + + if (!ar || !(ar->ary_flags & ARF_REAL) || ar->ary_max < 0) + return; + /*SUPPRESS 560*/ + if (key = ar->ary_array - ar->ary_alloc) { + ar->ary_max += key; + ar->ary_array -= key; + } + for (key = 0; key <= ar->ary_max; key++) + str_free(ar->ary_array[key]); + ar->ary_fill = -1; + Zero(ar->ary_array, ar->ary_max+1, STR*); +} + +void +afree(ar) +register ARRAY *ar; +{ + register int key; + + if (!ar) + return; + /*SUPPRESS 560*/ + if (key = ar->ary_array - ar->ary_alloc) { + ar->ary_max += key; + ar->ary_array -= key; + } + if (ar->ary_flags & ARF_REAL) { + for (key = 0; key <= ar->ary_max; key++) + str_free(ar->ary_array[key]); + } + str_free(ar->ary_magic); + Safefree(ar->ary_alloc); + Safefree(ar); +} + +bool +apush(ar,val) +register ARRAY *ar; +STR *val; +{ + return astore(ar,++(ar->ary_fill),val); +} + +STR * +apop(ar) +register ARRAY *ar; +{ + STR *retval; + + if (ar->ary_fill < 0) + return Nullstr; + retval = ar->ary_array[ar->ary_fill]; + ar->ary_array[ar->ary_fill--] = Nullstr; + return retval; +} + +void +aunshift(ar,num) +register ARRAY *ar; +register int num; +{ + register int i; + register STR **sstr,**dstr; + + if (num <= 0) + return; + if (ar->ary_array - ar->ary_alloc >= num) { + ar->ary_max += num; + ar->ary_fill += num; + while (num--) + *--ar->ary_array = Nullstr; + } + else { + (void)astore(ar,ar->ary_fill+num,(STR*)0); /* maybe extend array */ + dstr = ar->ary_array + ar->ary_fill; + sstr = dstr - num; +#ifdef BUGGY_MSC5 + # pragma loop_opt(off) /* don't loop-optimize the following code */ +#endif /* BUGGY_MSC5 */ + for (i = ar->ary_fill - num; i >= 0; i--) { + *dstr-- = *sstr--; +#ifdef BUGGY_MSC5 + # pragma loop_opt() /* loop-optimization back to command-line setting */ +#endif /* BUGGY_MSC5 */ + } + Zero(ar->ary_array, num, STR*); + } +} + +STR * +ashift(ar) +register ARRAY *ar; +{ + STR *retval; + + if (ar->ary_fill < 0) + return Nullstr; + retval = *ar->ary_array; + *(ar->ary_array++) = Nullstr; + ar->ary_max--; + ar->ary_fill--; + return retval; +} + +int +alen(ar) +register ARRAY *ar; +{ + return ar->ary_fill; +} + +void +afill(ar, fill) +register ARRAY *ar; +int fill; +{ + if (fill < 0) + fill = -1; + if (fill <= ar->ary_max) + ar->ary_fill = fill; + else + (void)astore(ar,fill,Nullstr); +} diff --git a/gnu/usr.bin/perl/perl/array.h b/gnu/usr.bin/perl/perl/array.h new file mode 100644 index 0000000..93d4920 --- /dev/null +++ b/gnu/usr.bin/perl/perl/array.h @@ -0,0 +1,45 @@ +/* $RCSfile: array.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:34 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: array.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:34 nate + * PERL! + * + * Revision 4.0.1.2 92/06/08 11:45:57 lwall + * patch20: removed implicit int declarations on funcions + * + * Revision 4.0.1.1 91/06/07 10:19:20 lwall + * patch4: new copyright notice + * + * Revision 4.0 91/03/20 01:03:44 lwall + * 4.0 baseline. + * + */ + +struct atbl { + STR **ary_array; + STR **ary_alloc; + STR *ary_magic; + int ary_max; + int ary_fill; + char ary_flags; +}; + +#define ARF_REAL 1 /* free old entries */ + +STR *afetch(); +bool astore(); +STR *apop(); +STR *ashift(); +void afree(); +void aclear(); +bool apush(); +int alen(); +ARRAY *anew(); +ARRAY *afake(); +void aunshift(); +void afill(); diff --git a/gnu/usr.bin/perl/perl/cflags b/gnu/usr.bin/perl/perl/cflags new file mode 100755 index 0000000..672dfc6 --- /dev/null +++ b/gnu/usr.bin/perl/perl/cflags @@ -0,0 +1,91 @@ +case "$0" in +*/*) cd `expr X$0 : 'X\(.*\)/'` ;; +esac +case $CONFIG in +'') + if test ! -f config.sh; then + ln ../config.sh . || \ + ln ../../config.sh . || \ + ln ../../../config.sh . || \ + (echo "Can't find config.sh."; exit 1) + fi 2>/dev/null + . ./config.sh + ;; +esac + +also=': ' +case $# in +1) also='echo 1>&2 " CCCMD = "' +esac + +case $# in +0) set *.c; echo "The current C flags are:" ;; +esac + +set `echo "$* " | sed 's/\.[oc] / /g'` + +for file do + + case "$#" in + 1) ;; + *) echo $n " $file.c $c" ;; + esac + + : allow variables like toke_cflags to be evaluated + + eval 'eval ${'"${file}_cflags"'-""}' + + : or customize here + + case "$file" in + array) ;; + cmd) ;; + cons) ;; + consarg) ;; + doarg) ;; + doio) ;; + dolist) ;; + dump) ;; + eval) ;; + form) ;; + hash) ;; + malloc) ;; + perl) ;; + perly) ;; + regcomp) ;; + regexec) ;; + stab) ;; + str) ;; + toke) ;; + usersub) ;; + util) ;; + tarray) ;; + tcmd) ;; + tcons) ;; + tconsarg) ;; + tdoarg) ;; + tdoio) ;; + tdolist) ;; + tdump) ;; + teval) ;; + tform) ;; + thash) ;; + tmalloc) ;; + tperl) ;; + tperly) ;; + tregcomp) ;; + tregexec) ;; + tstab) ;; + tstr) ;; + ttoke) ;; + tusersub) ;; + tutil) ;; + *) ;; + esac + + echo "$cc -c $ccflags $optimize $large $split" + eval "$also "'"$cc -c $ccflags $optimize $large $split"' + + . ./config.sh + +done diff --git a/gnu/usr.bin/perl/perl/cmd.c b/gnu/usr.bin/perl/perl/cmd.c new file mode 100644 index 0000000..1ddbde0 --- /dev/null +++ b/gnu/usr.bin/perl/perl/cmd.c @@ -0,0 +1,1263 @@ +/* $RCSfile: cmd.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:35 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: cmd.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:35 nate + * PERL! + * + * Revision 4.0.1.5 92/06/08 12:00:39 lwall + * patch20: the switch optimizer didn't do anything in subroutines + * patch20: removed implicit int declarations on funcions + * + * Revision 4.0.1.4 91/11/11 16:29:33 lwall + * patch19: do {$foo ne "bar";} returned wrong value + * patch19: some earlier patches weren't propagated to alternate 286 code + * + * Revision 4.0.1.3 91/11/05 16:07:43 lwall + * patch11: random cleanup + * patch11: "foo\0" eq "foo" was sometimes optimized to true + * patch11: foreach on null list could spring memory leak + * + * Revision 4.0.1.2 91/06/07 10:26:45 lwall + * patch4: new copyright notice + * patch4: made some allowances for "semi-standard" C + * + * Revision 4.0.1.1 91/04/11 17:36:16 lwall + * patch1: you may now use "die" and "caller" in a signal handler + * + * Revision 4.0 91/03/20 01:04:18 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#ifdef I_VARARGS +# include +#endif + +static STR strchop; + +void grow_dlevel(); + +/* do longjmps() clobber register variables? */ + +#if defined(cray) || defined(STANDARD_C) +#define JMPCLOBBER +#endif + +/* This is the main command loop. We try to spend as much time in this loop + * as possible, so lots of optimizations do their activities in here. This + * means things get a little sloppy. + */ + +int +cmd_exec(cmdparm,gimme,sp) +CMD *VOLATILE cmdparm; +VOLATILE int gimme; +VOLATILE int sp; +{ + register CMD *cmd = cmdparm; + SPAT *VOLATILE oldspat; + VOLATILE int firstsave = savestack->ary_fill; + VOLATILE int oldsave; + VOLATILE int aryoptsave; +#ifdef DEBUGGING + VOLATILE int olddlevel; + VOLATILE int entdlevel; +#endif + register STR *retstr = &str_undef; + register char *tmps; + register int cmdflags; + register int match; + register char *go_to = goto_targ; + register int newsp = -2; + register STR **st = stack->ary_array; + FILE *VOLATILE fp; + ARRAY *VOLATILE ar; + + lastsize = 0; +#ifdef DEBUGGING + entdlevel = dlevel; +#endif +tail_recursion_entry: +#ifdef DEBUGGING + dlevel = entdlevel; + if (debug & 4) + deb("mortals = (%d/%d) stack, = (%d/%d)\n", + tmps_max, tmps_base, + savestack->ary_fill, firstsave); +#endif +#ifdef TAINT + tainted = 0; /* Each statement is presumed innocent */ +#endif + if (cmd == Nullcmd) { + if (gimme == G_ARRAY && newsp > -2) + return newsp; + else { + st[++sp] = retstr; + return sp; + } + } + cmdflags = cmd->c_flags; /* hopefully load register */ + if (go_to) { + if (cmd->c_label && strEQ(go_to,cmd->c_label)) + goto_targ = go_to = Nullch; /* here at last */ + else { + switch (cmd->c_type) { + case C_IF: + oldspat = curspat; + oldsave = savestack->ary_fill; +#ifdef DEBUGGING + olddlevel = dlevel; +#endif + retstr = &str_yes; + newsp = -2; + if (cmd->ucmd.ccmd.cc_true) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 't'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + } + if (!goto_targ) + go_to = Nullch; + curspat = oldspat; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); +#ifdef DEBUGGING + dlevel = olddlevel; +#endif + cmd = cmd->ucmd.ccmd.cc_alt; + goto tail_recursion_entry; + case C_ELSE: + oldspat = curspat; + oldsave = savestack->ary_fill; +#ifdef DEBUGGING + olddlevel = dlevel; +#endif + retstr = &str_undef; + newsp = -2; + if (cmd->ucmd.ccmd.cc_true) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 'e'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + } + if (!goto_targ) + go_to = Nullch; + curspat = oldspat; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); +#ifdef DEBUGGING + dlevel = olddlevel; +#endif + break; + case C_BLOCK: + case C_WHILE: + if (!(cmdflags & CF_ONCE)) { + cmdflags |= CF_ONCE; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } + loop_stack[loop_ptr].loop_label = cmd->c_label; + loop_stack[loop_ptr].loop_sp = sp; +#ifdef DEBUGGING + if (debug & 4) { + deb("(Pushing label #%d %s)\n", + loop_ptr, cmd->c_label ? cmd->c_label : ""); + } +#endif + } +#ifdef JMPCLOBBER + cmdparm = cmd; +#endif + match = setjmp(loop_stack[loop_ptr].loop_env); + if (match) { + st = stack->ary_array; /* possibly reallocated */ +#ifdef JMPCLOBBER + cmd = cmdparm; + cmdflags = cmd->c_flags|CF_ONCE; +#endif + if (savestack->ary_fill > oldsave) + restorelist(oldsave); + switch (match) { + default: + fatal("longjmp returned bad value (%d)",match); + case O_LAST: /* not done unless go_to found */ + go_to = Nullch; + if (lastretstr) { + retstr = lastretstr; + newsp = -2; + } + else { + newsp = sp + lastsize; + retstr = st[newsp]; + } +#ifdef DEBUGGING + olddlevel = dlevel; +#endif + curspat = oldspat; + goto next_cmd; + case O_NEXT: /* not done unless go_to found */ + go_to = Nullch; +#ifdef JMPCLOBBER + newsp = -2; + retstr = &str_undef; +#endif + goto next_iter; + case O_REDO: /* not done unless go_to found */ + go_to = Nullch; +#ifdef JMPCLOBBER + newsp = -2; + retstr = &str_undef; +#endif + goto doit; + } + } + oldspat = curspat; + oldsave = savestack->ary_fill; +#ifdef DEBUGGING + olddlevel = dlevel; +#endif + if (cmd->ucmd.ccmd.cc_true) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 't'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + if (newsp >= 0) + retstr = st[newsp]; + } + if (!goto_targ) { + go_to = Nullch; + goto next_iter; + } +#ifdef DEBUGGING + dlevel = olddlevel; +#endif + if (cmd->ucmd.ccmd.cc_alt) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 'a'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_alt,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + if (newsp >= 0) + retstr = st[newsp]; + } + if (goto_targ) + break; + go_to = Nullch; + goto finish_while; + } + cmd = cmd->c_next; + if (cmd && cmd->c_head == cmd) + /* reached end of while loop */ + return sp; /* targ isn't in this block */ + if (cmdflags & CF_ONCE) { +#ifdef DEBUGGING + if (debug & 4) { + tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, + tmps ? tmps : "" ); + } +#endif + loop_ptr--; + } + goto tail_recursion_entry; + } + } + +until_loop: + + /* Set line number so run-time errors can be located */ + + curcmd = cmd; + +#ifdef DEBUGGING + if (debug) { + if (debug & 2) { + deb("%s (%lx) r%lx t%lx a%lx n%lx cs%lx\n", + cmdname[cmd->c_type],cmd,cmd->c_expr, + cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt,cmd->c_next, + curspat); + } + debname[dlevel] = cmdname[cmd->c_type][0]; + debdelim[dlevel] = '!'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + + /* Here is some common optimization */ + + if (cmdflags & CF_COND) { + switch (cmdflags & CF_OPTIMIZE) { + + case CFT_FALSE: + retstr = cmd->c_short; + newsp = -2; + match = FALSE; + if (cmdflags & CF_NESURE) + goto maybe; + break; + case CFT_TRUE: + retstr = cmd->c_short; + newsp = -2; + match = TRUE; + if (cmdflags & CF_EQSURE) + goto flipmaybe; + break; + + case CFT_REG: + retstr = STAB_STR(cmd->c_stab); + newsp = -2; + match = str_true(retstr); /* => retstr = retstr, c2 should fix */ + if (cmdflags & (match ? CF_EQSURE : CF_NESURE)) + goto flipmaybe; + break; + + case CFT_ANCHOR: /* /^pat/ optimization */ + if (multiline) { + if (*cmd->c_short->str_ptr && !(cmdflags & CF_EQSURE)) + goto scanner; /* just unanchor it */ + else + break; /* must evaluate */ + } + match = 0; + goto strop; + + case CFT_STROP: /* string op optimization */ + match = 1; + strop: + retstr = STAB_STR(cmd->c_stab); + newsp = -2; +#ifndef I286 + if (*cmd->c_short->str_ptr == *str_get(retstr) && + (match ? retstr->str_cur == cmd->c_slen - 1 : + retstr->str_cur >= cmd->c_slen) && + bcmp(cmd->c_short->str_ptr, str_get(retstr), + cmd->c_slen) == 0 ) { + if (cmdflags & CF_EQSURE) { + if (sawampersand && (cmdflags & CF_OPTIMIZE) != CFT_STROP) { + curspat = Nullspat; + if (leftstab) + str_nset(stab_val(leftstab),"",0); + if (amperstab) + str_sset(stab_val(amperstab),cmd->c_short); + if (rightstab) + str_nset(stab_val(rightstab), + retstr->str_ptr + cmd->c_slen, + retstr->str_cur - cmd->c_slen); + } + if (cmd->c_spat) + lastspat = cmd->c_spat; + match = !(cmdflags & CF_FIRSTNEG); + retstr = match ? &str_yes : &str_no; + goto flipmaybe; + } + } + else if (cmdflags & CF_NESURE) { + match = cmdflags & CF_FIRSTNEG; + retstr = match ? &str_yes : &str_no; + goto flipmaybe; + } +#else + { + char *zap1, *zap2, zap1c, zap2c; + int zaplen; + int lenok; + + zap1 = cmd->c_short->str_ptr; + zap2 = str_get(retstr); + zap1c = *zap1; + zap2c = *zap2; + zaplen = cmd->c_slen; + if (match) + lenok = (retstr->str_cur == cmd->c_slen - 1); + else + lenok = (retstr->str_cur >= cmd->c_slen); + if ((zap1c == zap2c) && lenok && (bcmp(zap1, zap2, zaplen) == 0)) { + if (cmdflags & CF_EQSURE) { + if (sawampersand && + (cmdflags & CF_OPTIMIZE) != CFT_STROP) { + curspat = Nullspat; + if (leftstab) + str_nset(stab_val(leftstab),"",0); + if (amperstab) + str_sset(stab_val(amperstab),cmd->c_short); + if (rightstab) + str_nset(stab_val(rightstab), + retstr->str_ptr + cmd->c_slen, + retstr->str_cur - cmd->c_slen); + } + if (cmd->c_spat) + lastspat = cmd->c_spat; + match = !(cmdflags & CF_FIRSTNEG); + retstr = match ? &str_yes : &str_no; + goto flipmaybe; + } + } + else if (cmdflags & CF_NESURE) { + match = cmdflags & CF_FIRSTNEG; + retstr = match ? &str_yes : &str_no; + goto flipmaybe; + } + } +#endif + break; /* must evaluate */ + + case CFT_SCAN: /* non-anchored search */ + scanner: + retstr = STAB_STR(cmd->c_stab); + newsp = -2; + if (retstr->str_pok & SP_STUDIED) + if (screamfirst[cmd->c_short->str_rare] >= 0) + tmps = screaminstr(retstr, cmd->c_short); + else + tmps = Nullch; + else { + tmps = str_get(retstr); /* make sure it's pok */ +#ifndef lint + tmps = fbminstr((unsigned char*)tmps, + (unsigned char*)tmps + retstr->str_cur, cmd->c_short); +#endif + } + if (tmps) { + if (cmdflags & CF_EQSURE) { + ++cmd->c_short->str_u.str_useful; + if (sawampersand) { + curspat = Nullspat; + if (leftstab) + str_nset(stab_val(leftstab),retstr->str_ptr, + tmps - retstr->str_ptr); + if (amperstab) + str_nset(stab_val(amperstab), + tmps, cmd->c_short->str_cur); + if (rightstab) + str_nset(stab_val(rightstab), + tmps + cmd->c_short->str_cur, + retstr->str_cur - (tmps - retstr->str_ptr) - + cmd->c_short->str_cur); + } + lastspat = cmd->c_spat; + match = !(cmdflags & CF_FIRSTNEG); + retstr = match ? &str_yes : &str_no; + goto flipmaybe; + } + else + hint = tmps; + } + else { + if (cmdflags & CF_NESURE) { + ++cmd->c_short->str_u.str_useful; + match = cmdflags & CF_FIRSTNEG; + retstr = match ? &str_yes : &str_no; + goto flipmaybe; + } + } + if (--cmd->c_short->str_u.str_useful < 0) { + cmdflags &= ~CF_OPTIMIZE; + cmdflags |= CFT_EVAL; /* never try this optimization again */ + cmd->c_flags = (cmdflags & ~CF_ONCE); + } + break; /* must evaluate */ + + case CFT_NUMOP: /* numeric op optimization */ + retstr = STAB_STR(cmd->c_stab); + newsp = -2; + switch (cmd->c_slen) { + case O_EQ: + if (dowarn) { + if ((!retstr->str_nok && !looks_like_number(retstr))) + warn("Possible use of == on string value"); + } + match = (str_gnum(retstr) == cmd->c_short->str_u.str_nval); + break; + case O_NE: + match = (str_gnum(retstr) != cmd->c_short->str_u.str_nval); + break; + case O_LT: + match = (str_gnum(retstr) < cmd->c_short->str_u.str_nval); + break; + case O_LE: + match = (str_gnum(retstr) <= cmd->c_short->str_u.str_nval); + break; + case O_GT: + match = (str_gnum(retstr) > cmd->c_short->str_u.str_nval); + break; + case O_GE: + match = (str_gnum(retstr) >= cmd->c_short->str_u.str_nval); + break; + } + if (match) { + if (cmdflags & CF_EQSURE) { + retstr = &str_yes; + goto flipmaybe; + } + } + else if (cmdflags & CF_NESURE) { + retstr = &str_no; + goto flipmaybe; + } + break; /* must evaluate */ + + case CFT_INDGETS: /* while (<$foo>) */ + last_in_stab = stabent(str_get(STAB_STR(cmd->c_stab)),TRUE); + if (!stab_io(last_in_stab)) + stab_io(last_in_stab) = stio_new(); + goto dogets; + case CFT_GETS: /* really a while () */ + last_in_stab = cmd->c_stab; + dogets: + fp = stab_io(last_in_stab)->ifp; + retstr = stab_val(defstab); + newsp = -2; + keepgoing: + if (fp && str_gets(retstr, fp, 0)) { + if (*retstr->str_ptr == '0' && retstr->str_cur == 1) + match = FALSE; + else + match = TRUE; + stab_io(last_in_stab)->lines++; + } + else if (stab_io(last_in_stab)->flags & IOF_ARGV) { + if (!fp) + goto doeval; /* first time through */ + fp = nextargv(last_in_stab); + if (fp) + goto keepgoing; + (void)do_close(last_in_stab,FALSE); + stab_io(last_in_stab)->flags |= IOF_START; + retstr = &str_undef; + match = FALSE; + } + else { + retstr = &str_undef; + match = FALSE; + } + goto flipmaybe; + case CFT_EVAL: + break; + case CFT_UNFLIP: + while (tmps_max > tmps_base) { /* clean up after last eval */ + str_free(tmps_list[tmps_max]); + tmps_list[tmps_max--] = Nullstr; + } + newsp = eval(cmd->c_expr,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + match = str_true(retstr); + if (cmd->c_expr->arg_type == O_FLIP) /* undid itself? */ + cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd); + goto maybe; + case CFT_CHOP: + retstr = stab_val(cmd->c_stab); + newsp = -2; + match = (retstr->str_cur != 0); + tmps = str_get(retstr); + tmps += retstr->str_cur - match; + str_nset(&strchop,tmps,match); + *tmps = '\0'; + retstr->str_nok = 0; + retstr->str_cur = tmps - retstr->str_ptr; + STABSET(retstr); + retstr = &strchop; + goto flipmaybe; + case CFT_ARRAY: + match = cmd->c_short->str_u.str_useful; /* just to get register */ + + if (match < 0) { /* first time through here? */ + ar = stab_array(cmd->c_expr[1].arg_ptr.arg_stab); + aryoptsave = savestack->ary_fill; + savesptr(&stab_val(cmd->c_stab)); + savelong(&cmd->c_short->str_u.str_useful); + } + else { + ar = stab_xarray(cmd->c_expr[1].arg_ptr.arg_stab); + if (cmd->c_type != C_WHILE && savestack->ary_fill > firstsave) + restorelist(firstsave); + } + + if (match >= ar->ary_fill) { /* we're in LAST, probably */ + if (match < 0 && /* er, probably not... */ + savestack->ary_fill > aryoptsave) + restorelist(aryoptsave); + retstr = &str_undef; + cmd->c_short->str_u.str_useful = -1; /* actually redundant */ + match = FALSE; + } + else { + match++; + if (!(retstr = ar->ary_array[match])) + retstr = afetch(ar,match,TRUE); + stab_val(cmd->c_stab) = retstr; + cmd->c_short->str_u.str_useful = match; + match = TRUE; + } + newsp = -2; + goto maybe; + case CFT_D1: + break; + case CFT_D0: + if (DBsingle->str_u.str_nval != 0) + break; + if (DBsignal->str_u.str_nval != 0) + break; + if (DBtrace->str_u.str_nval != 0) + break; + goto next_cmd; + } + + /* we have tried to make this normal case as abnormal as possible */ + + doeval: + if (gimme == G_ARRAY) { + lastretstr = Nullstr; + lastspbase = sp; + lastsize = newsp - sp; + if (lastsize < 0) + lastsize = 0; + } + else + lastretstr = retstr; + while (tmps_max > tmps_base) { /* clean up after last eval */ + str_free(tmps_list[tmps_max]); + tmps_list[tmps_max--] = Nullstr; + } + newsp = eval(cmd->c_expr, + gimme && (cmdflags & CF_TERM) && cmd->c_type == C_EXPR && + !cmd->ucmd.acmd.ac_expr, + sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + if (newsp > sp && retstr) + match = str_true(retstr); + else + match = FALSE; + goto maybe; + + /* if flipflop was true, flop it */ + + flipmaybe: + if (match && cmdflags & CF_FLIP) { + while (tmps_max > tmps_base) { /* clean up after last eval */ + str_free(tmps_list[tmps_max]); + tmps_list[tmps_max--] = Nullstr; + } + if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */ + newsp = eval(cmd->c_expr,G_SCALAR,sp);/*let eval undo it*/ + cmdflags = copyopt(cmd,cmd->c_expr[3].arg_ptr.arg_cmd); + } + else { + newsp = eval(cmd->c_expr,G_SCALAR,sp);/* let eval do it */ + if (cmd->c_expr->arg_type == O_FLOP) /* still toggled? */ + cmdflags = copyopt(cmd,cmd->c_expr[4].arg_ptr.arg_cmd); + } + } + else if (cmdflags & CF_FLIP) { + if (cmd->c_expr->arg_type == O_FLOP) { /* currently toggled? */ + match = TRUE; /* force on */ + } + } + + /* at this point, match says whether our expression was true */ + + maybe: + if (cmdflags & CF_INVERT) + match = !match; + if (!match) + goto next_cmd; + } +#ifdef TAINT + tainted = 0; /* modifier doesn't affect regular expression */ +#endif + + /* now to do the actual command, if any */ + + switch (cmd->c_type) { + case C_NULL: + fatal("panic: cmd_exec"); + case C_EXPR: /* evaluated for side effects */ + if (cmd->ucmd.acmd.ac_expr) { /* more to do? */ + if (gimme == G_ARRAY) { + lastretstr = Nullstr; + lastspbase = sp; + lastsize = newsp - sp; + if (lastsize < 0) + lastsize = 0; + } + else + lastretstr = retstr; + while (tmps_max > tmps_base) { /* clean up after last eval */ + str_free(tmps_list[tmps_max]); + tmps_list[tmps_max--] = Nullstr; + } + newsp = eval(cmd->ucmd.acmd.ac_expr,gimme && (cmdflags&CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + } + break; + case C_NSWITCH: + { + double value = str_gnum(STAB_STR(cmd->c_stab)); + + match = (int)value; + if (value < 0.0) { + if (((double)match) > value) + --match; /* was fractional--truncate other way */ + } + } + goto doswitch; + case C_CSWITCH: + if (multiline) { + cmd = cmd->c_next; /* can't assume anything */ + goto tail_recursion_entry; + } + match = *(str_get(STAB_STR(cmd->c_stab))) & 255; + doswitch: + match -= cmd->ucmd.scmd.sc_offset; + if (match < 0) + match = 0; + else if (match > cmd->ucmd.scmd.sc_max) + match = cmd->ucmd.scmd.sc_max; + cmd = cmd->ucmd.scmd.sc_next[match]; + goto tail_recursion_entry; + case C_NEXT: + cmd = cmd->ucmd.ccmd.cc_alt; + goto tail_recursion_entry; + case C_ELSIF: + fatal("panic: ELSIF"); + case C_IF: + oldspat = curspat; + oldsave = savestack->ary_fill; +#ifdef DEBUGGING + olddlevel = dlevel; +#endif + retstr = &str_yes; + newsp = -2; + if (cmd->ucmd.ccmd.cc_true) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 't'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + } + curspat = oldspat; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); +#ifdef DEBUGGING + dlevel = olddlevel; +#endif + cmd = cmd->ucmd.ccmd.cc_alt; + goto tail_recursion_entry; + case C_ELSE: + oldspat = curspat; + oldsave = savestack->ary_fill; +#ifdef DEBUGGING + olddlevel = dlevel; +#endif + retstr = &str_undef; + newsp = -2; + if (cmd->ucmd.ccmd.cc_true) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 'e'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + } + curspat = oldspat; + if (savestack->ary_fill > oldsave) + restorelist(oldsave); +#ifdef DEBUGGING + dlevel = olddlevel; +#endif + break; + case C_BLOCK: + case C_WHILE: + if (!(cmdflags & CF_ONCE)) { /* first time through here? */ + cmdflags |= CF_ONCE; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } + loop_stack[loop_ptr].loop_label = cmd->c_label; + loop_stack[loop_ptr].loop_sp = sp; +#ifdef DEBUGGING + if (debug & 4) { + deb("(Pushing label #%d %s)\n", + loop_ptr, cmd->c_label ? cmd->c_label : ""); + } +#endif + } +#ifdef JMPCLOBBER + cmdparm = cmd; +#endif + match = setjmp(loop_stack[loop_ptr].loop_env); + if (match) { + st = stack->ary_array; /* possibly reallocated */ +#ifdef JMPCLOBBER + cmd = cmdparm; + cmdflags = cmd->c_flags|CF_ONCE; + go_to = goto_targ; +#endif + if (savestack->ary_fill > oldsave) + restorelist(oldsave); + switch (match) { + default: + fatal("longjmp returned bad value (%d)",match); + case O_LAST: + if (lastretstr) { + retstr = lastretstr; + newsp = -2; + } + else { + newsp = sp + lastsize; + retstr = st[newsp]; + } + curspat = oldspat; + goto next_cmd; + case O_NEXT: +#ifdef JMPCLOBBER + newsp = -2; + retstr = &str_undef; +#endif + goto next_iter; + case O_REDO: +#ifdef DEBUGGING + dlevel = olddlevel; +#endif +#ifdef JMPCLOBBER + newsp = -2; + retstr = &str_undef; +#endif + goto doit; + } + } + oldspat = curspat; + oldsave = savestack->ary_fill; +#ifdef DEBUGGING + olddlevel = dlevel; +#endif + doit: + if (cmd->ucmd.ccmd.cc_true) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 't'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_true,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + } + /* actually, this spot is rarely reached anymore since the above + * cmd_exec() returns through longjmp(). Hooray for structure. + */ + next_iter: +#ifdef DEBUGGING + dlevel = olddlevel; +#endif + if (cmd->ucmd.ccmd.cc_alt) { +#ifdef DEBUGGING + if (debug) { + debname[dlevel] = 'a'; + debdelim[dlevel] = '_'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + newsp = cmd_exec(cmd->ucmd.ccmd.cc_alt,gimme && (cmdflags & CF_TERM),sp); + st = stack->ary_array; /* possibly reallocated */ + retstr = st[newsp]; + } + finish_while: + curspat = oldspat; + if (savestack->ary_fill > oldsave) { + if (cmdflags & CF_TERM) { + for (match = sp + 1; match <= newsp; match++) + st[match] = str_mortal(st[match]); + retstr = st[newsp]; + } + restorelist(oldsave); + } +#ifdef DEBUGGING + dlevel = olddlevel - 1; +#endif + if (cmd->c_type != C_BLOCK) + goto until_loop; /* go back and evaluate conditional again */ + } + if (cmdflags & CF_LOOP) { + cmdflags |= CF_COND; /* now test the condition */ +#ifdef DEBUGGING + dlevel = entdlevel; +#endif + goto until_loop; + } + next_cmd: + if (cmdflags & CF_ONCE) { +#ifdef DEBUGGING + if (debug & 4) { + tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, tmps ? tmps : ""); + } +#endif + loop_ptr--; + if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY && + savestack->ary_fill > aryoptsave) + restorelist(aryoptsave); + } + cmd = cmd->c_next; + goto tail_recursion_entry; +} + +#ifdef DEBUGGING +# ifndef I_VARARGS +/*VARARGS1*/ +void deb(pat,a1,a2,a3,a4,a5,a6,a7,a8) +char *pat; +{ + register int i; + + fprintf(stderr,"%-4ld",(long)curcmd->c_line); + for (i=0; ic_line); + for (i=0; ic_flags &= CF_ONCE|CF_COND|CF_LOOP; + cmd->c_flags |= which->c_flags; + cmd->c_short = which->c_short; + cmd->c_slen = which->c_slen; + cmd->c_stab = which->c_stab; + return cmd->c_flags; +} + +ARRAY * +saveary(stab) +STAB *stab; +{ + register STR *str; + + str = Str_new(10,0); + str->str_state = SS_SARY; + str->str_u.str_stab = stab; + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_ptr = Nullch; + str->str_len = 0; + } + str->str_ptr = (char*)stab_array(stab); + (void)apush(savestack,str); /* save array ptr */ + stab_xarray(stab) = Null(ARRAY*); + return stab_xarray(aadd(stab)); +} + +HASH * +savehash(stab) +STAB *stab; +{ + register STR *str; + + str = Str_new(11,0); + str->str_state = SS_SHASH; + str->str_u.str_stab = stab; + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_ptr = Nullch; + str->str_len = 0; + } + str->str_ptr = (char*)stab_hash(stab); + (void)apush(savestack,str); /* save hash ptr */ + stab_xhash(stab) = Null(HASH*); + return stab_xhash(hadd(stab)); +} + +void +saveitem(item) +register STR *item; +{ + register STR *str; + + (void)apush(savestack,item); /* remember the pointer */ + str = Str_new(12,0); + str_sset(str,item); + (void)apush(savestack,str); /* remember the value */ +} + +void +saveint(intp) +int *intp; +{ + register STR *str; + + str = Str_new(13,0); + str->str_state = SS_SINT; + str->str_u.str_useful = (long)*intp; /* remember value */ + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)intp; /* remember pointer */ + (void)apush(savestack,str); +} + +void +savelong(longp) +long *longp; +{ + register STR *str; + + str = Str_new(14,0); + str->str_state = SS_SLONG; + str->str_u.str_useful = *longp; /* remember value */ + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)longp; /* remember pointer */ + (void)apush(savestack,str); +} + +void +savesptr(sptr) +STR **sptr; +{ + register STR *str; + + str = Str_new(15,0); + str->str_state = SS_SSTRP; + str->str_magic = *sptr; /* remember value */ + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)sptr; /* remember pointer */ + (void)apush(savestack,str); +} + +void +savenostab(stab) +STAB *stab; +{ + register STR *str; + + str = Str_new(16,0); + str->str_state = SS_SNSTAB; + str->str_magic = (STR*)stab; /* remember which stab to free */ + (void)apush(savestack,str); +} + +void +savehptr(hptr) +HASH **hptr; +{ + register STR *str; + + str = Str_new(17,0); + str->str_state = SS_SHPTR; + str->str_u.str_hash = *hptr; /* remember value */ + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)hptr; /* remember pointer */ + (void)apush(savestack,str); +} + +void +saveaptr(aptr) +ARRAY **aptr; +{ + register STR *str; + + str = Str_new(17,0); + str->str_state = SS_SAPTR; + str->str_u.str_array = *aptr; /* remember value */ + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_len = 0; + } + str->str_ptr = (char*)aptr; /* remember pointer */ + (void)apush(savestack,str); +} + +void +savelist(sarg,maxsarg) +register STR **sarg; +int maxsarg; +{ + register STR *str; + register int i; + + for (i = 1; i <= maxsarg; i++) { + (void)apush(savestack,sarg[i]); /* remember the pointer */ + str = Str_new(18,0); + str_sset(str,sarg[i]); + (void)apush(savestack,str); /* remember the value */ + sarg[i]->str_u.str_useful = -1; + } +} + +void +restorelist(base) +int base; +{ + register STR *str; + register STR *value; + register STAB *stab; + + if (base < -1) + fatal("panic: corrupt saved stack index"); + while (savestack->ary_fill > base) { + value = apop(savestack); + switch (value->str_state) { + case SS_NORM: /* normal string */ + case SS_INCR: + str = apop(savestack); + str_replace(str,value); + STABSET(str); + break; + case SS_SARY: /* array reference */ + stab = value->str_u.str_stab; + afree(stab_xarray(stab)); + stab_xarray(stab) = (ARRAY*)value->str_ptr; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SHASH: /* hash reference */ + stab = value->str_u.str_stab; + (void)hfree(stab_xhash(stab), FALSE); + stab_xhash(stab) = (HASH*)value->str_ptr; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SINT: /* int reference */ + *((int*)value->str_ptr) = (int)value->str_u.str_useful; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SLONG: /* long reference */ + *((long*)value->str_ptr) = value->str_u.str_useful; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SSTRP: /* STR* reference */ + *((STR**)value->str_ptr) = value->str_magic; + value->str_magic = Nullstr; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SHPTR: /* HASH* reference */ + *((HASH**)value->str_ptr) = value->str_u.str_hash; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SAPTR: /* ARRAY* reference */ + *((ARRAY**)value->str_ptr) = value->str_u.str_array; + value->str_ptr = Nullch; + str_free(value); + break; + case SS_SNSTAB: + stab = (STAB*)value->str_magic; + value->str_magic = Nullstr; + (void)stab_clear(stab); + str_free(value); + break; + case SS_SCSV: /* callsave structure */ + { + CSV *csv = (CSV*) value->str_ptr; + + curcmd = csv->curcmd; + curcsv = csv->curcsv; + csv->sub->depth = csv->depth; + if (csv->hasargs) { /* put back old @_ */ + afree(csv->argarray); + stab_xarray(defstab) = csv->savearray; + } + str_free(value); + } + break; + default: + fatal("panic: restorelist inconsistency"); + } + } +} + +#ifdef DEBUGGING +void +grow_dlevel() +{ + dlmax += 128; + Renew(debname, dlmax, char); + Renew(debdelim, dlmax, char); +} +#endif diff --git a/gnu/usr.bin/perl/perl/cmd.h b/gnu/usr.bin/perl/perl/cmd.h new file mode 100644 index 0000000..76ef5c8 --- /dev/null +++ b/gnu/usr.bin/perl/perl/cmd.h @@ -0,0 +1,179 @@ +/* $RCSfile: cmd.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:35 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: cmd.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:35 nate + * PERL! + * + * Revision 4.0.1.2 92/06/08 12:01:02 lwall + * patch20: removed implicit int declarations on funcions + * + * Revision 4.0.1.1 91/06/07 10:28:50 lwall + * patch4: new copyright notice + * patch4: length($`), length($&), length($') now optimized to avoid string copy + * + * Revision 4.0 91/03/20 01:04:34 lwall + * 4.0 baseline. + * + */ + +#define C_NULL 0 +#define C_IF 1 +#define C_ELSE 2 +#define C_WHILE 3 +#define C_BLOCK 4 +#define C_EXPR 5 +#define C_NEXT 6 +#define C_ELSIF 7 /* temporary--turns into an IF + ELSE */ +#define C_CSWITCH 8 /* created by switch optimization in block_head() */ +#define C_NSWITCH 9 /* likewise */ + +#ifdef DEBUGGING +#ifndef DOINIT +extern char *cmdname[]; +#else +char *cmdname[] = { + "NULL", + "IF", + "ELSE", + "WHILE", + "BLOCK", + "EXPR", + "NEXT", + "ELSIF", + "CSWITCH", + "NSWITCH", + "10" +}; +#endif +#endif /* DEBUGGING */ + +#define CF_OPTIMIZE 077 /* type of optimization */ +#define CF_FIRSTNEG 0100/* conditional is ($register NE 'string') */ +#define CF_NESURE 0200 /* if short doesn't match we're sure */ +#define CF_EQSURE 0400 /* if short does match we're sure */ +#define CF_COND 01000 /* test c_expr as conditional first, if not null. */ + /* Set for everything except do {} while currently */ +#define CF_LOOP 02000 /* loop on the c_expr conditional (loop modifiers) */ +#define CF_INVERT 04000 /* it's an "unless" or an "until" */ +#define CF_ONCE 010000 /* we've already pushed the label on the stack */ +#define CF_FLIP 020000 /* on a match do flipflop */ +#define CF_TERM 040000 /* value of this cmd might be returned */ +#define CF_DBSUB 0100000 /* this is an inserted cmd for debugging */ + +#define CFT_FALSE 0 /* c_expr is always false */ +#define CFT_TRUE 1 /* c_expr is always true */ +#define CFT_REG 2 /* c_expr is a simple register */ +#define CFT_ANCHOR 3 /* c_expr is an anchored search /^.../ */ +#define CFT_STROP 4 /* c_expr is a string comparison */ +#define CFT_SCAN 5 /* c_expr is an unanchored search /.../ */ +#define CFT_GETS 6 /* c_expr is */ +#define CFT_EVAL 7 /* c_expr is not optimized, so call eval() */ +#define CFT_UNFLIP 8 /* 2nd half of range not optimized */ +#define CFT_CHOP 9 /* c_expr is a chop on a register */ +#define CFT_ARRAY 10 /* this is a foreach loop */ +#define CFT_INDGETS 11 /* c_expr is <$variable> */ +#define CFT_NUMOP 12 /* c_expr is a numeric comparison */ +#define CFT_CCLASS 13 /* c_expr must start with one of these characters */ +#define CFT_D0 14 /* no special breakpoint at this line */ +#define CFT_D1 15 /* possible special breakpoint at this line */ + +#ifdef DEBUGGING +#ifndef DOINIT +extern char *cmdopt[]; +#else +char *cmdopt[] = { + "FALSE", + "TRUE", + "REG", + "ANCHOR", + "STROP", + "SCAN", + "GETS", + "EVAL", + "UNFLIP", + "CHOP", + "ARRAY", + "INDGETS", + "NUMOP", + "CCLASS", + "14" +}; +#endif +#endif /* DEBUGGING */ + +struct acmd { + STAB *ac_stab; /* a symbol table entry */ + ARG *ac_expr; /* any associated expression */ +}; + +struct ccmd { + CMD *cc_true; /* normal code to do on if and while */ + CMD *cc_alt; /* else cmd ptr or continue code */ +}; + +struct scmd { + CMD **sc_next; /* array of pointers to commands */ + short sc_offset; /* first value - 1 */ + short sc_max; /* last value + 1 */ +}; + +struct cmd { + CMD *c_next; /* the next command at this level */ + ARG *c_expr; /* conditional expression */ + CMD *c_head; /* head of this command list */ + STR *c_short; /* string to match as shortcut */ + STAB *c_stab; /* a symbol table entry, mostly for fp */ + SPAT *c_spat; /* pattern used by optimization */ + char *c_label; /* label for this construct */ + union ucmd { + struct acmd acmd; /* normal command */ + struct ccmd ccmd; /* compound command */ + struct scmd scmd; /* switch command */ + } ucmd; + short c_slen; /* len of c_short, if not null */ + VOLATILE short c_flags; /* optimization flags--see above */ + HASH *c_stash; /* package line was compiled in */ + STAB *c_filestab; /* file the following line # is from */ + line_t c_line; /* line # of this command */ + char c_type; /* what this command does */ +}; + +#define Nullcmd Null(CMD*) +#define Nullcsv Null(CSV*) + +EXT CMD * VOLATILE main_root INIT(Nullcmd); +EXT CMD * VOLATILE eval_root INIT(Nullcmd); + +EXT CMD compiling; +EXT CMD * VOLATILE curcmd INIT(&compiling); +EXT CSV * VOLATILE curcsv INIT(Nullcsv); + +struct callsave { + SUBR *sub; + STAB *stab; + CSV *curcsv; + CMD *curcmd; + ARRAY *savearray; + ARRAY *argarray; + long depth; + int wantarray; + char hasargs; +}; + +struct compcmd { + CMD *comp_true; + CMD *comp_alt; +}; + +void opt_arg(); +ARG* evalstatic(); +int cmd_exec(); +#ifdef DEBUGGING +void deb(); +#endif +int copyopt(); diff --git a/gnu/usr.bin/perl/perl/config.H b/gnu/usr.bin/perl/perl/config.H new file mode 100644 index 0000000..21f635f --- /dev/null +++ b/gnu/usr.bin/perl/perl/config.H @@ -0,0 +1,892 @@ +#ifndef config_h +#define config_h +/* config.h + * This file was produced by running the config.h.SH script, which + * gets its values from config.sh, which is generally produced by + * running Configure. + * + * Feel free to modify any of this as the need arises. Note, however, + * that running config.h.SH again will wipe out any changes you've made. + * For a more permanent change edit config.sh and rerun config.h.SH. + */ + /*SUPPRESS 460*/ + + +/* EUNICE + * This symbol, if defined, indicates that the program is being compiled + * under the EUNICE package under VMS. The program will need to handle + * things like files that don't go away the first time you unlink them, + * due to version numbering. It will also need to compensate for lack + * of a respectable link() command. + */ +/* VMS + * This symbol, if defined, indicates that the program is running under + * VMS. It is currently only set in conjunction with the EUNICE symbol. + */ +/*#undef EUNICE /**/ +/*#undef VMS /**/ + +/* LOC_SED + * This symbol holds the complete pathname to the sed program. + */ +#define LOC_SED "/bin/sed" /**/ + +/* ALIGN_BYTES + * This symbol contains the number of bytes required to align a double. + * Usual values are 2, 4, and 8. + */ +#define ALIGN_BYTES 8 /**/ + +/* BIN + * This symbol holds the name of the directory in which the user wants + * to keep publicly executable images for the package in question. It + * is most often a local directory such as /usr/local/bin. + */ +#define BIN "/usr/local/bin" /**/ + +/* BYTEORDER + * This symbol contains an encoding of the order of bytes in a long. + * Usual values (in hex) are 0x1234, 0x4321, 0x2143, 0x3412... + */ +#define BYTEORDER 0x4321 /**/ + +/* CPPSTDIN + * This symbol contains the first part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. Typical value of "cc -E" or "/lib/cpp". + */ +/* CPPMINUS + * This symbol contains the second part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. This symbol will have the value "-" if CPPSTDIN needs a minus + * to specify standard input, otherwise the value is "". + */ +#define CPPSTDIN "/usr/lib/cpp" +#define CPPMINUS "" + +/* HAS_BCMP + * This symbol, if defined, indicates that the bcmp routine is available + * to compare blocks of memory. If undefined, use memcmp. If that's + * not available, roll your own. + */ +#define HAS_BCMP /**/ + +/* HAS_BCOPY + * This symbol, if defined, indicates that the bcopy routine is available + * to copy blocks of memory. Otherwise you should probably use memcpy(). + * If neither is defined, roll your own. + */ +/* SAFE_BCOPY + * This symbol, if defined, indicates that the bcopy routine is available + * to copy potentially overlapping copy blocks of bcopy. Otherwise you + * should probably use memmove() or memcpy(). If neither is defined, + * roll your own. + */ +#define HAS_BCOPY /**/ +#define SAFE_BCOPY /**/ + +/* HAS_BZERO + * This symbol, if defined, indicates that the bzero routine is available + * to zero blocks of memory. Otherwise you should probably use memset() + * or roll your own. + */ +#define HAS_BZERO /**/ + +/* CASTNEGFLOAT + * This symbol, if defined, indicates that this C compiler knows how to + * cast negative or large floating point numbers to unsigned longs, ints + * and shorts. + */ +/* CASTFLAGS + * This symbol contains flags that say what difficulties the compiler + * has casting odd floating values to unsigned long: + * 1 = couldn't cast < 0 + * 2 = couldn't cast >= 0x80000000 + */ +#define CASTNEGFLOAT /**/ +#define CASTFLAGS 0 /**/ + +/* CHARSPRINTF + * This symbol is defined if this system declares "char *sprintf()" in + * stdio.h. The trend seems to be to declare it as "int sprintf()". It + * is up to the package author to declare sprintf correctly based on the + * symbol. + */ +#define CHARSPRINTF /**/ + +/* HAS_CHSIZE + * This symbol, if defined, indicates that the chsize routine is available + * to truncate files. You might need a -lx to get this routine. + */ +/*#undef HAS_CHSIZE /**/ + +/* HAS_CRYPT + * This symbol, if defined, indicates that the crypt routine is available + * to encrypt passwords and the like. + */ +#define HAS_CRYPT /**/ + +/* CSH + * This symbol, if defined, indicates that the C-shell exists. + * If defined, contains the full pathname of csh. + */ +#define CSH "/bin/csh" /**/ + +/* DOSUID + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +/*#undef DOSUID /**/ + +/* HAS_DUP2 + * This symbol, if defined, indicates that the dup2 routine is available + * to dup file descriptors. Otherwise you should use dup(). + */ +#define HAS_DUP2 /**/ + +/* HAS_FCHMOD + * This symbol, if defined, indicates that the fchmod routine is available + * to change mode of opened files. If unavailable, use chmod(). + */ +#define HAS_FCHMOD /**/ + +/* HAS_FCHOWN + * This symbol, if defined, indicates that the fchown routine is available + * to change ownership of opened files. If unavailable, use chown(). + */ +#define HAS_FCHOWN /**/ + +/* HAS_FCNTL + * This symbol, if defined, indicates to the C program that + * the fcntl() function exists. + */ +#define HAS_FCNTL /**/ + +/* FLEXFILENAMES + * This symbol, if defined, indicates that the system supports filenames + * longer than 14 characters. + */ +#define FLEXFILENAMES /**/ + +/* HAS_FLOCK + * This symbol, if defined, indicates that the flock() routine is + * available to do file locking. + */ +#define HAS_FLOCK /**/ + +/* HAS_GETGROUPS + * This symbol, if defined, indicates that the getgroups() routine is + * available to get the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +#define HAS_GETGROUPS /**/ + +/* HAS_GETHOSTENT + * This symbol, if defined, indicates that the gethostent() routine is + * available to lookup host names in some data base or other. + */ +#define HAS_GETHOSTENT /**/ + +/* HAS_GETPGRP + * This symbol, if defined, indicates that the getpgrp() routine is + * available to get the current process group. + */ +#define HAS_GETPGRP /**/ + +/* HAS_GETPGRP2 + * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) + * routine is available to get the current process group. + */ +/*#undef HAS_GETPGRP2 /**/ + +/* HAS_GETPRIORITY + * This symbol, if defined, indicates that the getpriority() routine is + * available to get a process's priority. + */ +#define HAS_GETPRIORITY /**/ + +/* HAS_HTONS + * This symbol, if defined, indicates that the htons routine (and friends) + * are available to do network order byte swapping. + */ +/* HAS_HTONL + * This symbol, if defined, indicates that the htonl routine (and friends) + * are available to do network order byte swapping. + */ +/* HAS_NTOHS + * This symbol, if defined, indicates that the ntohs routine (and friends) + * are available to do network order byte swapping. + */ +/* HAS_NTOHL + * This symbol, if defined, indicates that the ntohl routine (and friends) + * are available to do network order byte swapping. + */ +#define HAS_HTONS /**/ +#define HAS_HTONL /**/ +#define HAS_NTOHS /**/ +#define HAS_NTOHL /**/ + +/* index + * This preprocessor symbol is defined, along with rindex, if the system + * uses the strchr and strrchr routines instead. + */ +/* rindex + * This preprocessor symbol is defined, along with index, if the system + * uses the strchr and strrchr routines instead. + */ +/*#undef index strchr /* cultural */ +/*#undef rindex strrchr /* differences? */ + +/* HAS_ISASCII + * This symbol, if defined, indicates that the isascii routine is available + * to test characters for asciiness. + */ +#define HAS_ISASCII /**/ + +/* HAS_KILLPG + * This symbol, if defined, indicates that the killpg routine is available + * to kill process groups. If unavailable, you probably should use kill + * with a negative process number. + */ +#define HAS_KILLPG /**/ + +/* HAS_LSTAT + * This symbol, if defined, indicates that the lstat() routine is + * available to stat symbolic links. + */ +#define HAS_LSTAT /**/ + +/* HAS_MEMCMP + * This symbol, if defined, indicates that the memcmp routine is available + * to compare blocks of memory. If undefined, roll your own. + */ +#define HAS_MEMCMP /**/ + +/* HAS_MEMCPY + * This symbol, if defined, indicates that the memcpy routine is available + * to copy blocks of memory. Otherwise you should probably use bcopy(). + * If neither is defined, roll your own. + */ +/* SAFE_MEMCPY + * This symbol, if defined, indicates that the memcpy routine is available + * to copy potentially overlapping copy blocks of memory. Otherwise you + * should probably use memmove() or bcopy(). If neither is defined, + * roll your own. + */ +#define HAS_MEMCPY /**/ +/*#undef SAFE_MEMCPY /**/ + +/* HAS_MEMMOVE + * This symbol, if defined, indicates that the memmove routine is available + * to move potentially overlapping blocks of memory. Otherwise you + * should use bcopy() or roll your own. + */ +/*#undef HAS_MEMMOVE /**/ + +/* HAS_MEMSET + * This symbol, if defined, indicates that the memset routine is available + * to set a block of memory to a character. If undefined, roll your own. + */ +#define HAS_MEMSET /**/ + +/* HAS_MKDIR + * This symbol, if defined, indicates that the mkdir routine is available + * to create directories. Otherwise you should fork off a new process to + * exec /bin/mkdir. + */ +#define HAS_MKDIR /**/ + +/* HAS_MSG + * This symbol, if defined, indicates that the entire msg*(2) library is + * supported. + */ +#define HAS_MSG /**/ + +/* HAS_MSGCTL + * This symbol, if defined, indicates that the msgctl() routine is + * available to control message passing. + */ +#define HAS_MSGCTL /**/ + +/* HAS_MSGGET + * This symbol, if defined, indicates that the msgget() routine is + * available to get messages. + */ +#define HAS_MSGGET /**/ + +/* HAS_MSGRCV + * This symbol, if defined, indicates that the msgrcv() routine is + * available to receive messages. + */ +#define HAS_MSGRCV /**/ + +/* HAS_MSGSND + * This symbol, if defined, indicates that the msgsnd() routine is + * available to send messages. + */ +#define HAS_MSGSND /**/ + +/* HAS_NDBM + * This symbol, if defined, indicates that ndbm.h exists and should + * be included. + */ +#define HAS_NDBM /**/ + +/* HAS_ODBM + * This symbol, if defined, indicates that dbm.h exists and should + * be included. + */ +#define HAS_ODBM /**/ + +/* HAS_OPEN3 + * This manifest constant lets the C program know that the three + * argument form of open(2) is available. + */ +#define HAS_OPEN3 /**/ + +/* HAS_READDIR + * This symbol, if defined, indicates that the readdir routine is available + * from the C library to read directories. + */ +#define HAS_READDIR /**/ + +/* HAS_RENAME + * This symbol, if defined, indicates that the rename routine is available + * to rename files. Otherwise you should do the unlink(), link(), unlink() + * trick. + */ +#define HAS_RENAME /**/ + +/* HAS_REWINDDIR + * This symbol, if defined, indicates that the rewindir routine is + * available to rewind directories. + */ +#define HAS_REWINDDIR /**/ + +/* HAS_RMDIR + * This symbol, if defined, indicates that the rmdir routine is available + * to remove directories. Otherwise you should fork off a new process to + * exec /bin/rmdir. + */ +#define HAS_RMDIR /**/ + +/* HAS_SEEKDIR + * This symbol, if defined, indicates that the seekdir routine is + * available to seek into directories. + */ +#define HAS_SEEKDIR /**/ + +/* HAS_SELECT + * This symbol, if defined, indicates that the select() subroutine + * exists. + */ +#define HAS_SELECT /**/ + +/* HAS_SEM + * This symbol, if defined, indicates that the entire sem*(2) library is + * supported. + */ +#define HAS_SEM /**/ + +/* HAS_SEMCTL + * This symbol, if defined, indicates that the semctl() routine is + * available to control semaphores. + */ +#define HAS_SEMCTL /**/ + +/* HAS_SEMGET + * This symbol, if defined, indicates that the semget() routine is + * available to get semaphores ids. + */ +#define HAS_SEMGET /**/ + +/* HAS_SEMOP + * This symbol, if defined, indicates that the semop() routine is + * available to perform semaphore operations. + */ +#define HAS_SEMOP /**/ + +/* HAS_SETEGID + * This symbol, if defined, indicates that the setegid routine is available + * to change the effective gid of the current program. + */ +#define HAS_SETEGID /**/ + +/* HAS_SETEUID + * This symbol, if defined, indicates that the seteuid routine is available + * to change the effective uid of the current program. + */ +#define HAS_SETEUID /**/ + +/* HAS_SETPGRP + * This symbol, if defined, indicates that the setpgrp() routine is + * available to set the current process group. + */ +#define HAS_SETPGRP /**/ + +/* HAS_SETPGRP2 + * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) + * routine is available to set the current process group. + */ +/*#undef HAS_SETPGRP2 /**/ + +/* HAS_SETPRIORITY + * This symbol, if defined, indicates that the setpriority() routine is + * available to set a process's priority. + */ +#define HAS_SETPRIORITY /**/ + +/* HAS_SETREGID + * This symbol, if defined, indicates that the setregid routine is + * available to change the real and effective gid of the current program. + */ +/* HAS_SETRESGID + * This symbol, if defined, indicates that the setresgid routine is + * available to change the real, effective and saved gid of the current + * program. + */ +#define HAS_SETREGID /**/ +/*#undef HAS_SETRESGID /**/ + +/* HAS_SETREUID + * This symbol, if defined, indicates that the setreuid routine is + * available to change the real and effective uid of the current program. + */ +/* HAS_SETRESUID + * This symbol, if defined, indicates that the setresuid routine is + * available to change the real, effective and saved uid of the current + * program. + */ +#define HAS_SETREUID /**/ +/*#undef HAS_SETRESUID /**/ + +/* HAS_SETRGID + * This symbol, if defined, indicates that the setrgid routine is available + * to change the real gid of the current program. + */ +#define HAS_SETRGID /**/ + +/* HAS_SETRUID + * This symbol, if defined, indicates that the setruid routine is available + * to change the real uid of the current program. + */ +#define HAS_SETRUID /**/ + +/* HAS_SHM + * This symbol, if defined, indicates that the entire shm*(2) library is + * supported. + */ +#define HAS_SHM /**/ + +/* HAS_SHMAT + * This symbol, if defined, indicates that the shmat() routine is + * available to attach a shared memory segment. + */ +/* VOID_SHMAT + * This symbol, if defined, indicates that the shmat() routine + * returns a pointer of type void*. + */ +#define HAS_SHMAT /**/ + +/*#undef VOIDSHMAT /**/ + +/* HAS_SHMCTL + * This symbol, if defined, indicates that the shmctl() routine is + * available to control a shared memory segment. + */ +#define HAS_SHMCTL /**/ + +/* HAS_SHMDT + * This symbol, if defined, indicates that the shmdt() routine is + * available to detach a shared memory segment. + */ +#define HAS_SHMDT /**/ + +/* HAS_SHMGET + * This symbol, if defined, indicates that the shmget() routine is + * available to get a shared memory segment id. + */ +#define HAS_SHMGET /**/ + +/* HAS_SOCKET + * This symbol, if defined, indicates that the BSD socket interface is + * supported. + */ +/* HAS_SOCKETPAIR + * This symbol, if defined, indicates that the BSD socketpair call is + * supported. + */ +/* OLDSOCKET + * This symbol, if defined, indicates that the 4.1c BSD socket interface + * is supported instead of the 4.2/4.3 BSD socket interface. + */ +#define HAS_SOCKET /**/ + +#define HAS_SOCKETPAIR /**/ + +/*#undef OLDSOCKET /**/ + +/* STATBLOCKS + * This symbol is defined if this system has a stat structure declaring + * st_blksize and st_blocks. + */ +#define STATBLOCKS /**/ + +/* STDSTDIO + * This symbol is defined if this system has a FILE structure declaring + * _ptr and _cnt in stdio.h. + */ +#define STDSTDIO /**/ + +/* STRUCTCOPY + * This symbol, if defined, indicates that this C compiler knows how + * to copy structures. If undefined, you'll need to use a block copy + * routine of some sort instead. + */ +#define STRUCTCOPY /**/ + +/* HAS_STRERROR + * This symbol, if defined, indicates that the strerror() routine is + * available to translate error numbers to strings. + */ +/*#undef HAS_STRERROR /**/ + +/* HAS_SYMLINK + * This symbol, if defined, indicates that the symlink routine is available + * to create symbolic links. + */ +#define HAS_SYMLINK /**/ + +/* HAS_SYSCALL + * This symbol, if defined, indicates that the syscall routine is available + * to call arbitrary system calls. If undefined, that's tough. + */ +#define HAS_SYSCALL /**/ + +/* HAS_TELLDIR + * This symbol, if defined, indicates that the telldir routine is + * available to tell your location in directories. + */ +#define HAS_TELLDIR /**/ + +/* HAS_TRUNCATE + * This symbol, if defined, indicates that the truncate routine is + * available to truncate files. + */ +#define HAS_TRUNCATE /**/ + +/* HAS_VFORK + * This symbol, if defined, indicates that vfork() exists. + */ +#define HAS_VFORK /**/ + +/* VOIDSIG + * This symbol is defined if this system declares "void (*signal())()" in + * signal.h. The old way was to declare it as "int (*signal())()". It + * is up to the package author to declare things correctly based on the + * symbol. + */ +/* TO_SIGNAL + * This symbol's value is either "void" or "int", corresponding to the + * appropriate return "type" of a signal handler. Thus, one can declare + * a signal handler using "TO_SIGNAL (*handler())()", and define the + * handler using "TO_SIGNAL handler(sig)". + */ +#define VOIDSIG /**/ +#define TO_SIGNAL int /**/ + +/* HASVOLATILE + * This symbol, if defined, indicates that this C compiler knows about + * the volatile declaration. + */ +/*#undef HASVOLATILE /**/ + +/* HAS_VPRINTF + * This symbol, if defined, indicates that the vprintf routine is available + * to printf with a pointer to an argument list. If unavailable, you + * may need to write your own, probably in terms of _doprnt(). + */ +/* CHARVSPRINTF + * This symbol is defined if this system has vsprintf() returning type + * (char*). The trend seems to be to declare it as "int vsprintf()". It + * is up to the package author to declare vsprintf correctly based on the + * symbol. + */ +#define HAS_VPRINTF /**/ +#define CHARVSPRINTF /**/ + +/* HAS_WAIT4 + * This symbol, if defined, indicates that wait4() exists. + */ +#define HAS_WAIT4 /**/ + +/* HAS_WAITPID + * This symbol, if defined, indicates that waitpid() exists. + */ +#define HAS_WAITPID /**/ + +/* GIDTYPE + * This symbol has a value like gid_t, int, ushort, or whatever type is + * used to declare group ids in the kernel. + */ +#define GIDTYPE gid_t /**/ + +/* GROUPSTYPE + * This symbol has a value like gid_t, int, ushort, or whatever type is + * used in the return value of getgroups(). + */ +#define GROUPSTYPE int /**/ + +/* I_FCNTL + * This manifest constant tells the C program to include . + */ +/*#undef I_FCNTL /**/ + +/* I_GDBM + * This symbol, if defined, indicates that gdbm.h exists and should + * be included. + */ +/*#undef I_GDBM /**/ + +/* I_GRP + * This symbol, if defined, indicates to the C program that it should + * include grp.h. + */ +#define I_GRP /**/ + +/* I_NETINET_IN + * This symbol, if defined, indicates to the C program that it should + * include netinet/in.h. + */ +/* I_SYS_IN + * This symbol, if defined, indicates to the C program that it should + * include sys/in.h. + */ +#define I_NETINET_IN /**/ +/*#undef I_SYS_IN /**/ + +/* I_PWD + * This symbol, if defined, indicates to the C program that it should + * include pwd.h. + */ +/* PWQUOTA + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +/* PWCHANGE + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_change. + */ +/* PWCLASS + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_class. + */ +/* PWEXPIRE + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_expire. + */ +/* PWCOMMENT + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_comment. + */ +#define I_PWD /**/ +/*#undef PWQUOTA /**/ +#define PWAGE /**/ +/*#undef PWCHANGE /**/ +/*#undef PWCLASS /**/ +/*#undef PWEXPIRE /**/ +#define PWCOMMENT /**/ + +/* I_SYS_FILE + * This manifest constant tells the C program to include . + */ +#define I_SYS_FILE /**/ + +/* I_SYSIOCTL + * This symbol, if defined, indicates that sys/ioctl.h exists and should + * be included. + */ +#define I_SYSIOCTL /**/ + +/* I_TIME + * This symbol is defined if the program should include . + */ +/* I_SYS_TIME + * This symbol is defined if the program should include . + */ +/* SYSTIMEKERNEL + * This symbol is defined if the program should include + * with KERNEL defined. + */ +/* I_SYS_SELECT + * This symbol is defined if the program should include . + */ +/*#undef I_TIME /**/ +#define I_SYS_TIME /**/ +/*#undef SYSTIMEKERNEL /**/ +/*#undef I_SYS_SELECT /**/ + +/* I_UTIME + * This symbol, if defined, indicates to the C program that it should + * include utime.h. + */ +#define I_UTIME /**/ + +/* I_VARARGS + * This symbol, if defined, indicates to the C program that it should + * include varargs.h. + */ +#define I_VARARGS /**/ + +/* I_VFORK + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +#define I_VFORK /**/ + +/* INTSIZE + * This symbol contains the size of an int, so that the C preprocessor + * can make decisions based on it. + */ +#define INTSIZE 4 /**/ + +/* I_DIRENT + * This symbol, if defined, indicates that the program should use the + * P1003-style directory routines, and include . + */ +/* I_SYS_DIR + * This symbol, if defined, indicates that the program should use the + * directory functions by including . + */ +/* I_NDIR + * This symbol, if defined, indicates that the program should include the + * system's version of ndir.h, rather than the one with this package. + */ +/* I_SYS_NDIR + * This symbol, if defined, indicates that the program should include the + * system's version of sys/ndir.h, rather than the one with this package. + */ +/* I_MY_DIR + * This symbol, if defined, indicates that the program should compile + * the ndir.c code provided with the package. + */ +/* DIRNAMLEN + * This symbol, if defined, indicates to the C program that the length + * of directory entry names is provided by a d_namlen field. Otherwise + * you need to do strlen() on the d_name field. + */ +#define I_DIRENT /**/ +/*#undef I_SYS_DIR /**/ +/*#undef I_NDIR /**/ +/*#undef I_SYS_NDIR /**/ +/*#undef I_MY_DIR /**/ +/*#undef DIRNAMLEN /**/ + +/* MYMALLOC + * This symbol, if defined, indicates that we're using our own malloc. + */ +/* MALLOCPTRTYPE + * This symbol defines the kind of ptr returned by malloc and realloc. + */ +#define MYMALLOC /**/ + +#define MALLOCPTRTYPE char /**/ + + +/* RANDBITS + * This symbol contains the number of bits of random number the rand() + * function produces. Usual values are 15, 16, and 31. + */ +#define RANDBITS 31 /**/ + +/* SCRIPTDIR + * This symbol holds the name of the directory in which the user wants + * to keep publicly executable scripts for the package in question. It + * is often a directory that is mounted across diverse architectures. + */ +#define SCRIPTDIR "/usr/local/bin" /**/ + +/* SIG_NAME + * This symbol contains an list of signal names in order. + */ +#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","LOST","USR1","USR2" /**/ + +/* STDCHAR + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR unsigned char /**/ + +/* UIDTYPE + * This symbol has a value like uid_t, int, ushort, or whatever type is + * used to declare user ids in the kernel. + */ +#define UIDTYPE uid_t /**/ + +/* VOIDHAVE + * This symbol indicates how much support of the void type is given by this + * compiler. What various bits mean: + * + * 1 = supports declaration of void + * 2 = supports arrays of pointers to functions returning void + * 4 = supports comparisons between pointers to void functions and + * addresses of void functions + * + * The package designer should define VOIDWANT to indicate the requirements + * of the package. This can be done either by #defining VOIDWANT before + * including config.h, or by defining voidwant in Myinit.U. If the level + * of void support necessary is not present, config.h defines void to "int", + * VOID to the empty string, and VOIDP to "char *". + */ +/* void + * This symbol is used for void casts. On implementations which support + * void appropriately, its value is "void". Otherwise, its value maps + * to "int". + */ +/* VOID + * This symbol's value is "void" if the implementation supports void + * appropriately. Otherwise, its value is the empty string. The primary + * use of this symbol is in specifying void parameter lists for function + * prototypes. + */ +/* VOIDP + * This symbol is used for casting generic pointers. On implementations + * which support void appropriately, its value is "void *". Otherwise, + * its value is "char *". + */ +#ifndef VOIDWANT +#define VOIDWANT 7 +#endif +#define VOIDHAVE 7 +#if (VOIDHAVE & VOIDWANT) != VOIDWANT +#define void int /* is void to be avoided? */ +#define VOID +#define VOIDP (char *) +#define M_VOID /* Xenix strikes again */ +#else +#define VOID void +#define VOIDP (void *) +#endif + +/* PRIVLIB + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + */ +#define PRIVLIB "/usr/local/lib/perl" /**/ + +#endif diff --git a/gnu/usr.bin/perl/perl/config.h b/gnu/usr.bin/perl/perl/config.h new file mode 100644 index 0000000..43cc08f --- /dev/null +++ b/gnu/usr.bin/perl/perl/config.h @@ -0,0 +1,892 @@ +#ifndef config_h +#define config_h +/* config.h + * This file was produced by running the config.h.SH script, which + * gets its values from config.sh, which is generally produced by + * running Configure. + * + * Feel free to modify any of this as the need arises. Note, however, + * that running config.h.SH again will wipe out any changes you've made. + * For a more permanent change edit config.sh and rerun config.h.SH. + */ + /*SUPPRESS 460*/ + + +/* EUNICE + * This symbol, if defined, indicates that the program is being compiled + * under the EUNICE package under VMS. The program will need to handle + * things like files that don't go away the first time you unlink them, + * due to version numbering. It will also need to compensate for lack + * of a respectable link() command. + */ +/* VMS + * This symbol, if defined, indicates that the program is running under + * VMS. It is currently only set in conjunction with the EUNICE symbol. + */ +/*#undef EUNICE /**/ +/*#undef VMS /**/ + +/* LOC_SED + * This symbol holds the complete pathname to the sed program. + */ +#define LOC_SED "/usr/bin/sed" /**/ + +/* ALIGN_BYTES + * This symbol contains the number of bytes required to align a double. + * Usual values are 2, 4, and 8. + */ +#define ALIGN_BYTES 4 /**/ + +/* BIN + * This symbol holds the name of the directory in which the user wants + * to keep publicly executable images for the package in question. It + * is most often a local directory such as /usr/local/bin. + */ +#define BIN "/usr/local/bin" /**/ + +/* BYTEORDER + * This symbol contains an encoding of the order of bytes in a long. + * Usual values (in hex) are 0x1234, 0x4321, 0x2143, 0x3412... + */ +#define BYTEORDER 0x1234 /**/ + +/* CPPSTDIN + * This symbol contains the first part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. Typical value of "cc -E" or "/lib/cpp". + */ +/* CPPMINUS + * This symbol contains the second part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. This symbol will have the value "-" if CPPSTDIN needs a minus + * to specify standard input, otherwise the value is "". + */ +#define CPPSTDIN "cc -E" +#define CPPMINUS "-" + +/* HAS_BCMP + * This symbol, if defined, indicates that the bcmp routine is available + * to compare blocks of memory. If undefined, use memcmp. If that's + * not available, roll your own. + */ +#define HAS_BCMP /**/ + +/* HAS_BCOPY + * This symbol, if defined, indicates that the bcopy routine is available + * to copy blocks of memory. Otherwise you should probably use memcpy(). + * If neither is defined, roll your own. + */ +/* SAFE_BCOPY + * This symbol, if defined, indicates that the bcopy routine is available + * to copy potentially overlapping copy blocks of bcopy. Otherwise you + * should probably use memmove() or memcpy(). If neither is defined, + * roll your own. + */ +#define HAS_BCOPY /**/ +#define SAFE_BCOPY /**/ + +/* HAS_BZERO + * This symbol, if defined, indicates that the bzero routine is available + * to zero blocks of memory. Otherwise you should probably use memset() + * or roll your own. + */ +#define HAS_BZERO /**/ + +/* CASTNEGFLOAT + * This symbol, if defined, indicates that this C compiler knows how to + * cast negative or large floating point numbers to unsigned longs, ints + * and shorts. + */ +/* CASTFLAGS + * This symbol contains flags that say what difficulties the compiler + * has casting odd floating values to unsigned long: + * 1 = couldn't cast < 0 + * 2 = couldn't cast >= 0x80000000 + */ +#define CASTNEGFLOAT /**/ +#define CASTFLAGS 0 /**/ + +/* CHARSPRINTF + * This symbol is defined if this system declares "char *sprintf()" in + * stdio.h. The trend seems to be to declare it as "int sprintf()". It + * is up to the package author to declare sprintf correctly based on the + * symbol. + */ +/*#undef CHARSPRINTF /**/ + +/* HAS_CHSIZE + * This symbol, if defined, indicates that the chsize routine is available + * to truncate files. You might need a -lx to get this routine. + */ +/*#undef HAS_CHSIZE /**/ + +/* HAS_CRYPT + * This symbol, if defined, indicates that the crypt routine is available + * to encrypt passwords and the like. + */ +#define HAS_CRYPT /**/ + +/* CSH + * This symbol, if defined, indicates that the C-shell exists. + * If defined, contains the full pathname of csh. + */ +#define CSH "/bin/csh" /**/ + +/* DOSUID + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +/*#undef DOSUID /**/ + +/* HAS_DUP2 + * This symbol, if defined, indicates that the dup2 routine is available + * to dup file descriptors. Otherwise you should use dup(). + */ +#define HAS_DUP2 /**/ + +/* HAS_FCHMOD + * This symbol, if defined, indicates that the fchmod routine is available + * to change mode of opened files. If unavailable, use chmod(). + */ +#define HAS_FCHMOD /**/ + +/* HAS_FCHOWN + * This symbol, if defined, indicates that the fchown routine is available + * to change ownership of opened files. If unavailable, use chown(). + */ +#define HAS_FCHOWN /**/ + +/* HAS_FCNTL + * This symbol, if defined, indicates to the C program that + * the fcntl() function exists. + */ +#define HAS_FCNTL /**/ + +/* FLEXFILENAMES + * This symbol, if defined, indicates that the system supports filenames + * longer than 14 characters. + */ +#define FLEXFILENAMES /**/ + +/* HAS_FLOCK + * This symbol, if defined, indicates that the flock() routine is + * available to do file locking. + */ +#define HAS_FLOCK /**/ + +/* HAS_GETGROUPS + * This symbol, if defined, indicates that the getgroups() routine is + * available to get the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +#define HAS_GETGROUPS /**/ + +/* HAS_GETHOSTENT + * This symbol, if defined, indicates that the gethostent() routine is + * available to lookup host names in some data base or other. + */ +/*#undef HAS_GETHOSTENT /**/ + +/* HAS_GETPGRP + * This symbol, if defined, indicates that the getpgrp() routine is + * available to get the current process group. + */ +#define HAS_GETPGRP /**/ + +/* HAS_GETPGRP2 + * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) + * routine is available to get the current process group. + */ +/*#undef HAS_GETPGRP2 /**/ + +/* HAS_GETPRIORITY + * This symbol, if defined, indicates that the getpriority() routine is + * available to get a process's priority. + */ +#define HAS_GETPRIORITY /**/ + +/* HAS_HTONS + * This symbol, if defined, indicates that the htons routine (and friends) + * are available to do network order byte swapping. + */ +/* HAS_HTONL + * This symbol, if defined, indicates that the htonl routine (and friends) + * are available to do network order byte swapping. + */ +/* HAS_NTOHS + * This symbol, if defined, indicates that the ntohs routine (and friends) + * are available to do network order byte swapping. + */ +/* HAS_NTOHL + * This symbol, if defined, indicates that the ntohl routine (and friends) + * are available to do network order byte swapping. + */ +#define HAS_HTONS /**/ +#define HAS_HTONL /**/ +#define HAS_NTOHS /**/ +#define HAS_NTOHL /**/ + +/* index + * This preprocessor symbol is defined, along with rindex, if the system + * uses the strchr and strrchr routines instead. + */ +/* rindex + * This preprocessor symbol is defined, along with index, if the system + * uses the strchr and strrchr routines instead. + */ +/*#undef index strchr /* cultural */ +/*#undef rindex strrchr /* differences? */ + +/* HAS_ISASCII + * This symbol, if defined, indicates that the isascii routine is available + * to test characters for asciiness. + */ +#define HAS_ISASCII /**/ + +/* HAS_KILLPG + * This symbol, if defined, indicates that the killpg routine is available + * to kill process groups. If unavailable, you probably should use kill + * with a negative process number. + */ +#define HAS_KILLPG /**/ + +/* HAS_LSTAT + * This symbol, if defined, indicates that the lstat() routine is + * available to stat symbolic links. + */ +#define HAS_LSTAT /**/ + +/* HAS_MEMCMP + * This symbol, if defined, indicates that the memcmp routine is available + * to compare blocks of memory. If undefined, roll your own. + */ +#define HAS_MEMCMP /**/ + +/* HAS_MEMCPY + * This symbol, if defined, indicates that the memcpy routine is available + * to copy blocks of memory. Otherwise you should probably use bcopy(). + * If neither is defined, roll your own. + */ +/* SAFE_MEMCPY + * This symbol, if defined, indicates that the memcpy routine is available + * to copy potentially overlapping copy blocks of memory. Otherwise you + * should probably use memmove() or bcopy(). If neither is defined, + * roll your own. + */ +#define HAS_MEMCPY /**/ +#define SAFE_MEMCPY /**/ + +/* HAS_MEMMOVE + * This symbol, if defined, indicates that the memmove routine is available + * to move potentially overlapping blocks of memory. Otherwise you + * should use bcopy() or roll your own. + */ +#define HAS_MEMMOVE /**/ + +/* HAS_MEMSET + * This symbol, if defined, indicates that the memset routine is available + * to set a block of memory to a character. If undefined, roll your own. + */ +#define HAS_MEMSET /**/ + +/* HAS_MKDIR + * This symbol, if defined, indicates that the mkdir routine is available + * to create directories. Otherwise you should fork off a new process to + * exec /bin/mkdir. + */ +#define HAS_MKDIR /**/ + +/* HAS_MSG + * This symbol, if defined, indicates that the entire msg*(2) library is + * supported. + */ +/*#undef HAS_MSG /**/ + +/* HAS_MSGCTL + * This symbol, if defined, indicates that the msgctl() routine is + * available to control message passing. + */ +/*#undef HAS_MSGCTL /**/ + +/* HAS_MSGGET + * This symbol, if defined, indicates that the msgget() routine is + * available to get messages. + */ +/*#undef HAS_MSGGET /**/ + +/* HAS_MSGRCV + * This symbol, if defined, indicates that the msgrcv() routine is + * available to receive messages. + */ +/*#undef HAS_MSGRCV /**/ + +/* HAS_MSGSND + * This symbol, if defined, indicates that the msgsnd() routine is + * available to send messages. + */ +/*#undef HAS_MSGSND /**/ + +/* HAS_NDBM + * This symbol, if defined, indicates that ndbm.h exists and should + * be included. + */ +#define HAS_NDBM /**/ + +/* HAS_ODBM + * This symbol, if defined, indicates that dbm.h exists and should + * be included. + */ +/*#undef HAS_ODBM /**/ + +/* HAS_OPEN3 + * This manifest constant lets the C program know that the three + * argument form of open(2) is available. + */ +#define HAS_OPEN3 /**/ + +/* HAS_READDIR + * This symbol, if defined, indicates that the readdir routine is available + * from the C library to read directories. + */ +#define HAS_READDIR /**/ + +/* HAS_RENAME + * This symbol, if defined, indicates that the rename routine is available + * to rename files. Otherwise you should do the unlink(), link(), unlink() + * trick. + */ +#define HAS_RENAME /**/ + +/* HAS_REWINDDIR + * This symbol, if defined, indicates that the rewindir routine is + * available to rewind directories. + */ +#define HAS_REWINDDIR /**/ + +/* HAS_RMDIR + * This symbol, if defined, indicates that the rmdir routine is available + * to remove directories. Otherwise you should fork off a new process to + * exec /bin/rmdir. + */ +#define HAS_RMDIR /**/ + +/* HAS_SEEKDIR + * This symbol, if defined, indicates that the seekdir routine is + * available to seek into directories. + */ +#define HAS_SEEKDIR /**/ + +/* HAS_SELECT + * This symbol, if defined, indicates that the select() subroutine + * exists. + */ +#define HAS_SELECT /**/ + +/* HAS_SEM + * This symbol, if defined, indicates that the entire sem*(2) library is + * supported. + */ +/*#undef HAS_SEM /**/ + +/* HAS_SEMCTL + * This symbol, if defined, indicates that the semctl() routine is + * available to control semaphores. + */ +/*#undef HAS_SEMCTL /**/ + +/* HAS_SEMGET + * This symbol, if defined, indicates that the semget() routine is + * available to get semaphores ids. + */ +/*#undef HAS_SEMGET /**/ + +/* HAS_SEMOP + * This symbol, if defined, indicates that the semop() routine is + * available to perform semaphore operations. + */ +/*#undef HAS_SEMOP /**/ + +/* HAS_SETEGID + * This symbol, if defined, indicates that the setegid routine is available + * to change the effective gid of the current program. + */ +#define HAS_SETEGID /**/ + +/* HAS_SETEUID + * This symbol, if defined, indicates that the seteuid routine is available + * to change the effective uid of the current program. + */ +#define HAS_SETEUID /**/ + +/* HAS_SETPGRP + * This symbol, if defined, indicates that the setpgrp() routine is + * available to set the current process group. + */ +#define HAS_SETPGRP /**/ + +/* HAS_SETPGRP2 + * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) + * routine is available to set the current process group. + */ +/*#undef HAS_SETPGRP2 /**/ + +/* HAS_SETPRIORITY + * This symbol, if defined, indicates that the setpriority() routine is + * available to set a process's priority. + */ +#define HAS_SETPRIORITY /**/ + +/* HAS_SETREGID + * This symbol, if defined, indicates that the setregid routine is + * available to change the real and effective gid of the current program. + */ +/* HAS_SETRESGID + * This symbol, if defined, indicates that the setresgid routine is + * available to change the real, effective and saved gid of the current + * program. + */ +#define HAS_SETREGID /**/ +/*#undef HAS_SETRESGID /**/ + +/* HAS_SETREUID + * This symbol, if defined, indicates that the setreuid routine is + * available to change the real and effective uid of the current program. + */ +/* HAS_SETRESUID + * This symbol, if defined, indicates that the setresuid routine is + * available to change the real, effective and saved uid of the current + * program. + */ +#define HAS_SETREUID /**/ +/*#undef HAS_SETRESUID /**/ + +/* HAS_SETRGID + * This symbol, if defined, indicates that the setrgid routine is available + * to change the real gid of the current program. + */ +#define HAS_SETRGID /**/ + +/* HAS_SETRUID + * This symbol, if defined, indicates that the setruid routine is available + * to change the real uid of the current program. + */ +#define HAS_SETRUID /**/ + +/* HAS_SHM + * This symbol, if defined, indicates that the entire shm*(2) library is + * supported. + */ +/*#undef HAS_SHM /**/ + +/* HAS_SHMAT + * This symbol, if defined, indicates that the shmat() routine is + * available to attach a shared memory segment. + */ +/* VOID_SHMAT + * This symbol, if defined, indicates that the shmat() routine + * returns a pointer of type void*. + */ +/*#undef HAS_SHMAT /**/ + +/*#undef VOIDSHMAT /**/ + +/* HAS_SHMCTL + * This symbol, if defined, indicates that the shmctl() routine is + * available to control a shared memory segment. + */ +/*#undef HAS_SHMCTL /**/ + +/* HAS_SHMDT + * This symbol, if defined, indicates that the shmdt() routine is + * available to detach a shared memory segment. + */ +/*#undef HAS_SHMDT /**/ + +/* HAS_SHMGET + * This symbol, if defined, indicates that the shmget() routine is + * available to get a shared memory segment id. + */ +/*#undef HAS_SHMGET /**/ + +/* HAS_SOCKET + * This symbol, if defined, indicates that the BSD socket interface is + * supported. + */ +/* HAS_SOCKETPAIR + * This symbol, if defined, indicates that the BSD socketpair call is + * supported. + */ +/* OLDSOCKET + * This symbol, if defined, indicates that the 4.1c BSD socket interface + * is supported instead of the 4.2/4.3 BSD socket interface. + */ +#define HAS_SOCKET /**/ + +#define HAS_SOCKETPAIR /**/ + +/*#undef OLDSOCKET /**/ + +/* STATBLOCKS + * This symbol is defined if this system has a stat structure declaring + * st_blksize and st_blocks. + */ +#define STATBLOCKS /**/ + +/* STDSTDIO + * This symbol is defined if this system has a FILE structure declaring + * _ptr and _cnt in stdio.h. + */ +/*#undef STDSTDIO /**/ + +/* STRUCTCOPY + * This symbol, if defined, indicates that this C compiler knows how + * to copy structures. If undefined, you'll need to use a block copy + * routine of some sort instead. + */ +#define STRUCTCOPY /**/ + +/* HAS_STRERROR + * This symbol, if defined, indicates that the strerror() routine is + * available to translate error numbers to strings. + */ +#define HAS_STRERROR /**/ + +/* HAS_SYMLINK + * This symbol, if defined, indicates that the symlink routine is available + * to create symbolic links. + */ +#define HAS_SYMLINK /**/ + +/* HAS_SYSCALL + * This symbol, if defined, indicates that the syscall routine is available + * to call arbitrary system calls. If undefined, that's tough. + */ +#define HAS_SYSCALL /**/ + +/* HAS_TELLDIR + * This symbol, if defined, indicates that the telldir routine is + * available to tell your location in directories. + */ +#define HAS_TELLDIR /**/ + +/* HAS_TRUNCATE + * This symbol, if defined, indicates that the truncate routine is + * available to truncate files. + */ +#define HAS_TRUNCATE /**/ + +/* HAS_VFORK + * This symbol, if defined, indicates that vfork() exists. + */ +#define HAS_VFORK /**/ + +/* VOIDSIG + * This symbol is defined if this system declares "void (*signal())()" in + * signal.h. The old way was to declare it as "int (*signal())()". It + * is up to the package author to declare things correctly based on the + * symbol. + */ +/* TO_SIGNAL + * This symbol's value is either "void" or "int", corresponding to the + * appropriate return "type" of a signal handler. Thus, one can declare + * a signal handler using "TO_SIGNAL (*handler())()", and define the + * handler using "TO_SIGNAL handler(sig)". + */ +#define VOIDSIG /**/ +#define TO_SIGNAL int /**/ + +/* HASVOLATILE + * This symbol, if defined, indicates that this C compiler knows about + * the volatile declaration. + */ +#define HASVOLATILE /**/ + +/* HAS_VPRINTF + * This symbol, if defined, indicates that the vprintf routine is available + * to printf with a pointer to an argument list. If unavailable, you + * may need to write your own, probably in terms of _doprnt(). + */ +/* CHARVSPRINTF + * This symbol is defined if this system has vsprintf() returning type + * (char*). The trend seems to be to declare it as "int vsprintf()". It + * is up to the package author to declare vsprintf correctly based on the + * symbol. + */ +#define HAS_VPRINTF /**/ +/*#undef CHARVSPRINTF /**/ + +/* HAS_WAIT4 + * This symbol, if defined, indicates that wait4() exists. + */ +#define HAS_WAIT4 /**/ + +/* HAS_WAITPID + * This symbol, if defined, indicates that waitpid() exists. + */ +#define HAS_WAITPID /**/ + +/* GIDTYPE + * This symbol has a value like gid_t, int, ushort, or whatever type is + * used to declare group ids in the kernel. + */ +#define GIDTYPE gid_t /**/ + +/* GROUPSTYPE + * This symbol has a value like gid_t, int, ushort, or whatever type is + * used in the return value of getgroups(). + */ +#define GROUPSTYPE int /**/ + +/* I_FCNTL + * This manifest constant tells the C program to include . + */ +/*#undef I_FCNTL /**/ + +/* I_GDBM + * This symbol, if defined, indicates that gdbm.h exists and should + * be included. + */ +/*#undef I_GDBM /**/ + +/* I_GRP + * This symbol, if defined, indicates to the C program that it should + * include grp.h. + */ +#define I_GRP /**/ + +/* I_NETINET_IN + * This symbol, if defined, indicates to the C program that it should + * include netinet/in.h. + */ +/* I_SYS_IN + * This symbol, if defined, indicates to the C program that it should + * include sys/in.h. + */ +#define I_NETINET_IN /**/ +/*#undef I_SYS_IN /**/ + +/* I_PWD + * This symbol, if defined, indicates to the C program that it should + * include pwd.h. + */ +/* PWQUOTA + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +/* PWCHANGE + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_change. + */ +/* PWCLASS + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_class. + */ +/* PWEXPIRE + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_expire. + */ +/* PWCOMMENT + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_comment. + */ +#define I_PWD /**/ +/*#undef PWQUOTA /**/ +/*#undef PWAGE /**/ +#define PWCHANGE /**/ +#define PWCLASS /**/ +#define PWEXPIRE /**/ +/*#undef PWCOMMENT /**/ + +/* I_SYS_FILE + * This manifest constant tells the C program to include . + */ +#define I_SYS_FILE /**/ + +/* I_SYSIOCTL + * This symbol, if defined, indicates that sys/ioctl.h exists and should + * be included. + */ +#define I_SYSIOCTL /**/ + +/* I_TIME + * This symbol is defined if the program should include . + */ +/* I_SYS_TIME + * This symbol is defined if the program should include . + */ +/* SYSTIMEKERNEL + * This symbol is defined if the program should include + * with KERNEL defined. + */ +/* I_SYS_SELECT + * This symbol is defined if the program should include . + */ +/*#undef I_TIME /**/ +#define I_SYS_TIME /**/ +/*#undef SYSTIMEKERNEL /**/ +/*#undef I_SYS_SELECT /**/ + +/* I_UTIME + * This symbol, if defined, indicates to the C program that it should + * include utime.h. + */ +#define I_UTIME /**/ + +/* I_VARARGS + * This symbol, if defined, indicates to the C program that it should + * include varargs.h. + */ +#define I_VARARGS /**/ + +/* I_VFORK + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +/*#undef I_VFORK /**/ + +/* INTSIZE + * This symbol contains the size of an int, so that the C preprocessor + * can make decisions based on it. + */ +#define INTSIZE 4 /**/ + +/* I_DIRENT + * This symbol, if defined, indicates that the program should use the + * P1003-style directory routines, and include . + */ +/* I_SYS_DIR + * This symbol, if defined, indicates that the program should use the + * directory functions by including . + */ +/* I_NDIR + * This symbol, if defined, indicates that the program should include the + * system's version of ndir.h, rather than the one with this package. + */ +/* I_SYS_NDIR + * This symbol, if defined, indicates that the program should include the + * system's version of sys/ndir.h, rather than the one with this package. + */ +/* I_MY_DIR + * This symbol, if defined, indicates that the program should compile + * the ndir.c code provided with the package. + */ +/* DIRNAMLEN + * This symbol, if defined, indicates to the C program that the length + * of directory entry names is provided by a d_namlen field. Otherwise + * you need to do strlen() on the d_name field. + */ +#define I_DIRENT /**/ +/*#undef I_SYS_DIR /**/ +/*#undef I_NDIR /**/ +/*#undef I_SYS_NDIR /**/ +/*#undef I_MY_DIR /**/ +/*#undef DIRNAMLEN /**/ + +/* MYMALLOC + * This symbol, if defined, indicates that we're using our own malloc. + */ +/* MALLOCPTRTYPE + * This symbol defines the kind of ptr returned by malloc and realloc. + */ +#define MYMALLOC /**/ + +#define MALLOCPTRTYPE void /**/ + + +/* RANDBITS + * This symbol contains the number of bits of random number the rand() + * function produces. Usual values are 15, 16, and 31. + */ +#define RANDBITS 31 /**/ + +/* SCRIPTDIR + * This symbol holds the name of the directory in which the user wants + * to keep publicly executable scripts for the package in question. It + * is often a directory that is mounted across diverse architectures. + */ +#define SCRIPTDIR "/usr/local/bin" /**/ + +/* SIG_NAME + * This symbol contains an list of signal names in order. + */ +#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","URG","STOP","TSTP","CONT","CHLD","TTIN","TTOU","IO","XCPU","XFSZ","VTALRM","PROF","WINCH","INFO","USR1","USR2" /**/ + +/* STDCHAR + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR char /**/ + +/* UIDTYPE + * This symbol has a value like uid_t, int, ushort, or whatever type is + * used to declare user ids in the kernel. + */ +#define UIDTYPE uid_t /**/ + +/* VOIDHAVE + * This symbol indicates how much support of the void type is given by this + * compiler. What various bits mean: + * + * 1 = supports declaration of void + * 2 = supports arrays of pointers to functions returning void + * 4 = supports comparisons between pointers to void functions and + * addresses of void functions + * + * The package designer should define VOIDWANT to indicate the requirements + * of the package. This can be done either by #defining VOIDWANT before + * including config.h, or by defining voidwant in Myinit.U. If the level + * of void support necessary is not present, config.h defines void to "int", + * VOID to the empty string, and VOIDP to "char *". + */ +/* void + * This symbol is used for void casts. On implementations which support + * void appropriately, its value is "void". Otherwise, its value maps + * to "int". + */ +/* VOID + * This symbol's value is "void" if the implementation supports void + * appropriately. Otherwise, its value is the empty string. The primary + * use of this symbol is in specifying void parameter lists for function + * prototypes. + */ +/* VOIDP + * This symbol is used for casting generic pointers. On implementations + * which support void appropriately, its value is "void *". Otherwise, + * its value is "char *". + */ +#ifndef VOIDWANT +#define VOIDWANT 7 +#endif +#define VOIDHAVE 7 +#if (VOIDHAVE & VOIDWANT) != VOIDWANT +#define void int /* is void to be avoided? */ +#define VOID +#define VOIDP (char *) +#define M_VOID /* Xenix strikes again */ +#else +#define VOID void +#define VOIDP (void *) +#endif + +/* PRIVLIB + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + */ +#define PRIVLIB "/usr/local/lib/perl" /**/ + +#endif diff --git a/gnu/usr.bin/perl/perl/config.sh b/gnu/usr.bin/perl/perl/config.sh new file mode 100644 index 0000000..0baad6b --- /dev/null +++ b/gnu/usr.bin/perl/perl/config.sh @@ -0,0 +1,268 @@ +#!/bin/sh +# config.sh +# This file was produced by running the Configure script. +d_eunice='undef' +define='define' +eunicefix=':' +loclist=' +cat +cp +echo +expr +grep +mkdir +mv +rm +sed +sort +tr +uniq +' +expr='/bin/expr' +sed='/usr/bin/sed' +echo='/bin/echo' +cat='/bin/cat' +rm='/bin/rm' +mv='/bin/mv' +cp='/bin/cp' +tail='' +tr='/usr/bin/tr' +mkdir='/bin/mkdir' +sort='/usr/bin/sort' +uniq='/usr/bin/uniq' +grep='/usr/bin/grep' +trylist=' +Mcc +bison +cpp +csh +egrep +line +nroff +perl +test +uname +yacc +' +test='test' +inews='' +egrep='/usr/bin/egrep' +more='' +pg='' +Mcc='Mcc' +vi='' +mailx='' +mail='' +cpp='/usr/bin/cpp' +perl='perl' +emacs='' +ls='' +rmail='' +sendmail='' +shar='' +smail='' +tbl='' +troff='' +nroff='/usr/bin/nroff' +uname='uname' +uuname='' +line='line' +chgrp='' +chmod='' +lint='' +sleep='' +pr='' +tar='' +ln='' +lpr='' +lp='' +touch='' +make='' +date='' +csh='/bin/csh' +bash='' +ksh='' +lex='' +flex='' +bison='bison' +Log='$Log' +Header='$Header' +Id='$Id' +lastuname='uname: not found' +alignbytes='4' +bin='/usr/gnu/bin' +installbin='/usr/gnu/bin' +byteorder='1234' +contains='grep' +cppstdin='/usr/bin/cpp' +cppminus='' +d_bcmp='define' +d_bcopy='define' +d_safebcpy='define' +d_bzero='define' +d_castneg='define' +castflags='0' +d_charsprf='undef' +d_chsize='undef' +d_crypt='define' +cryptlib='-lcrypt' +d_csh='define' +d_dosuid='define' +d_dup2='define' +d_fchmod='define' +d_fchown='define' +d_fcntl='define' +d_flexfnam='define' +d_flock='define' +d_getgrps='define' +d_gethent='undef' +d_getpgrp='define' +d_getpgrp2='undef' +d_getprior='define' +d_htonl='define' +d_index='undef' +d_isascii='undef' +d_killpg='define' +d_lstat='define' +d_memcmp='define' +d_memcpy='define' +d_safemcpy='define' +d_memmove='define' +d_memset='define' +d_mkdir='define' +d_msg='define' +d_msgctl='define' +d_msgget='define' +d_msgrcv='define' +d_msgsnd='define' +d_ndbm='define' +d_odbm='undef' +d_open3='define' +d_readdir='define' +d_rename='define' +d_rewindir='define' +d_rmdir='define' +d_seekdir='define' +d_select='define' +d_sem='define' +d_semctl='define' +d_semget='define' +d_semop='define' +d_setegid='define' +d_seteuid='define' +d_setpgrp='define' +d_setpgrp2='undef' +d_setprior='define' +d_setregid='define' +d_setresgid='undef' +d_setreuid='define' +d_setresuid='undef' +d_setrgid='define' +d_setruid='define' +d_shm='define' +d_shmat='define' +d_voidshmat='define' +d_shmctl='define' +d_shmdt='define' +d_shmget='define' +d_socket='define' +d_sockpair='define' +d_oldsock='undef' +socketlib='' +d_statblks='define' +d_stdstdio='undef' +d_strctcpy='define' +d_strerror='define' +d_symlink='define' +d_syscall='define' +d_telldir='define' +d_truncate='define' +d_vfork='define' +d_voidsig='define' +d_tosignal='int' +d_volatile='define' +d_vprintf='define' +d_charvspr='undef' +d_wait4='define' +d_waitpid='define' +gidtype='gid_t' +groupstype='int' +i_fcntl='undef' +i_gdbm='undef' +i_grp='define' +i_niin='define' +i_sysin='undef' +i_pwd='define' +d_pwquota='undef' +d_pwage='undef' +d_pwchange='define' +d_pwclass='define' +d_pwexpire='define' +d_pwcomment='undef' +i_sys_file='define' +i_sysioctl='define' +i_time='undef' +i_sys_time='define' +i_sys_select='undef' +d_systimekernel='undef' +i_utime='define' +i_varargs='define' +i_vfork='undef' +intsize='4' +libc='/usr/lib/libc.so.1.0' +nm_opts='' +libndir='' +i_my_dir='undef' +i_ndir='undef' +i_sys_ndir='undef' +i_dirent='define' +i_sys_dir='undef' +d_dirnamlen='define' +ndirc='' +ndiro='' +mallocsrc='malloc.c' +mallocobj='malloc.o' +d_mymalloc='define' +mallocptrtype='void' +mansrc='/usr/gnu/man/man1' +manext='1' +models='none' +split='' +small='' +medium='' +large='' +huge='' +optimize='-O' +ccflags='' +cppflags='' +ldflags='' +cc='cc' +nativegcc='' +libs='-lm' +n='-n' +c='' +package='perl' +randbits='31' +scriptdir='/usr/gnu/bin' +installscr='/usr/gnu/bin' +sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CHLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2' +spitshell='cat' +shsharp='true' +sharpbang='#!' +startsh='#!/bin/sh' +stdchar='char' +uidtype='uid_t' +usrinclude='/usr/include' +inclPath='' +void='' +voidhave='7' +voidwant='7' +w_localtim='1' +w_s_timevl='1' +w_s_tm='1' +yacc='/usr/bin/yacc' +lib='' +privlib='/usr/gnu/lib/perl' +installprivlib='/usr/gnu/lib/perl' +PATCHLEVEL=36 +CONFIG=true diff --git a/gnu/usr.bin/perl/perl/cons.c b/gnu/usr.bin/perl/perl/cons.c new file mode 100644 index 0000000..c926f7a --- /dev/null +++ b/gnu/usr.bin/perl/perl/cons.c @@ -0,0 +1,1450 @@ +/* $RCSfile: cons.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:35 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: cons.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:35 nate + * PERL! + * + * Revision 4.0.1.4 1993/02/05 19:30:15 lwall + * patch36: fixed various little coredump bugs + * + * Revision 4.0.1.3 92/06/08 12:18:35 lwall + * patch20: removed implicit int declarations on funcions + * patch20: deleted some minor memory leaks + * patch20: fixed double debug break in foreach with implicit array assignment + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: debugger sometimes displayed wrong source line + * patch20: various error messages have been clarified + * patch20: an eval block containing a null block or statement could dump core + * + * Revision 4.0.1.2 91/11/05 16:15:13 lwall + * patch11: debugger got confused over nested subroutine definitions + * patch11: prepared for ctype implementations that don't define isascii() + * + * Revision 4.0.1.1 91/06/07 10:31:15 lwall + * patch4: new copyright notice + * patch4: added global modifier for pattern matches + * + * Revision 4.0 91/03/20 01:05:51 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "perly.h" + +extern char *tokename[]; +extern int yychar; + +static int cmd_tosave(); +static int arg_tosave(); +static int spat_tosave(); +static void make_cswitch(); +static void make_nswitch(); + +static bool saw_return; + +SUBR * +make_sub(name,cmd) +char *name; +CMD *cmd; +{ + register SUBR *sub; + STAB *stab = stabent(name,TRUE); + + if (sub = stab_sub(stab)) { + if (dowarn) { + CMD *oldcurcmd = curcmd; + + if (cmd) + curcmd = cmd; + warn("Subroutine %s redefined",name); + curcmd = oldcurcmd; + } + if (!sub->usersub && sub->cmd) { + cmd_free(sub->cmd); + sub->cmd = Nullcmd; + afree(sub->tosave); + } + Safefree(sub); + } + Newz(101,sub,1,SUBR); + stab_sub(stab) = sub; + sub->filestab = curcmd->c_filestab; + saw_return = FALSE; + tosave = anew(Nullstab); + tosave->ary_fill = 0; /* make 1 based */ + (void)cmd_tosave(cmd,FALSE); /* this builds the tosave array */ + sub->tosave = tosave; + if (saw_return) { + struct compcmd mycompblock; + + mycompblock.comp_true = cmd; + mycompblock.comp_alt = Nullcmd; + cmd = add_label(savestr("_SUB_"),make_ccmd(C_BLOCK,0, + Nullarg,mycompblock)); + saw_return = FALSE; + cmd->c_flags |= CF_TERM; + cmd->c_head = cmd; + } + sub->cmd = cmd; + if (perldb) { + STR *str; + STR *tmpstr = str_mortal(&str_undef); + + sprintf(buf,"%s:%ld",stab_val(curcmd->c_filestab)->str_ptr, subline); + str = str_make(buf,0); + str_cat(str,"-"); + sprintf(buf,"%ld",(long)curcmd->c_line); + str_cat(str,buf); + stab_efullname(tmpstr,stab); + hstore(stab_xhash(DBsub), tmpstr->str_ptr, tmpstr->str_cur, str, 0); + } + Safefree(name); + return sub; +} + +SUBR * +make_usub(name, ix, subaddr, filename) +char *name; +int ix; +int (*subaddr)(); +char *filename; +{ + register SUBR *sub; + STAB *stab = stabent(name,allstabs); + + if (!stab) /* unused function */ + return Null(SUBR*); + if (sub = stab_sub(stab)) { + if (dowarn) + warn("Subroutine %s redefined",name); + if (!sub->usersub && sub->cmd) { + cmd_free(sub->cmd); + sub->cmd = Nullcmd; + afree(sub->tosave); + } + Safefree(sub); + } + Newz(101,sub,1,SUBR); + stab_sub(stab) = sub; + sub->filestab = fstab(filename); + sub->usersub = subaddr; + sub->userindex = ix; + return sub; +} + +void +make_form(stab,fcmd) +STAB *stab; +FCMD *fcmd; +{ + if (stab_form(stab)) { + FCMD *tmpfcmd; + FCMD *nextfcmd; + + for (tmpfcmd = stab_form(stab); tmpfcmd; tmpfcmd = nextfcmd) { + nextfcmd = tmpfcmd->f_next; + if (tmpfcmd->f_expr) + arg_free(tmpfcmd->f_expr); + if (tmpfcmd->f_unparsed) + str_free(tmpfcmd->f_unparsed); + if (tmpfcmd->f_pre) + Safefree(tmpfcmd->f_pre); + Safefree(tmpfcmd); + } + } + stab_form(stab) = fcmd; +} + +CMD * +block_head(tail) +register CMD *tail; +{ + CMD *head; + register int opt; + register int last_opt = 0; + register STAB *last_stab = Nullstab; + register int count = 0; + register CMD *switchbeg = Nullcmd; + + if (tail == Nullcmd) { + return tail; + } + head = tail->c_head; + + for (tail = head; tail; tail = tail->c_next) { + + /* save one measly dereference at runtime */ + if (tail->c_type == C_IF) { + if (!(tail->ucmd.ccmd.cc_alt = tail->ucmd.ccmd.cc_alt->c_next)) + tail->c_flags |= CF_TERM; + } + else if (tail->c_type == C_EXPR) { + ARG *arg; + + if (tail->ucmd.acmd.ac_expr) + arg = tail->ucmd.acmd.ac_expr; + else + arg = tail->c_expr; + if (arg) { + if (arg->arg_type == O_RETURN) + tail->c_flags |= CF_TERM; + else if (arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD) + tail->c_flags |= CF_TERM; + } + } + if (!tail->c_next) + tail->c_flags |= CF_TERM; + + if (tail->c_expr && (tail->c_flags & CF_OPTIMIZE) == CFT_FALSE) + opt_arg(tail,1, tail->c_type == C_EXPR); + + /* now do a little optimization on case-ish structures */ + switch(tail->c_flags & (CF_OPTIMIZE|CF_FIRSTNEG|CF_INVERT)) { + case CFT_ANCHOR: + case CFT_STROP: + opt = (tail->c_flags & CF_NESURE) ? CFT_STROP : 0; + break; + case CFT_CCLASS: + opt = CFT_STROP; + break; + case CFT_NUMOP: + opt = (tail->c_slen == O_NE ? 0 : CFT_NUMOP); + if ((tail->c_flags&(CF_NESURE|CF_EQSURE)) != (CF_NESURE|CF_EQSURE)) + opt = 0; + break; + default: + opt = 0; + } + if (opt && opt == last_opt && tail->c_stab == last_stab) + count++; + else { + if (count >= 3) { /* is this the breakeven point? */ + if (last_opt == CFT_NUMOP) + make_nswitch(switchbeg,count); + else + make_cswitch(switchbeg,count); + } + if (opt) { + count = 1; + switchbeg = tail; + } + else + count = 0; + } + last_opt = opt; + last_stab = tail->c_stab; + } + if (count >= 3) { /* is this the breakeven point? */ + if (last_opt == CFT_NUMOP) + make_nswitch(switchbeg,count); + else + make_cswitch(switchbeg,count); + } + return head; +} + +/* We've spotted a sequence of CMDs that all test the value of the same + * spat. Thus we can insert a SWITCH in front and jump directly + * to the correct one. + */ +static void +make_cswitch(head,count) +register CMD *head; +int count; +{ + register CMD *cur; + register CMD **loc; + register int i; + register int min = 255; + register int max = 0; + + /* make a new head in the exact same spot */ + New(102,cur, 1, CMD); + StructCopy(head,cur,CMD); + Zero(head,1,CMD); + head->c_head = cur->c_head; + head->c_type = C_CSWITCH; + head->c_next = cur; /* insert new cmd at front of list */ + head->c_stab = cur->c_stab; + + Newz(103,loc,258,CMD*); + loc++; /* lie a little */ + while (count--) { + if ((cur->c_flags & CF_OPTIMIZE) == CFT_CCLASS) { + for (i = 0; i <= 255; i++) { + if (!loc[i] && cur->c_short->str_ptr[i>>3] & (1 << (i&7))) { + loc[i] = cur; + if (i < min) + min = i; + if (i > max) + max = i; + } + } + } + else { + i = *cur->c_short->str_ptr & 255; + if (!loc[i]) { + loc[i] = cur; + if (i < min) + min = i; + if (i > max) + max = i; + } + } + cur = cur->c_next; + } + max++; + if (min > 0) + Move(&loc[min],&loc[0], max - min, CMD*); + loc--; + min--; + max -= min; + for (i = 0; i <= max; i++) + if (!loc[i]) + loc[i] = cur; + Renew(loc,max+1,CMD*); /* chop it down to size */ + head->ucmd.scmd.sc_offset = min; + head->ucmd.scmd.sc_max = max; + head->ucmd.scmd.sc_next = loc; +} + +static void +make_nswitch(head,count) +register CMD *head; +int count; +{ + register CMD *cur = head; + register CMD **loc; + register int i; + register int min = 32767; + register int max = -32768; + int origcount = count; + double value; /* or your money back! */ + short changed; /* so triple your money back! */ + + while (count--) { + i = (int)str_gnum(cur->c_short); + value = (double)i; + if (value != cur->c_short->str_u.str_nval) + return; /* fractional values--just forget it */ + changed = i; + if (changed != i) + return; /* too big for a short */ + if (cur->c_slen == O_LE) + i++; + else if (cur->c_slen == O_GE) /* we only do < or > here */ + i--; + if (i < min) + min = i; + if (i > max) + max = i; + cur = cur->c_next; + } + count = origcount; + if (max - min > count * 2 + 10) /* too sparse? */ + return; + + /* now make a new head in the exact same spot */ + New(104,cur, 1, CMD); + StructCopy(head,cur,CMD); + Zero(head,1,CMD); + head->c_head = cur->c_head; + head->c_type = C_NSWITCH; + head->c_next = cur; /* insert new cmd at front of list */ + head->c_stab = cur->c_stab; + + Newz(105,loc, max - min + 3, CMD*); + loc++; + max -= min; + max++; + while (count--) { + i = (int)str_gnum(cur->c_short); + i -= min; + switch(cur->c_slen) { + case O_LE: + i++; + case O_LT: + for (i--; i >= -1; i--) + if (!loc[i]) + loc[i] = cur; + break; + case O_GE: + i--; + case O_GT: + for (i++; i <= max; i++) + if (!loc[i]) + loc[i] = cur; + break; + case O_EQ: + if (!loc[i]) + loc[i] = cur; + break; + } + cur = cur->c_next; + } + loc--; + min--; + max++; + for (i = 0; i <= max; i++) + if (!loc[i]) + loc[i] = cur; + head->ucmd.scmd.sc_offset = min; + head->ucmd.scmd.sc_max = max; + head->ucmd.scmd.sc_next = loc; +} + +CMD * +append_line(head,tail) +register CMD *head; +register CMD *tail; +{ + if (tail == Nullcmd) + return head; + if (!tail->c_head) /* make sure tail is well formed */ + tail->c_head = tail; + if (head != Nullcmd) { + tail = tail->c_head; /* get to start of tail list */ + if (!head->c_head) + head->c_head = head; /* start a new head list */ + while (head->c_next) { + head->c_next->c_head = head->c_head; + head = head->c_next; /* get to end of head list */ + } + head->c_next = tail; /* link to end of old list */ + tail->c_head = head->c_head; /* propagate head pointer */ + } + while (tail->c_next) { + tail->c_next->c_head = tail->c_head; + tail = tail->c_next; + } + return tail; +} + +CMD * +dodb(cur) +CMD *cur; +{ + register CMD *cmd; + register CMD *head = cur->c_head; + STR *str; + + if (!head) + head = cur; + if (!head->c_line) + return cur; + str = afetch(stab_xarray(curcmd->c_filestab),(int)head->c_line,FALSE); + if (str == &str_undef || str->str_nok) + return cur; + str->str_u.str_nval = (double)head->c_line; + str->str_nok = 1; + Newz(106,cmd,1,CMD); + str_magic(str, curcmd->c_filestab, 0, Nullch, 0); + str->str_magic->str_u.str_cmd = cmd; + cmd->c_type = C_EXPR; + cmd->ucmd.acmd.ac_stab = Nullstab; + cmd->ucmd.acmd.ac_expr = Nullarg; + cmd->c_expr = make_op(O_SUBR, 2, + stab2arg(A_WORD,DBstab), + Nullarg, + Nullarg); + /*SUPPRESS 53*/ + cmd->c_flags |= CF_COND|CF_DBSUB|CFT_D0; + cmd->c_line = head->c_line; + cmd->c_label = head->c_label; + cmd->c_filestab = curcmd->c_filestab; + cmd->c_stash = curstash; + return append_line(cmd, cur); +} + +CMD * +make_acmd(type,stab,cond,arg) +int type; +STAB *stab; +ARG *cond; +ARG *arg; +{ + register CMD *cmd; + + Newz(107,cmd,1,CMD); + cmd->c_type = type; + cmd->ucmd.acmd.ac_stab = stab; + cmd->ucmd.acmd.ac_expr = arg; + cmd->c_expr = cond; + if (cond) + cmd->c_flags |= CF_COND; + if (cmdline == NOLINE) + cmd->c_line = curcmd->c_line; + else { + cmd->c_line = cmdline; + cmdline = NOLINE; + } + cmd->c_filestab = curcmd->c_filestab; + cmd->c_stash = curstash; + if (perldb) + cmd = dodb(cmd); + return cmd; +} + +CMD * +make_ccmd(type,debuggable,arg,cblock) +int type; +int debuggable; +ARG *arg; +struct compcmd cblock; +{ + register CMD *cmd; + + Newz(108,cmd, 1, CMD); + cmd->c_type = type; + cmd->c_expr = arg; + cmd->ucmd.ccmd.cc_true = cblock.comp_true; + cmd->ucmd.ccmd.cc_alt = cblock.comp_alt; + if (arg) + cmd->c_flags |= CF_COND; + if (cmdline == NOLINE) + cmd->c_line = curcmd->c_line; + else { + cmd->c_line = cmdline; + cmdline = NOLINE; + } + cmd->c_filestab = curcmd->c_filestab; + cmd->c_stash = curstash; + if (perldb && debuggable) + cmd = dodb(cmd); + return cmd; +} + +CMD * +make_icmd(type,arg,cblock) +int type; +ARG *arg; +struct compcmd cblock; +{ + register CMD *cmd; + register CMD *alt; + register CMD *cur; + register CMD *head; + struct compcmd ncblock; + + Newz(109,cmd, 1, CMD); + head = cmd; + cmd->c_type = type; + cmd->c_expr = arg; + cmd->ucmd.ccmd.cc_true = cblock.comp_true; + cmd->ucmd.ccmd.cc_alt = cblock.comp_alt; + if (arg) + cmd->c_flags |= CF_COND; + if (cmdline == NOLINE) + cmd->c_line = curcmd->c_line; + else { + cmd->c_line = cmdline; + cmdline = NOLINE; + } + cmd->c_filestab = curcmd->c_filestab; + cmd->c_stash = curstash; + cur = cmd; + alt = cblock.comp_alt; + while (alt && alt->c_type == C_ELSIF) { + cur = alt; + alt = alt->ucmd.ccmd.cc_alt; + } + if (alt) { /* a real life ELSE at the end? */ + ncblock.comp_true = alt; + ncblock.comp_alt = Nullcmd; + alt = append_line(cur,make_ccmd(C_ELSE,1,Nullarg,ncblock)); + cur->ucmd.ccmd.cc_alt = alt; + } + else + alt = cur; /* no ELSE, so cur is proxy ELSE */ + + cur = cmd; + while (cmd) { /* now point everyone at the ELSE */ + cur = cmd; + cmd = cur->ucmd.ccmd.cc_alt; + cur->c_head = head; + if (cur->c_type == C_ELSIF) + cur->c_type = C_IF; + if (cur->c_type == C_IF) + cur->ucmd.ccmd.cc_alt = alt; + if (cur == alt) + break; + cur->c_next = cmd; + } + if (perldb) + cur = dodb(cur); + return cur; +} + +void +opt_arg(cmd,fliporflop,acmd) +register CMD *cmd; +int fliporflop; +int acmd; +{ + register ARG *arg; + int opt = CFT_EVAL; + int sure = 0; + ARG *arg2; + int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */ + int flp = fliporflop; + + if (!cmd) + return; + if (!(arg = cmd->c_expr)) { + cmd->c_flags &= ~CF_COND; + return; + } + + /* Can we turn && and || into if and unless? */ + + if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM) && + (arg->arg_type == O_AND || arg->arg_type == O_OR) ) { + dehoist(arg,1); + arg[2].arg_type &= A_MASK; /* don't suppress eval */ + dehoist(arg,2); + cmd->ucmd.acmd.ac_expr = arg[2].arg_ptr.arg_arg; + cmd->c_expr = arg[1].arg_ptr.arg_arg; + if (arg->arg_type == O_OR) + cmd->c_flags ^= CF_INVERT; /* || is like unless */ + arg->arg_len = 0; + free_arg(arg); + arg = cmd->c_expr; + } + + /* Turn "if (!expr)" into "unless (expr)" */ + + if (!(cmd->c_flags & CF_TERM)) { /* unless return value wanted */ + while (arg->arg_type == O_NOT) { + dehoist(arg,1); + cmd->c_flags ^= CF_INVERT; /* flip sense of cmd */ + cmd->c_expr = arg[1].arg_ptr.arg_arg; /* hoist the rest of expr */ + free_arg(arg); + arg = cmd->c_expr; /* here we go again */ + } + } + + if (!arg->arg_len) { /* sanity check */ + cmd->c_flags |= opt; + return; + } + + /* for "cond .. cond" we set up for the initial check */ + + if (arg->arg_type == O_FLIP) + context |= 4; + + /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */ + + morecontext: + if (arg->arg_type == O_AND) + context |= 1; + else if (arg->arg_type == O_OR) + context |= 2; + if (context && (arg[flp].arg_type & A_MASK) == A_EXPR) { + arg = arg[flp].arg_ptr.arg_arg; + flp = 1; + if (arg->arg_type == O_AND || arg->arg_type == O_OR) + goto morecontext; + } + if ((context & 3) == 3) + return; + + if (arg[flp].arg_flags & (AF_PRE|AF_POST)) { + cmd->c_flags |= opt; + if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM) + && cmd->c_expr->arg_type == O_ITEM) { + arg[flp].arg_flags &= ~AF_POST; /* prefer ++$foo to $foo++ */ + arg[flp].arg_flags |= AF_PRE; /* if value not wanted */ + } + return; /* side effect, can't optimize */ + } + + if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP || + arg->arg_type == O_AND || arg->arg_type == O_OR) { + if ((arg[flp].arg_type & A_MASK) == A_SINGLE) { + opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE); + cmd->c_short = str_smake(arg[flp].arg_ptr.arg_str); + goto literal; + } + else if ((arg[flp].arg_type & A_MASK) == A_STAB || + (arg[flp].arg_type & A_MASK) == A_LVAL) { + cmd->c_stab = arg[flp].arg_ptr.arg_stab; + if (!context) + arg[flp].arg_ptr.arg_stab = Nullstab; + opt = CFT_REG; + literal: + if (!context) { /* no && or ||? */ + arg_free(arg); + cmd->c_expr = Nullarg; + } + if (!(context & 1)) + cmd->c_flags |= CF_EQSURE; + if (!(context & 2)) + cmd->c_flags |= CF_NESURE; + } + } + else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST || + arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) { + if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && + (arg[2].arg_type & A_MASK) == A_SPAT && + arg[2].arg_ptr.arg_spat->spat_short && + (arg->arg_type == O_SUBST || arg->arg_type == O_NSUBST || + (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_GLOBAL) == 0 )) { + cmd->c_stab = arg[1].arg_ptr.arg_stab; + cmd->c_short = str_smake(arg[2].arg_ptr.arg_spat->spat_short); + cmd->c_slen = arg[2].arg_ptr.arg_spat->spat_slen; + if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ALL && + !(arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ONCE) && + (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) ) + sure |= CF_EQSURE; /* (SUBST must be forced even */ + /* if we know it will work.) */ + if (arg->arg_type != O_SUBST) { + str_free(arg[2].arg_ptr.arg_spat->spat_short); + arg[2].arg_ptr.arg_spat->spat_short = Nullstr; + arg[2].arg_ptr.arg_spat->spat_slen = 0; /* only one chk */ + } + sure |= CF_NESURE; /* normally only sure if it fails */ + if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) + cmd->c_flags |= CF_FIRSTNEG; + if (context & 1) { /* only sure if thing is false */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_NESURE; + else + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_EQSURE; + else + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { /* if we know anything*/ + if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST) + opt = CFT_SCAN; + else + opt = CFT_ANCHOR; + if (sure == (CF_EQSURE|CF_NESURE) /* really sure? */ + && arg->arg_type == O_MATCH + && context & 4 + && fliporflop == 1) { + spat_free(arg[2].arg_ptr.arg_spat); + arg[2].arg_ptr.arg_spat = Nullspat; /* don't do twice */ + } + else + cmd->c_spat = arg[2].arg_ptr.arg_spat; + cmd->c_flags |= sure; + } + } + } + else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE || + arg->arg_type == O_SLT || arg->arg_type == O_SGT) { + if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) { + if (arg[2].arg_type == A_SINGLE) { + /*SUPPRESS 594*/ + char *junk = str_get(arg[2].arg_ptr.arg_str); + + cmd->c_stab = arg[1].arg_ptr.arg_stab; + cmd->c_short = str_smake(arg[2].arg_ptr.arg_str); + cmd->c_slen = cmd->c_short->str_cur+1; + switch (arg->arg_type) { + case O_SLT: case O_SGT: + sure |= CF_EQSURE; + cmd->c_flags |= CF_FIRSTNEG; + break; + case O_SNE: + cmd->c_flags |= CF_FIRSTNEG; + /* FALL THROUGH */ + case O_SEQ: + sure |= CF_NESURE|CF_EQSURE; + break; + } + if (context & 1) { /* only sure if thing is false */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_NESURE; + else + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_EQSURE; + else + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { + opt = CFT_STROP; + cmd->c_flags |= sure; + } + } + } + } + else if (arg->arg_type == O_EQ || arg->arg_type == O_NE || + arg->arg_type == O_LE || arg->arg_type == O_GE || + arg->arg_type == O_LT || arg->arg_type == O_GT) { + if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) { + if (arg[2].arg_type == A_SINGLE) { + cmd->c_stab = arg[1].arg_ptr.arg_stab; + if (dowarn) { + STR *str = arg[2].arg_ptr.arg_str; + + if ((!str->str_nok && !looks_like_number(str))) + warn("Possible use of == on string value"); + } + cmd->c_short = str_nmake(str_gnum(arg[2].arg_ptr.arg_str)); + cmd->c_slen = arg->arg_type; + sure |= CF_NESURE|CF_EQSURE; + if (context & 1) { /* only sure if thing is false */ + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { + opt = CFT_NUMOP; + cmd->c_flags |= sure; + } + } + } + } + else if (arg->arg_type == O_ASSIGN && + (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && + arg[1].arg_ptr.arg_stab == defstab && + arg[2].arg_type == A_EXPR ) { + arg2 = arg[2].arg_ptr.arg_arg; + if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) { + opt = CFT_GETS; + cmd->c_stab = arg2[1].arg_ptr.arg_stab; + if (!(stab_io(arg2[1].arg_ptr.arg_stab)->flags & IOF_ARGV)) { + free_arg(arg2); + arg[2].arg_ptr.arg_arg = Nullarg; + free_arg(arg); + cmd->c_expr = Nullarg; + } + } + } + else if (arg->arg_type == O_CHOP && + (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) { + opt = CFT_CHOP; + cmd->c_stab = arg[1].arg_ptr.arg_stab; + free_arg(arg); + cmd->c_expr = Nullarg; + } + if (context & 4) + opt |= CF_FLIP; + cmd->c_flags |= opt; + + if (cmd->c_flags & CF_FLIP) { + if (fliporflop == 1) { + arg = cmd->c_expr; /* get back to O_FLIP arg */ + New(110,arg[3].arg_ptr.arg_cmd, 1, CMD); + Copy(cmd, arg[3].arg_ptr.arg_cmd, 1, CMD); + New(111,arg[4].arg_ptr.arg_cmd,1,CMD); + Copy(cmd, arg[4].arg_ptr.arg_cmd, 1, CMD); + opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd); + arg->arg_len = 2; /* this is a lie */ + } + else { + if ((opt & CF_OPTIMIZE) == CFT_EVAL) + cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP; + } + } +} + +CMD * +add_label(lbl,cmd) +char *lbl; +register CMD *cmd; +{ + if (cmd) + cmd->c_label = lbl; + return cmd; +} + +CMD * +addcond(cmd, arg) +register CMD *cmd; +register ARG *arg; +{ + cmd->c_expr = arg; + cmd->c_flags |= CF_COND; + return cmd; +} + +CMD * +addloop(cmd, arg) +register CMD *cmd; +register ARG *arg; +{ + void while_io(); + + cmd->c_expr = arg; + cmd->c_flags |= CF_COND|CF_LOOP; + + if (!(cmd->c_flags & CF_INVERT)) + while_io(cmd); /* add $_ =, if necessary */ + + if (cmd->c_type == C_BLOCK) + cmd->c_flags &= ~CF_COND; + else { + arg = cmd->ucmd.acmd.ac_expr; + if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD) + cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */ + if (arg && (arg->arg_flags & AF_DEPR) && + (arg->arg_type == O_SUBR || arg->arg_type == O_DBSUBR) ) + cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */ + } + return cmd; +} + +CMD * +invert(cmd) +CMD *cmd; +{ + register CMD *targ = cmd; + if (targ->c_head) + targ = targ->c_head; + if (targ->c_flags & CF_DBSUB) + targ = targ->c_next; + targ->c_flags ^= CF_INVERT; + return cmd; +} + +void +cpy7bit(d,s,l) +register char *d; +register char *s; +register int l; +{ + while (l--) + *d++ = *s++ & 127; + *d = '\0'; +} + +int +yyerror(s) +char *s; +{ + char tmpbuf[258]; + char tmp2buf[258]; + char *tname = tmpbuf; + + if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 && + oldoldbufptr != oldbufptr && oldbufptr != bufptr) { + while (isSPACE(*oldoldbufptr)) + oldoldbufptr++; + cpy7bit(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr); + sprintf(tname,"next 2 tokens \"%s\"",tmp2buf); + } + else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 && + oldbufptr != bufptr) { + while (isSPACE(*oldbufptr)) + oldbufptr++; + cpy7bit(tmp2buf, oldbufptr, bufptr - oldbufptr); + sprintf(tname,"next token \"%s\"",tmp2buf); + } + else if (yychar > 256) + tname = "next token ???"; + else if (!yychar) + (void)strcpy(tname,"at EOF"); + else if (yychar < 32) + (void)sprintf(tname,"next char ^%c",yychar+64); + else if (yychar == 127) + (void)strcpy(tname,"at EOF"); + else + (void)sprintf(tname,"next char %c",yychar); + (void)sprintf(buf, "%s in file %s at line %d, %s\n", + s,stab_val(curcmd->c_filestab)->str_ptr,curcmd->c_line,tname); + if (curcmd->c_line == multi_end && multi_start < multi_end) + sprintf(buf+strlen(buf), + " (Might be a runaway multi-line %c%c string starting on line %d)\n", + multi_open,multi_close,multi_start); + if (in_eval) + str_cat(stab_val(stabent("@",TRUE)),buf); + else + fputs(buf,stderr); + if (++error_count >= 10) + fatal("%s has too many errors.\n", + stab_val(curcmd->c_filestab)->str_ptr); +} + +void +while_io(cmd) +register CMD *cmd; +{ + register ARG *arg = cmd->c_expr; + STAB *asgnstab; + + /* hoist "while ()" up into command block */ + + if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) { + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_GETS; /* and set it to do the input */ + cmd->c_stab = arg[1].arg_ptr.arg_stab; + if (stab_io(arg[1].arg_ptr.arg_stab)->flags & IOF_ARGV) { + cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */ + stab2arg(A_LVAL,defstab), arg, Nullarg)); + } + else { + free_arg(arg); + cmd->c_expr = Nullarg; + } + } + else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) { + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_INDGETS; /* and set it to do the input */ + cmd->c_stab = arg[1].arg_ptr.arg_stab; + free_arg(arg); + cmd->c_expr = Nullarg; + } + else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) { + if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY) + asgnstab = cmd->c_stab; + else + asgnstab = defstab; + cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$foo =" */ + stab2arg(A_LVAL,asgnstab), arg, Nullarg)); + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + } +} + +CMD * +wopt(cmd) +register CMD *cmd; +{ + register CMD *tail; + CMD *newtail; + register int i; + + if (cmd->c_expr && (cmd->c_flags & CF_OPTIMIZE) == CFT_FALSE) + opt_arg(cmd,1, cmd->c_type == C_EXPR); + + while_io(cmd); /* add $_ =, if necessary */ + + /* First find the end of the true list */ + + tail = cmd->ucmd.ccmd.cc_true; + if (tail == Nullcmd) + return cmd; + New(112,newtail, 1, CMD); /* guaranteed continue */ + for (;;) { + /* optimize "next" to point directly to continue block */ + if (tail->c_type == C_EXPR && + tail->ucmd.acmd.ac_expr && + tail->ucmd.acmd.ac_expr->arg_type == O_NEXT && + (tail->ucmd.acmd.ac_expr->arg_len == 0 || + (cmd->c_label && + strEQ(cmd->c_label, + tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) ))) + { + arg_free(tail->ucmd.acmd.ac_expr); + tail->ucmd.acmd.ac_expr = Nullarg; + tail->c_type = C_NEXT; + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) + tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt; + else + tail->ucmd.ccmd.cc_alt = newtail; + tail->ucmd.ccmd.cc_true = Nullcmd; + } + else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) { + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) + tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt; + else + tail->ucmd.ccmd.cc_alt = newtail; + } + else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) { + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) { + for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) + if (!tail->ucmd.scmd.sc_next[i]) + tail->ucmd.scmd.sc_next[i] = cmd->ucmd.ccmd.cc_alt; + } + else { + for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) + if (!tail->ucmd.scmd.sc_next[i]) + tail->ucmd.scmd.sc_next[i] = newtail; + } + } + + if (!tail->c_next) + break; + tail = tail->c_next; + } + + /* if there's a continue block, link it to true block and find end */ + + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) { + tail->c_next = cmd->ucmd.ccmd.cc_alt; + tail = tail->c_next; + for (;;) { + /* optimize "next" to point directly to continue block */ + if (tail->c_type == C_EXPR && + tail->ucmd.acmd.ac_expr && + tail->ucmd.acmd.ac_expr->arg_type == O_NEXT && + (tail->ucmd.acmd.ac_expr->arg_len == 0 || + (cmd->c_label && + strEQ(cmd->c_label, + tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) ))) + { + arg_free(tail->ucmd.acmd.ac_expr); + tail->ucmd.acmd.ac_expr = Nullarg; + tail->c_type = C_NEXT; + tail->ucmd.ccmd.cc_alt = newtail; + tail->ucmd.ccmd.cc_true = Nullcmd; + } + else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) { + tail->ucmd.ccmd.cc_alt = newtail; + } + else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) { + for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) + if (!tail->ucmd.scmd.sc_next[i]) + tail->ucmd.scmd.sc_next[i] = newtail; + } + + if (!tail->c_next) + break; + tail = tail->c_next; + } + /*SUPPRESS 530*/ + for ( ; tail->c_next; tail = tail->c_next) ; + } + + /* Here's the real trick: link the end of the list back to the beginning, + * inserting a "last" block to break out of the loop. This saves one or + * two procedure calls every time through the loop, because of how cmd_exec + * does tail recursion. + */ + + tail->c_next = newtail; + tail = newtail; + if (!cmd->ucmd.ccmd.cc_alt) + cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */ + +#ifndef lint + Copy((char *)cmd, (char *)tail, 1, CMD); +#endif + tail->c_type = C_EXPR; + tail->c_flags ^= CF_INVERT; /* turn into "last unless" */ + tail->c_next = tail->ucmd.ccmd.cc_true; /* loop directly back to top */ + tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg); + tail->ucmd.acmd.ac_stab = Nullstab; + return cmd; +} + +CMD * +over(eachstab,cmd) +STAB *eachstab; +register CMD *cmd; +{ + /* hoist "for $foo (@bar)" up into command block */ + + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_ARRAY; /* and set it to do the iteration */ + cmd->c_stab = eachstab; + cmd->c_short = Str_new(23,0); /* just to save a field in struct cmd */ + cmd->c_short->str_u.str_useful = -1; + + return cmd; +} + +void +cmd_free(cmd) +register CMD *cmd; +{ + register CMD *tofree; + register CMD *head = cmd; + + if (!cmd) + return; + if (cmd->c_head != cmd) + warn("Malformed cmd links\n"); + while (cmd) { + if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */ + if (cmd->c_label) { + Safefree(cmd->c_label); + cmd->c_label = Nullch; + } + if (cmd->c_short) { + str_free(cmd->c_short); + cmd->c_short = Nullstr; + } + if (cmd->c_expr) { + arg_free(cmd->c_expr); + cmd->c_expr = Nullarg; + } + } + switch (cmd->c_type) { + case C_WHILE: + case C_BLOCK: + case C_ELSE: + case C_IF: + if (cmd->ucmd.ccmd.cc_true) { + cmd_free(cmd->ucmd.ccmd.cc_true); + cmd->ucmd.ccmd.cc_true = Nullcmd; + } + break; + case C_EXPR: + if (cmd->ucmd.acmd.ac_expr) { + arg_free(cmd->ucmd.acmd.ac_expr); + cmd->ucmd.acmd.ac_expr = Nullarg; + } + break; + } + tofree = cmd; + cmd = cmd->c_next; + if (tofree != head) /* to get Saber to shut up */ + Safefree(tofree); + if (cmd && cmd == head) /* reached end of while loop */ + break; + } + Safefree(head); +} + +void +arg_free(arg) +register ARG *arg; +{ + register int i; + + if (!arg) + return; + for (i = 1; i <= arg->arg_len; i++) { + switch (arg[i].arg_type & A_MASK) { + case A_NULL: + if (arg->arg_type == O_TRANS) { + Safefree(arg[i].arg_ptr.arg_cval); + arg[i].arg_ptr.arg_cval = Nullch; + } + break; + case A_LEXPR: + if (arg->arg_type == O_AASSIGN && + arg[i].arg_ptr.arg_arg->arg_type == O_LARRAY) { + char *name = + stab_name(arg[i].arg_ptr.arg_arg[1].arg_ptr.arg_stab); + + if (strnEQ("_GEN_",name, 5)) /* array for foreach */ + hdelete(defstash,name,strlen(name)); + } + /* FALL THROUGH */ + case A_EXPR: + arg_free(arg[i].arg_ptr.arg_arg); + arg[i].arg_ptr.arg_arg = Nullarg; + break; + case A_CMD: + cmd_free(arg[i].arg_ptr.arg_cmd); + arg[i].arg_ptr.arg_cmd = Nullcmd; + break; + case A_WORD: + case A_STAB: + case A_LVAL: + case A_READ: + case A_GLOB: + case A_ARYLEN: + case A_LARYLEN: + case A_ARYSTAB: + case A_LARYSTAB: + break; + case A_SINGLE: + case A_DOUBLE: + case A_BACKTICK: + str_free(arg[i].arg_ptr.arg_str); + arg[i].arg_ptr.arg_str = Nullstr; + break; + case A_SPAT: + spat_free(arg[i].arg_ptr.arg_spat); + arg[i].arg_ptr.arg_spat = Nullspat; + break; + } + } + free_arg(arg); +} + +void +spat_free(spat) +register SPAT *spat; +{ + register SPAT *sp; + HENT *entry; + + if (!spat) + return; + if (spat->spat_runtime) { + arg_free(spat->spat_runtime); + spat->spat_runtime = Nullarg; + } + if (spat->spat_repl) { + arg_free(spat->spat_repl); + spat->spat_repl = Nullarg; + } + if (spat->spat_short) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; + } + if (spat->spat_regexp) { + regfree(spat->spat_regexp); + spat->spat_regexp = Null(REGEXP*); + } + + /* now unlink from spat list */ + + for (entry = defstash->tbl_array['_']; entry; entry = entry->hent_next) { + register HASH *stash; + STAB *stab = (STAB*)entry->hent_val; + + if (!stab) + continue; + stash = stab_hash(stab); + if (!stash || stash->tbl_spatroot == Null(SPAT*)) + continue; + if (stash->tbl_spatroot == spat) + stash->tbl_spatroot = spat->spat_next; + else { + for (sp = stash->tbl_spatroot; + sp && sp->spat_next != spat; + sp = sp->spat_next) + /*SUPPRESS 530*/ + ; + if (sp) + sp->spat_next = spat->spat_next; + } + } + Safefree(spat); +} + +/* Recursively descend a command sequence and push the address of any string + * that needs saving on recursion onto the tosave array. + */ + +static int +cmd_tosave(cmd,willsave) +register CMD *cmd; +int willsave; /* willsave passes down the tree */ +{ + register CMD *head = cmd; + int shouldsave = FALSE; /* shouldsave passes up the tree */ + int tmpsave; + register CMD *lastcmd = Nullcmd; + + while (cmd) { + if (cmd->c_expr) + shouldsave |= arg_tosave(cmd->c_expr,willsave); + switch (cmd->c_type) { + case C_WHILE: + if (cmd->ucmd.ccmd.cc_true) { + tmpsave = cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave); + + /* Here we check to see if the temporary array generated for + * a foreach needs to be localized because of recursion. + */ + if (tmpsave && (cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY) { + if (lastcmd && + lastcmd->c_type == C_EXPR && + lastcmd->c_expr) { + ARG *arg = lastcmd->c_expr; + + if (arg->arg_type == O_ASSIGN && + arg[1].arg_type == A_LEXPR && + arg[1].arg_ptr.arg_arg->arg_type == O_LARRAY && + strnEQ("_GEN_", + stab_name( + arg[1].arg_ptr.arg_arg[1].arg_ptr.arg_stab), + 5)) { /* array generated for foreach */ + (void)localize(arg); + } + } + + /* in any event, save the iterator */ + + if (cmd->c_short) /* Better safe than sorry */ + (void)apush(tosave,cmd->c_short); + } + shouldsave |= tmpsave; + } + break; + case C_BLOCK: + case C_ELSE: + case C_IF: + if (cmd->ucmd.ccmd.cc_true) + shouldsave |= cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave); + break; + case C_EXPR: + if (cmd->ucmd.acmd.ac_expr) + shouldsave |= arg_tosave(cmd->ucmd.acmd.ac_expr,willsave); + break; + } + lastcmd = cmd; + cmd = cmd->c_next; + if (cmd && cmd == head) /* reached end of while loop */ + break; + } + return shouldsave; +} + +static int +arg_tosave(arg,willsave) +register ARG *arg; +int willsave; +{ + register int i; + int shouldsave = FALSE; + + for (i = arg->arg_len; i >= 1; i--) { + switch (arg[i].arg_type & A_MASK) { + case A_NULL: + break; + case A_LEXPR: + case A_EXPR: + shouldsave |= arg_tosave(arg[i].arg_ptr.arg_arg,shouldsave); + break; + case A_CMD: + shouldsave |= cmd_tosave(arg[i].arg_ptr.arg_cmd,shouldsave); + break; + case A_WORD: + case A_STAB: + case A_LVAL: + case A_READ: + case A_GLOB: + case A_ARYLEN: + case A_SINGLE: + case A_DOUBLE: + case A_BACKTICK: + break; + case A_SPAT: + shouldsave |= spat_tosave(arg[i].arg_ptr.arg_spat); + break; + } + } + switch (arg->arg_type) { + case O_RETURN: + saw_return = TRUE; + break; + case O_EVAL: + case O_SUBR: + shouldsave = TRUE; + break; + } + if (willsave && arg->arg_ptr.arg_str) + (void)apush(tosave,arg->arg_ptr.arg_str); + return shouldsave; +} + +static int +spat_tosave(spat) +register SPAT *spat; +{ + int shouldsave = FALSE; + + if (spat->spat_runtime) + shouldsave |= arg_tosave(spat->spat_runtime,FALSE); + if (spat->spat_repl) { + shouldsave |= arg_tosave(spat->spat_repl,FALSE); + } + + return shouldsave; +} + diff --git a/gnu/usr.bin/perl/perl/consarg.c b/gnu/usr.bin/perl/perl/consarg.c new file mode 100644 index 0000000..2c28afb --- /dev/null +++ b/gnu/usr.bin/perl/perl/consarg.c @@ -0,0 +1,1292 @@ +/* $RCSfile: consarg.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:35 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: consarg.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:35 nate + * PERL! + * + * Revision 4.0.1.4 92/06/08 12:26:27 lwall + * patch20: new warning for use of x with non-numeric right operand + * patch20: modulus with highest bit in left operand set didn't always work + * patch20: illegal lvalue message could be followed by core dump + * patch20: deleted some minor memory leaks + * + * Revision 4.0.1.3 91/11/05 16:21:16 lwall + * patch11: random cleanup + * patch11: added eval {} + * patch11: added sort {} LIST + * patch11: "foo" x -1 dumped core + * patch11: substr() and vec() weren't allowed in an lvalue list + * + * Revision 4.0.1.2 91/06/07 10:33:12 lwall + * patch4: new copyright notice + * patch4: length($`), length($&), length($') now optimized to avoid string copy + * + * Revision 4.0.1.1 91/04/11 17:38:34 lwall + * patch1: fixed "Bad free" error + * + * Revision 4.0 91/03/20 01:06:15 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" +static int nothing_in_common(); +static int arg_common(); +static int spat_common(); + +ARG * +make_split(stab,arg,limarg) +register STAB *stab; +register ARG *arg; +ARG *limarg; +{ + register SPAT *spat; + + if (arg->arg_type != O_MATCH) { + Newz(201,spat,1,SPAT); + spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ + curstash->tbl_spatroot = spat; + + spat->spat_runtime = arg; + arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat); + } + Renew(arg,4,ARG); + arg->arg_len = 3; + if (limarg) { + if (limarg->arg_type == O_ITEM) { + Copy(limarg+1,arg+3,1,ARG); + limarg[1].arg_type = A_NULL; + arg_free(limarg); + } + else { + arg[3].arg_flags = 0; + arg[3].arg_len = 0; + arg[3].arg_type = A_EXPR; + arg[3].arg_ptr.arg_arg = limarg; + } + } + else { + arg[3].arg_flags = 0; + arg[3].arg_len = 0; + arg[3].arg_type = A_NULL; + arg[3].arg_ptr.arg_arg = Nullarg; + } + arg->arg_type = O_SPLIT; + spat = arg[2].arg_ptr.arg_spat; + spat->spat_repl = stab2arg(A_STAB,aadd(stab)); + if (spat->spat_short) { /* exact match can bypass regexec() */ + if (!((spat->spat_flags & SPAT_SCANFIRST) && + (spat->spat_flags & SPAT_ALL) )) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; + } + } + return arg; +} + +ARG * +mod_match(type,left,pat) +register ARG *left; +register ARG *pat; +{ + + register SPAT *spat; + register ARG *newarg; + + if (!pat) + return Nullarg; + + if ((pat->arg_type == O_MATCH || + pat->arg_type == O_SUBST || + pat->arg_type == O_TRANS || + pat->arg_type == O_SPLIT + ) && + pat[1].arg_ptr.arg_stab == defstab ) { + switch (pat->arg_type) { + case O_MATCH: + newarg = make_op(type == O_MATCH ? O_MATCH : O_NMATCH, + pat->arg_len, + left,Nullarg,Nullarg); + break; + case O_SUBST: + newarg = l(make_op(type == O_MATCH ? O_SUBST : O_NSUBST, + pat->arg_len, + left,Nullarg,Nullarg)); + break; + case O_TRANS: + newarg = l(make_op(type == O_MATCH ? O_TRANS : O_NTRANS, + pat->arg_len, + left,Nullarg,Nullarg)); + break; + case O_SPLIT: + newarg = make_op(type == O_MATCH ? O_SPLIT : O_SPLIT, + pat->arg_len, + left,Nullarg,Nullarg); + break; + } + if (pat->arg_len >= 2) { + newarg[2].arg_type = pat[2].arg_type; + newarg[2].arg_ptr = pat[2].arg_ptr; + newarg[2].arg_len = pat[2].arg_len; + newarg[2].arg_flags = pat[2].arg_flags; + if (pat->arg_len >= 3) { + newarg[3].arg_type = pat[3].arg_type; + newarg[3].arg_ptr = pat[3].arg_ptr; + newarg[3].arg_len = pat[3].arg_len; + newarg[3].arg_flags = pat[3].arg_flags; + } + } + free_arg(pat); + } + else { + Newz(202,spat,1,SPAT); + spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ + curstash->tbl_spatroot = spat; + + spat->spat_runtime = pat; + newarg = make_op(type,2,left,Nullarg,Nullarg); + newarg[2].arg_type = A_SPAT | A_DONT; + newarg[2].arg_ptr.arg_spat = spat; + } + + return newarg; +} + +ARG * +make_op(type,newlen,arg1,arg2,arg3) +int type; +int newlen; +ARG *arg1; +ARG *arg2; +ARG *arg3; +{ + register ARG *arg; + register ARG *chld; + register unsigned doarg; + register int i; + extern ARG *arg4; /* should be normal arguments, really */ + extern ARG *arg5; + + arg = op_new(newlen); + arg->arg_type = type; + /*SUPPRESS 560*/ + if (chld = arg1) { + if (chld->arg_type == O_ITEM && + (hoistable[ i = (chld[1].arg_type&A_MASK)] || i == A_LVAL || + (i == A_LEXPR && + (chld[1].arg_ptr.arg_arg->arg_type == O_LIST || + chld[1].arg_ptr.arg_arg->arg_type == O_ARRAY || + chld[1].arg_ptr.arg_arg->arg_type == O_HASH )))) + { + arg[1].arg_type = chld[1].arg_type; + arg[1].arg_ptr = chld[1].arg_ptr; + arg[1].arg_flags |= chld[1].arg_flags; + arg[1].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[1].arg_type = A_EXPR; + arg[1].arg_ptr.arg_arg = chld; + } + } + /*SUPPRESS 560*/ + if (chld = arg2) { + if (chld->arg_type == O_ITEM && + (hoistable[chld[1].arg_type&A_MASK] || + (type == O_ASSIGN && + ((chld[1].arg_type == A_READ && !(arg[1].arg_type & A_DONT)) + || + (chld[1].arg_type == A_INDREAD && !(arg[1].arg_type & A_DONT)) + || + (chld[1].arg_type == A_GLOB && !(arg[1].arg_type & A_DONT)) + ) ) ) ) { + arg[2].arg_type = chld[1].arg_type; + arg[2].arg_ptr = chld[1].arg_ptr; + arg[2].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[2].arg_type = A_EXPR; + arg[2].arg_ptr.arg_arg = chld; + } + } + /*SUPPRESS 560*/ + if (chld = arg3) { + if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) { + arg[3].arg_type = chld[1].arg_type; + arg[3].arg_ptr = chld[1].arg_ptr; + arg[3].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[3].arg_type = A_EXPR; + arg[3].arg_ptr.arg_arg = chld; + } + } + if (newlen >= 4 && (chld = arg4)) { + if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) { + arg[4].arg_type = chld[1].arg_type; + arg[4].arg_ptr = chld[1].arg_ptr; + arg[4].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[4].arg_type = A_EXPR; + arg[4].arg_ptr.arg_arg = chld; + } + } + if (newlen >= 5 && (chld = arg5)) { + if (chld->arg_type == O_ITEM && hoistable[chld[1].arg_type&A_MASK]) { + arg[5].arg_type = chld[1].arg_type; + arg[5].arg_ptr = chld[1].arg_ptr; + arg[5].arg_len = chld[1].arg_len; + free_arg(chld); + } + else { + arg[5].arg_type = A_EXPR; + arg[5].arg_ptr.arg_arg = chld; + } + } + doarg = opargs[type]; + for (i = 1; i <= newlen; ++i) { + if (!(doarg & 1)) + arg[i].arg_type |= A_DONT; + if (doarg & 2) + arg[i].arg_flags |= AF_ARYOK; + doarg >>= 2; + } +#ifdef DEBUGGING + if (debug & 16) { + fprintf(stderr,"%lx <= make_op(%s",arg,opname[arg->arg_type]); + if (arg1) + fprintf(stderr,",%s=%lx", + argname[arg[1].arg_type&A_MASK],arg[1].arg_ptr.arg_arg); + if (arg2) + fprintf(stderr,",%s=%lx", + argname[arg[2].arg_type&A_MASK],arg[2].arg_ptr.arg_arg); + if (arg3) + fprintf(stderr,",%s=%lx", + argname[arg[3].arg_type&A_MASK],arg[3].arg_ptr.arg_arg); + if (newlen >= 4) + fprintf(stderr,",%s=%lx", + argname[arg[4].arg_type&A_MASK],arg[4].arg_ptr.arg_arg); + if (newlen >= 5) + fprintf(stderr,",%s=%lx", + argname[arg[5].arg_type&A_MASK],arg[5].arg_ptr.arg_arg); + fprintf(stderr,")\n"); + } +#endif + arg = evalstatic(arg); /* see if we can consolidate anything */ + return arg; +} + +ARG * +evalstatic(arg) +register ARG *arg; +{ + static STR *str = Nullstr; + register STR *s1; + register STR *s2; + double value; /* must not be register */ + register char *tmps; + int i; + unsigned long tmplong; + long tmp2; + double exp(), log(), sqrt(), modf(); + char *crypt(); + double sin(), cos(), atan2(), pow(); + + if (!arg || !arg->arg_len) + return arg; + + if (!str) + str = Str_new(20,0); + + if (arg[1].arg_type == A_SINGLE) + s1 = arg[1].arg_ptr.arg_str; + else + s1 = Nullstr; + if (arg->arg_len >= 2 && arg[2].arg_type == A_SINGLE) + s2 = arg[2].arg_ptr.arg_str; + else + s2 = Nullstr; + +#define CHECK1 if (!s1) return arg +#define CHECK2 if (!s2) return arg +#define CHECK12 if (!s1 || !s2) return arg + + switch (arg->arg_type) { + default: + return arg; + case O_SORT: + if (arg[1].arg_type == A_CMD) + arg[1].arg_type |= A_DONT; + return arg; + case O_EVAL: + if (arg[1].arg_type == A_CMD) { + arg->arg_type = O_TRY; + arg[1].arg_type |= A_DONT; + return arg; + } + CHECK1; + arg->arg_type = O_EVALONCE; + return arg; + case O_AELEM: + CHECK2; + i = (int)str_gnum(s2); + if (i < 32767 && i >= 0) { + arg->arg_type = O_ITEM; + arg->arg_len = 1; + arg[1].arg_type = A_ARYSTAB; /* $abc[123] is hoistable now */ + arg[1].arg_len = i; + str_free(s2); + Renew(arg, 2, ARG); + } + return arg; + case O_CONCAT: + CHECK12; + str_sset(str,s1); + str_scat(str,s2); + break; + case O_REPEAT: + CHECK2; + if (dowarn && !s2->str_nok && !looks_like_number(s2)) + warn("Right operand of x is not numeric"); + CHECK1; + i = (int)str_gnum(s2); + tmps = str_get(s1); + str_nset(str,"",0); + if (i > 0) { + STR_GROW(str, i * s1->str_cur + 1); + repeatcpy(str->str_ptr, tmps, s1->str_cur, i); + str->str_cur = i * s1->str_cur; + str->str_ptr[str->str_cur] = '\0'; + } + break; + case O_MULTIPLY: + CHECK12; + value = str_gnum(s1); + str_numset(str,value * str_gnum(s2)); + break; + case O_DIVIDE: + CHECK12; + value = str_gnum(s2); + if (value == 0.0) + yyerror("Illegal division by constant zero"); + else +#ifdef SLOPPYDIVIDE + /* insure that 20./5. == 4. */ + { + double x; + int k; + x = str_gnum(s1); + if ((double)(int)x == x && + (double)(int)value == value && + (k = (int)x/(int)value)*(int)value == (int)x) { + value = k; + } else { + value = x/value; + } + str_numset(str,value); + } +#else + str_numset(str,str_gnum(s1) / value); +#endif + break; + case O_MODULO: + CHECK12; + tmplong = (unsigned long)str_gnum(s2); + if (tmplong == 0L) { + yyerror("Illegal modulus of constant zero"); + return arg; + } + value = str_gnum(s1); +#ifndef lint + if (value >= 0.0) + str_numset(str,(double)(((unsigned long)value) % tmplong)); + else { + tmp2 = (long)value; + str_numset(str,(double)((tmplong-((-tmp2 - 1) % tmplong)) - 1)); + } +#else + tmp2 = tmp2; +#endif + break; + case O_ADD: + CHECK12; + value = str_gnum(s1); + str_numset(str,value + str_gnum(s2)); + break; + case O_SUBTRACT: + CHECK12; + value = str_gnum(s1); + str_numset(str,value - str_gnum(s2)); + break; + case O_LEFT_SHIFT: + CHECK12; + value = str_gnum(s1); + i = (int)str_gnum(s2); +#ifndef lint + str_numset(str,(double)(((long)value) << i)); +#endif + break; + case O_RIGHT_SHIFT: + CHECK12; + value = str_gnum(s1); + i = (int)str_gnum(s2); +#ifndef lint + str_numset(str,(double)(((long)value) >> i)); +#endif + break; + case O_LT: + CHECK12; + value = str_gnum(s1); + str_numset(str,(value < str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_GT: + CHECK12; + value = str_gnum(s1); + str_numset(str,(value > str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_LE: + CHECK12; + value = str_gnum(s1); + str_numset(str,(value <= str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_GE: + CHECK12; + value = str_gnum(s1); + str_numset(str,(value >= str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_EQ: + CHECK12; + if (dowarn) { + if ((!s1->str_nok && !looks_like_number(s1)) || + (!s2->str_nok && !looks_like_number(s2)) ) + warn("Possible use of == on string value"); + } + value = str_gnum(s1); + str_numset(str,(value == str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_NE: + CHECK12; + value = str_gnum(s1); + str_numset(str,(value != str_gnum(s2)) ? 1.0 : 0.0); + break; + case O_NCMP: + CHECK12; + value = str_gnum(s1); + value -= str_gnum(s2); + if (value > 0.0) + value = 1.0; + else if (value < 0.0) + value = -1.0; + str_numset(str,value); + break; + case O_BIT_AND: + CHECK12; + value = str_gnum(s1); +#ifndef lint + str_numset(str,(double)(U_L(value) & U_L(str_gnum(s2)))); +#endif + break; + case O_XOR: + CHECK12; + value = str_gnum(s1); +#ifndef lint + str_numset(str,(double)(U_L(value) ^ U_L(str_gnum(s2)))); +#endif + break; + case O_BIT_OR: + CHECK12; + value = str_gnum(s1); +#ifndef lint + str_numset(str,(double)(U_L(value) | U_L(str_gnum(s2)))); +#endif + break; + case O_AND: + CHECK12; + if (str_true(s1)) + str_sset(str,s2); + else + str_sset(str,s1); + break; + case O_OR: + CHECK12; + if (str_true(s1)) + str_sset(str,s1); + else + str_sset(str,s2); + break; + case O_COND_EXPR: + CHECK12; + if ((arg[3].arg_type & A_MASK) != A_SINGLE) + return arg; + if (str_true(s1)) + str_sset(str,s2); + else + str_sset(str,arg[3].arg_ptr.arg_str); + str_free(arg[3].arg_ptr.arg_str); + Renew(arg, 3, ARG); + break; + case O_NEGATE: + CHECK1; + str_numset(str,(double)(-str_gnum(s1))); + break; + case O_NOT: + CHECK1; +#ifdef NOTNOT + { char xxx = str_true(s1); str_numset(str,(double)!xxx); } +#else + str_numset(str,(double)(!str_true(s1))); +#endif + break; + case O_COMPLEMENT: + CHECK1; +#ifndef lint + str_numset(str,(double)(~U_L(str_gnum(s1)))); +#endif + break; + case O_SIN: + CHECK1; + str_numset(str,sin(str_gnum(s1))); + break; + case O_COS: + CHECK1; + str_numset(str,cos(str_gnum(s1))); + break; + case O_ATAN2: + CHECK12; + value = str_gnum(s1); + str_numset(str,atan2(value, str_gnum(s2))); + break; + case O_POW: + CHECK12; + value = str_gnum(s1); + str_numset(str,pow(value, str_gnum(s2))); + break; + case O_LENGTH: + if (arg[1].arg_type == A_STAB) { + arg->arg_type = O_ITEM; + arg[1].arg_type = A_LENSTAB; + return arg; + } + CHECK1; + str_numset(str, (double)str_len(s1)); + break; + case O_SLT: + CHECK12; + str_numset(str,(double)(str_cmp(s1,s2) < 0)); + break; + case O_SGT: + CHECK12; + str_numset(str,(double)(str_cmp(s1,s2) > 0)); + break; + case O_SLE: + CHECK12; + str_numset(str,(double)(str_cmp(s1,s2) <= 0)); + break; + case O_SGE: + CHECK12; + str_numset(str,(double)(str_cmp(s1,s2) >= 0)); + break; + case O_SEQ: + CHECK12; + str_numset(str,(double)(str_eq(s1,s2))); + break; + case O_SNE: + CHECK12; + str_numset(str,(double)(!str_eq(s1,s2))); + break; + case O_SCMP: + CHECK12; + str_numset(str,(double)(str_cmp(s1,s2))); + break; + case O_CRYPT: + CHECK12; +#ifdef HAS_CRYPT + tmps = str_get(s1); + str_set(str,crypt(tmps,str_get(s2))); +#else + yyerror( + "The crypt() function is unimplemented due to excessive paranoia."); +#endif + break; + case O_EXP: + CHECK1; + str_numset(str,exp(str_gnum(s1))); + break; + case O_LOG: + CHECK1; + str_numset(str,log(str_gnum(s1))); + break; + case O_SQRT: + CHECK1; + str_numset(str,sqrt(str_gnum(s1))); + break; + case O_INT: + CHECK1; + value = str_gnum(s1); + if (value >= 0.0) + (void)modf(value,&value); + else { + (void)modf(-value,&value); + value = -value; + } + str_numset(str,value); + break; + case O_ORD: + CHECK1; +#ifndef I286 + str_numset(str,(double)(*str_get(s1))); +#else + { + int zapc; + char *zaps; + + zaps = str_get(s1); + zapc = (int) *zaps; + str_numset(str,(double)(zapc)); + } +#endif + break; + } + arg->arg_type = O_ITEM; /* note arg1 type is already SINGLE */ + str_free(s1); + arg[1].arg_ptr.arg_str = str; + if (s2) { + str_free(s2); + arg[2].arg_ptr.arg_str = Nullstr; + arg[2].arg_type = A_NULL; + } + str = Nullstr; + + return arg; +} + +ARG * +l(arg) +register ARG *arg; +{ + register int i; + register ARG *arg1; + register ARG *arg2; + SPAT *spat; + int arghog = 0; + + i = arg[1].arg_type & A_MASK; + + arg->arg_flags |= AF_COMMON; /* assume something in common */ + /* which forces us to copy things */ + + if (i == A_ARYLEN) { + arg[1].arg_type = A_LARYLEN; + return arg; + } + if (i == A_ARYSTAB) { + arg[1].arg_type = A_LARYSTAB; + return arg; + } + + /* see if it's an array reference */ + + if (i == A_EXPR || i == A_LEXPR) { + arg1 = arg[1].arg_ptr.arg_arg; + + if (arg1->arg_type == O_LIST || arg1->arg_type == O_ITEM) { + /* assign to list */ + if (arg->arg_len > 1) { + dehoist(arg,2); + arg2 = arg[2].arg_ptr.arg_arg; + if (nothing_in_common(arg1,arg2)) + arg->arg_flags &= ~AF_COMMON; + if (arg->arg_type == O_ASSIGN) { + if (arg1->arg_flags & AF_LOCAL) + arg->arg_flags |= AF_LOCAL; + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + else if (arg->arg_type != O_CHOP) + arg->arg_type = O_ASSIGN; /* possible local(); */ + for (i = arg1->arg_len; i >= 1; i--) { + switch (arg1[i].arg_type) { + case A_STAR: case A_LSTAR: + arg1[i].arg_type = A_LSTAR; + break; + case A_STAB: case A_LVAL: + arg1[i].arg_type = A_LVAL; + break; + case A_ARYLEN: case A_LARYLEN: + arg1[i].arg_type = A_LARYLEN; + break; + case A_ARYSTAB: case A_LARYSTAB: + arg1[i].arg_type = A_LARYSTAB; + break; + case A_EXPR: case A_LEXPR: + arg1[i].arg_type = A_LEXPR; + switch(arg1[i].arg_ptr.arg_arg->arg_type) { + case O_ARRAY: case O_LARRAY: + arg1[i].arg_ptr.arg_arg->arg_type = O_LARRAY; + arghog = 1; + break; + case O_AELEM: case O_LAELEM: + arg1[i].arg_ptr.arg_arg->arg_type = O_LAELEM; + break; + case O_HASH: case O_LHASH: + arg1[i].arg_ptr.arg_arg->arg_type = O_LHASH; + arghog = 1; + break; + case O_HELEM: case O_LHELEM: + arg1[i].arg_ptr.arg_arg->arg_type = O_LHELEM; + break; + case O_ASLICE: case O_LASLICE: + arg1[i].arg_ptr.arg_arg->arg_type = O_LASLICE; + break; + case O_HSLICE: case O_LHSLICE: + arg1[i].arg_ptr.arg_arg->arg_type = O_LHSLICE; + break; + case O_SUBSTR: case O_VEC: + (void)l(arg1[i].arg_ptr.arg_arg); + Renewc(arg1[i].arg_ptr.arg_arg->arg_ptr.arg_str, 1, + struct lstring, STR); + /* grow string struct to hold an lstring struct */ + break; + default: + goto ill_item; + } + break; + default: + ill_item: + (void)sprintf(tokenbuf, "Illegal item (%s) as lvalue", + argname[arg1[i].arg_type&A_MASK]); + yyerror(tokenbuf); + } + } + if (arg->arg_len > 1) { + if (arg2->arg_type == O_SPLIT && !arg2[3].arg_type && !arghog) { + arg2[3].arg_type = A_SINGLE; + arg2[3].arg_ptr.arg_str = + str_nmake((double)arg1->arg_len + 1); /* limit split len*/ + } + } + } + else if (arg1->arg_type == O_AELEM || arg1->arg_type == O_LAELEM) + if (arg->arg_type == O_DEFINED) + arg1->arg_type = O_AELEM; + else + arg1->arg_type = O_LAELEM; + else if (arg1->arg_type == O_ARRAY || arg1->arg_type == O_LARRAY) { + arg1->arg_type = O_LARRAY; + if (arg->arg_len > 1) { + dehoist(arg,2); + arg2 = arg[2].arg_ptr.arg_arg; + if (arg2->arg_type == O_SPLIT) { /* use split's builtin =?*/ + spat = arg2[2].arg_ptr.arg_spat; + if (!(spat->spat_flags & SPAT_ONCE) && + nothing_in_common(arg1,spat->spat_repl)) { + spat->spat_repl[1].arg_ptr.arg_stab = + arg1[1].arg_ptr.arg_stab; + arg1[1].arg_ptr.arg_stab = Nullstab; + spat->spat_flags |= SPAT_ONCE; + arg_free(arg1); /* recursive */ + arg[1].arg_ptr.arg_arg = Nullarg; + free_arg(arg); /* non-recursive */ + return arg2; /* split has builtin assign */ + } + } + else if (nothing_in_common(arg1,arg2)) + arg->arg_flags &= ~AF_COMMON; + if (arg->arg_type == O_ASSIGN) { + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + else if (arg->arg_type == O_ASSIGN) + arg[1].arg_flags |= AF_ARYOK; + } + else if (arg1->arg_type == O_HELEM || arg1->arg_type == O_LHELEM) + if (arg->arg_type == O_DEFINED) + arg1->arg_type = O_HELEM; /* avoid creating one */ + else + arg1->arg_type = O_LHELEM; + else if (arg1->arg_type == O_HASH || arg1->arg_type == O_LHASH) { + arg1->arg_type = O_LHASH; + if (arg->arg_len > 1) { + dehoist(arg,2); + arg2 = arg[2].arg_ptr.arg_arg; + if (nothing_in_common(arg1,arg2)) + arg->arg_flags &= ~AF_COMMON; + if (arg->arg_type == O_ASSIGN) { + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + else if (arg->arg_type == O_ASSIGN) + arg[1].arg_flags |= AF_ARYOK; + } + else if (arg1->arg_type == O_ASLICE) { + arg1->arg_type = O_LASLICE; + if (arg->arg_type == O_ASSIGN) { + dehoist(arg,2); + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + else if (arg1->arg_type == O_HSLICE) { + arg1->arg_type = O_LHSLICE; + if (arg->arg_type == O_ASSIGN) { + dehoist(arg,2); + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + } + } + else if ((arg->arg_type == O_DEFINED || arg->arg_type == O_UNDEF) && + (arg1->arg_type == (perldb ? O_DBSUBR : O_SUBR)) ) { + arg[1].arg_type |= A_DONT; + } + else if (arg1->arg_type == O_SUBSTR || arg1->arg_type == O_VEC) { + (void)l(arg1); + Renewc(arg1->arg_ptr.arg_str, 1, struct lstring, STR); + /* grow string struct to hold an lstring struct */ + } + else if (arg1->arg_type == O_ASSIGN) + /*SUPPRESS 530*/ + ; + else { + (void)sprintf(tokenbuf, + "Illegal expression (%s) as lvalue",opname[arg1->arg_type]); + yyerror(tokenbuf); + return arg; + } + arg[1].arg_type = A_LEXPR | (arg[1].arg_type & A_DONT); + if (arg->arg_type == O_ASSIGN && (arg1[1].arg_flags & AF_ARYOK)) { + arg[1].arg_flags |= AF_ARYOK; + if (arg->arg_len > 1) + arg[2].arg_flags |= AF_ARYOK; + } +#ifdef DEBUGGING + if (debug & 16) + fprintf(stderr,"lval LEXPR\n"); +#endif + return arg; + } + if (i == A_STAR || i == A_LSTAR) { + arg[1].arg_type = A_LSTAR | (arg[1].arg_type & A_DONT); + return arg; + } + + /* not an array reference, should be a register name */ + + if (i != A_STAB && i != A_LVAL) { + (void)sprintf(tokenbuf, + "Illegal item (%s) as lvalue",argname[arg[1].arg_type&A_MASK]); + yyerror(tokenbuf); + return arg; + } + arg[1].arg_type = A_LVAL | (arg[1].arg_type & A_DONT); +#ifdef DEBUGGING + if (debug & 16) + fprintf(stderr,"lval LVAL\n"); +#endif + return arg; +} + +ARG * +fixl(type,arg) +int type; +ARG *arg; +{ + if (type == O_DEFINED || type == O_UNDEF) { + if (arg->arg_type != O_ITEM) + arg = hide_ary(arg); + if (arg->arg_type == O_ITEM) { + type = arg[1].arg_type & A_MASK; + if (type == A_EXPR || type == A_LEXPR) + arg[1].arg_type = A_LEXPR|A_DONT; + } + } + return arg; +} + +void +dehoist(arg,i) +ARG *arg; +{ + ARG *tmparg; + + if (arg[i].arg_type != A_EXPR) { /* dehoist */ + tmparg = make_op(O_ITEM,1,Nullarg,Nullarg,Nullarg); + tmparg[1] = arg[i]; + arg[i].arg_ptr.arg_arg = tmparg; + arg[i].arg_type = A_EXPR; + } +} + +ARG * +addflags(i,flags,arg) +register ARG *arg; +{ + arg[i].arg_flags |= flags; + return arg; +} + +ARG * +hide_ary(arg) +ARG *arg; +{ + if (arg->arg_type == O_ARRAY || arg->arg_type == O_HASH) + return make_op(O_ITEM,1,arg,Nullarg,Nullarg); + return arg; +} + +/* maybe do a join on multiple array dimensions */ + +ARG * +jmaybe(arg) +register ARG *arg; +{ + if (arg && arg->arg_type == O_COMMA) { + arg = listish(arg); + arg = make_op(O_JOIN, 2, + stab2arg(A_STAB,stabent(";",TRUE)), + make_list(arg), + Nullarg); + } + return arg; +} + +ARG * +make_list(arg) +register ARG *arg; +{ + register int i; + register ARG *node; + register ARG *nxtnode; + register int j; + STR *tmpstr; + + if (!arg) { + arg = op_new(0); + arg->arg_type = O_LIST; + } + if (arg->arg_type != O_COMMA) { + if (arg->arg_type != O_ARRAY) + arg->arg_flags |= AF_LISTISH; /* see listish() below */ + arg->arg_flags |= AF_LISTISH; /* see listish() below */ + return arg; + } + for (i = 2, node = arg; ; i++) { + if (node->arg_len < 2) + break; + if (node[1].arg_type != A_EXPR) + break; + node = node[1].arg_ptr.arg_arg; + if (node->arg_type != O_COMMA) + break; + } + if (i > 2) { + node = arg; + arg = op_new(i); + tmpstr = arg->arg_ptr.arg_str; + StructCopy(node, arg, ARG); /* copy everything except the STR */ + arg->arg_ptr.arg_str = tmpstr; + for (j = i; ; ) { + StructCopy(node+2, arg+j, ARG); + arg[j].arg_flags |= AF_ARYOK; + --j; /* Bug in Xenix compiler */ + if (j < 2) { + StructCopy(node+1, arg+1, ARG); + free_arg(node); + break; + } + nxtnode = node[1].arg_ptr.arg_arg; + free_arg(node); + node = nxtnode; + } + } + arg[1].arg_flags |= AF_ARYOK; + arg[2].arg_flags |= AF_ARYOK; + arg->arg_type = O_LIST; + arg->arg_len = i; + str_free(arg->arg_ptr.arg_str); + arg->arg_ptr.arg_str = Nullstr; + return arg; +} + +/* turn a single item into a list */ + +ARG * +listish(arg) +ARG *arg; +{ + if (arg && arg->arg_flags & AF_LISTISH) + arg = make_op(O_LIST,1,arg,Nullarg,Nullarg); + return arg; +} + +ARG * +maybelistish(optype, arg) +int optype; +ARG *arg; +{ + ARG *tmparg = arg; + + if (optype == O_RETURN && arg->arg_type == O_ITEM && + arg[1].arg_type == A_EXPR && (tmparg = arg[1].arg_ptr.arg_arg) && + ((tmparg->arg_flags & AF_LISTISH) || (tmparg->arg_type == O_ARRAY) )) { + tmparg = listish(tmparg); + free_arg(arg); + arg = tmparg; + } + else if (optype == O_PRTF || + (arg->arg_type == O_ASLICE || arg->arg_type == O_HSLICE || + arg->arg_type == O_F_OR_R) ) + arg = listish(arg); + return arg; +} + +/* mark list of local variables */ + +ARG * +localize(arg) +ARG *arg; +{ + arg->arg_flags |= AF_LOCAL; + return arg; +} + +ARG * +rcatmaybe(arg) +ARG *arg; +{ + ARG *arg2; + + if (arg->arg_type == O_CONCAT && arg[2].arg_type == A_EXPR) { + arg2 = arg[2].arg_ptr.arg_arg; + if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) { + arg->arg_type = O_RCAT; + arg[2].arg_type = arg2[1].arg_type; + arg[2].arg_ptr = arg2[1].arg_ptr; + free_arg(arg2); + } + } + return arg; +} + +ARG * +stab2arg(atype,stab) +int atype; +register STAB *stab; +{ + register ARG *arg; + + arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = atype; + arg[1].arg_ptr.arg_stab = stab; + return arg; +} + +ARG * +cval_to_arg(cval) +register char *cval; +{ + register ARG *arg; + + arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = A_SINGLE; + arg[1].arg_ptr.arg_str = str_make(cval,0); + Safefree(cval); + return arg; +} + +ARG * +op_new(numargs) +int numargs; +{ + register ARG *arg; + + Newz(203,arg, numargs + 1, ARG); + arg->arg_ptr.arg_str = Str_new(21,0); + arg->arg_len = numargs; + return arg; +} + +void +free_arg(arg) +ARG *arg; +{ + str_free(arg->arg_ptr.arg_str); + Safefree(arg); +} + +ARG * +make_match(type,expr,spat) +int type; +ARG *expr; +SPAT *spat; +{ + register ARG *arg; + + arg = make_op(type,2,expr,Nullarg,Nullarg); + + arg[2].arg_type = A_SPAT|A_DONT; + arg[2].arg_ptr.arg_spat = spat; +#ifdef DEBUGGING + if (debug & 16) + fprintf(stderr,"make_match SPAT=%lx\n",(long)spat); +#endif + + if (type == O_SUBST || type == O_NSUBST) { + if (arg[1].arg_type != A_STAB) { + yyerror("Illegal lvalue"); + } + arg[1].arg_type = A_LVAL; + } + return arg; +} + +ARG * +cmd_to_arg(cmd) +CMD *cmd; +{ + register ARG *arg; + + arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = A_CMD; + arg[1].arg_ptr.arg_cmd = cmd; + return arg; +} + +/* Check two expressions to see if there is any identifier in common */ + +static int +nothing_in_common(arg1,arg2) +ARG *arg1; +ARG *arg2; +{ + static int thisexpr = 0; /* I don't care if this wraps */ + + thisexpr++; + if (arg_common(arg1,thisexpr,1)) + return 0; /* hit eval or do {} */ + stab_lastexpr(defstab) = thisexpr; /* pretend to hit @_ */ + if (arg_common(arg2,thisexpr,0)) + return 0; /* hit identifier again */ + return 1; +} + +/* Recursively descend an expression and mark any identifier or check + * it to see if it was marked already. + */ + +static int +arg_common(arg,exprnum,marking) +register ARG *arg; +int exprnum; +int marking; +{ + register int i; + + if (!arg) + return 0; + for (i = arg->arg_len; i >= 1; i--) { + switch (arg[i].arg_type & A_MASK) { + case A_NULL: + break; + case A_LEXPR: + case A_EXPR: + if (arg_common(arg[i].arg_ptr.arg_arg,exprnum,marking)) + return 1; + break; + case A_CMD: + return 1; /* assume hanky panky */ + case A_STAR: + case A_LSTAR: + case A_STAB: + case A_LVAL: + case A_ARYLEN: + case A_LARYLEN: + if (marking) + stab_lastexpr(arg[i].arg_ptr.arg_stab) = exprnum; + else if (stab_lastexpr(arg[i].arg_ptr.arg_stab) == exprnum) + return 1; + break; + case A_DOUBLE: + case A_BACKTICK: + { + register char *s = arg[i].arg_ptr.arg_str->str_ptr; + register char *send = s + arg[i].arg_ptr.arg_str->str_cur; + register STAB *stab; + + while (*s) { + if (*s == '$' && s[1]) { + s = scanident(s,send,tokenbuf); + stab = stabent(tokenbuf,TRUE); + if (marking) + stab_lastexpr(stab) = exprnum; + else if (stab_lastexpr(stab) == exprnum) + return 1; + continue; + } + else if (*s == '\\' && s[1]) + s++; + s++; + } + } + break; + case A_SPAT: + if (spat_common(arg[i].arg_ptr.arg_spat,exprnum,marking)) + return 1; + break; + case A_READ: + case A_INDREAD: + case A_GLOB: + case A_WORD: + case A_SINGLE: + break; + } + } + switch (arg->arg_type) { + case O_ARRAY: + case O_LARRAY: + if ((arg[1].arg_type & A_MASK) == A_STAB) + (void)aadd(arg[1].arg_ptr.arg_stab); + break; + case O_HASH: + case O_LHASH: + if ((arg[1].arg_type & A_MASK) == A_STAB) + (void)hadd(arg[1].arg_ptr.arg_stab); + break; + case O_EVAL: + case O_SUBR: + case O_DBSUBR: + return 1; + } + return 0; +} + +static int +spat_common(spat,exprnum,marking) +register SPAT *spat; +int exprnum; +int marking; +{ + if (spat->spat_runtime) + if (arg_common(spat->spat_runtime,exprnum,marking)) + return 1; + if (spat->spat_repl) { + if (arg_common(spat->spat_repl,exprnum,marking)) + return 1; + } + return 0; +} diff --git a/gnu/usr.bin/perl/perl/crypt.c b/gnu/usr.bin/perl/perl/crypt.c new file mode 100644 index 0000000..3299a86 --- /dev/null +++ b/gnu/usr.bin/perl/perl/crypt.c @@ -0,0 +1,200 @@ +/* + * Copyright (c) 1989 The Regents of the University of California. + * All rights reserved. + * + * This code is derived from software contributed to Berkeley by + * Tom Truscott. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the University of + * California, Berkeley and its contributors. + * 4. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#if defined(LIBC_SCCS) && !defined(lint) +/* from static char sccsid[] = "@(#)crypt.c 5.11 (Berkeley) 6/25/91"; */ +static char rcsid[] = "$Header: /home/cvs/386BSD/src/lib/libc/gen/crypt.c,v 1.6 1993/08/29 22:03:56 nate Exp $"; +#endif /* LIBC_SCCS and not lint */ + +#include +#include + +/* + * UNIX password, and DES, encryption. + * + * since this is non-exportable, this is just a dummy. if you want real + * encryption, make sure you've got libcrypt.a around. + */ + +#define SCRAMBLE /* Don't leave them in plaintext */ + +#ifndef SCRAMBLE +static char cryptresult[1+4+4+11+1]; /* "encrypted" result */ + +char * +crypt(key, setting) + register const char *key; + register const char *setting; +{ + fprintf(stderr, "WARNING! crypt(3) not present in the system!\n"); + strncpy(cryptresult, key, sizeof cryptresult); + cryptresult[sizeof cryptresult - 1] = '\0'; + return (cryptresult); +} + +#else + +char * +crypt(pw, salt) + register const char *pw; + register const char *salt; +{ + static char password[14]; + long matrix[128], *m, vector[2]; + char a, b, *p; + int i, value; + unsigned short crc; + unsigned long t; + + /* Ugly hack, but I'm too lazy to find the real problem - NW */ + bzero(matrix, 128 * sizeof(long)); + + if (salt[0]) { + a = salt[0]; + if (salt[1]) + b = salt[1]; + else + b = a; + } else + a = b = '0'; + password[0] = a; + password[1] = b; + if (a > 'Z') + a -= 6; + if (a > '9') + a -= 7; + if (b > 'Z') + b -= 6; + if (b > '9') + b -= 7; + a -= '.'; + b -= '.'; + value = (a | (b << 6)) & 07777; + + crc = value; + value += 1000; + b = 0; + p = (char *)pw; + while (value--) { + if (crc & 0x8000) + crc = (crc << 1) ^ 0x1021; + else + crc <<= 1; + if (!b) { + b = 8; + if (!(i = *p++)) { + p = (char *)pw; + i = *p++; + } + } + if (i & 0x80) + crc ^= 1; + i <<= 1; + b--; + } + + m = matrix; + matrix[0] = 0; + a = 32; + for (value = 07777; value >= 0; value--) { + *m <<= 1; + if (crc & 0x8000) { + *m |= 1; + crc = (crc << 1) ^ 0x1021; + } else + crc <<= 1; + if (!b) { + b = 8; + if (!(i = *p++)) { + p = (char *)pw; + i = *p++; + } + } + if (i & 0x80) + crc ^= 1; + i <<= 1; + b--; + if (!(a--)) { + a = 32; + *++m = 0; + } + } + + vector[0] = 0; + vector[1] = 0; + p = (char *) vector; + for (i = 0; i < 7; i++) + if (pw[i]) + *p++ = pw[i]; + else + break; + + p = password + 2; + a = 6; + m = matrix; + *p = 0; + for (i = 077; i >= 0; i--) { + t = *m++; + t = t ^ *m++; + t = t ^ vector[0]; + t = t ^ vector[1]; + b = 0; + while (t) { + if (t & 1) + b = 1 - b; + t >>= 1; + } + a--; + if (b) + *p |= 1 << a; + if (!a) { + a = 6; + *++p = 0; + } + } + + for (i = 2; i < 13; i++) { + password[i] += '.'; + if (password[i] > '9') + password[i] += 7; + if (password[i] > 'Z') + password[i] += 6; + } + password[13] = 0; + + return password; +} +#endif diff --git a/gnu/usr.bin/perl/perl/doarg.c b/gnu/usr.bin/perl/perl/doarg.c new file mode 100644 index 0000000..f36dd13 --- /dev/null +++ b/gnu/usr.bin/perl/perl/doarg.c @@ -0,0 +1,1849 @@ +/* $RCSfile: doarg.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:35 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: doarg.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:35 nate + * PERL! + * + * Revision 4.0.1.8 1993/02/05 19:32:27 lwall + * patch36: substitution didn't always invalidate numericity + * + * Revision 4.0.1.7 92/06/11 21:07:11 lwall + * patch34: join with null list attempted negative allocation + * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd " + * + * Revision 4.0.1.6 92/06/08 12:34:30 lwall + * patch20: removed implicit int declarations on funcions + * patch20: pattern modifiers i and o didn't interact right + * patch20: join() now pre-extends target string to avoid excessive copying + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly + * patch20: usersub routines didn't reclaim temp values soon enough + * patch20: ($<,$>) = ... didn't work on some architectures + * patch20: added Atari ST portability + * + * Revision 4.0.1.5 91/11/11 16:31:58 lwall + * patch19: added little-endian pack/unpack options + * + * Revision 4.0.1.4 91/11/05 16:35:06 lwall + * patch11: /$foo/o optimizer could access deallocated data + * patch11: minimum match length calculation in regexp is now cumulative + * patch11: added some support for 64-bit integers + * patch11: prepared for ctype implementations that don't define isascii() + * patch11: sprintf() now supports any length of s field + * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work + * patch11: defined(&$foo) and undef(&$foo) didn't work + * + * Revision 4.0.1.3 91/06/10 01:18:41 lwall + * patch10: pack(hh,1) dumped core + * + * Revision 4.0.1.2 91/06/07 10:42:17 lwall + * patch4: new copyright notice + * patch4: // wouldn't use previous pattern if it started with a null character + * patch4: //o and s///o now optimize themselves fully at runtime + * patch4: added global modifier for pattern matches + * patch4: undef @array disabled "@array" interpolation + * patch4: chop("") was returning "\0" rather than "" + * patch4: vector logical operations &, | and ^ sometimes returned null string + * patch4: syscall couldn't pass numbers with most significant bit set on sparcs + * + * Revision 4.0.1.1 91/04/11 17:40:14 lwall + * patch1: fixed undefined environ problem + * patch1: fixed debugger coredump on subroutines + * + * Revision 4.0 91/03/20 01:06:42 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +#include +#endif + +extern unsigned char fold[]; + +#ifdef BUGGY_MSC + #pragma function(memcmp) +#endif /* BUGGY_MSC */ + +static void doencodes(); + +int +do_subst(str,arg,sp) +STR *str; +ARG *arg; +int sp; +{ + register SPAT *spat; + SPAT *rspat; + register STR *dstr; + register char *s = str_get(str); + char *strend = s + str->str_cur; + register char *m; + char *c; + register char *d; + int clen; + int iters = 0; + int maxiters = (strend - s) + 10; + register int i; + bool once; + char *orig; + int safebase; + + rspat = spat = arg[2].arg_ptr.arg_spat; + if (!spat || !s) + fatal("panic: do_subst"); + else if (spat->spat_runtime) { + nointrp = "|)"; + (void)eval(spat->spat_runtime,G_SCALAR,sp); + m = str_get(dstr = stack->ary_array[sp+1]); + nointrp = ""; + if (spat->spat_regexp) { + regfree(spat->spat_regexp); + spat->spat_regexp = Null(REGEXP*); /* required if regcomp pukes */ + } + spat->spat_regexp = regcomp(m,m+dstr->str_cur, + spat->spat_flags & SPAT_FOLD); + if (spat->spat_flags & SPAT_KEEP) { + if (!(spat->spat_flags & SPAT_FOLD)) + scanconst(spat, m, dstr->str_cur); + arg_free(spat->spat_runtime); /* it won't change, so */ + spat->spat_runtime = Nullarg; /* no point compiling again */ + hoistmust(spat); + if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) { + curcmd->c_flags &= ~CF_OPTIMIZE; + opt_arg(curcmd, 1, curcmd->c_type == C_EXPR); + } + } + } +#ifdef DEBUGGING + if (debug & 8) { + deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); + } +#endif + safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) && + !sawampersand); + if (!spat->spat_regexp->prelen && lastspat) + spat = lastspat; + orig = m = s; + if (hint) { + if (hint < s || hint > strend) + fatal("panic: hint in do_match"); + s = hint; + hint = Nullch; + if (spat->spat_regexp->regback >= 0) { + s -= spat->spat_regexp->regback; + if (s < m) + s = m; + } + else + s = m; + } + else if (spat->spat_short) { + if (spat->spat_flags & SPAT_SCANFIRST) { + if (str->str_pok & SP_STUDIED) { + if (screamfirst[spat->spat_short->str_rare] < 0) + goto nope; + else if (!(s = screaminstr(str,spat->spat_short))) + goto nope; + } +#ifndef lint + else if (!(s = fbminstr((unsigned char*)s, (unsigned char*)strend, + spat->spat_short))) + goto nope; +#endif + if (s && spat->spat_regexp->regback >= 0) { + ++spat->spat_short->str_u.str_useful; + s -= spat->spat_regexp->regback; + if (s < m) + s = m; + } + else + s = m; + } + else if (!multiline && (*spat->spat_short->str_ptr != *s || + bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) )) + goto nope; + if (--spat->spat_short->str_u.str_useful < 0) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; /* opt is being useless */ + } + } + once = !(rspat->spat_flags & SPAT_GLOBAL); + if (rspat->spat_flags & SPAT_CONST) { /* known replacement string? */ + if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE) + dstr = rspat->spat_repl[1].arg_ptr.arg_str; + else { /* constant over loop, anyway */ + (void)eval(rspat->spat_repl,G_SCALAR,sp); + dstr = stack->ary_array[sp+1]; + } + c = str_get(dstr); + clen = dstr->str_cur; + if (clen <= spat->spat_regexp->minlen) { + /* can do inplace substitution */ + if (regexec(spat->spat_regexp, s, strend, orig, 0, + str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) { + if (spat->spat_regexp->subbase) /* oops, no we can't */ + goto long_way; + d = s; + lastspat = spat; + str->str_pok = SP_VALID; /* disable possible screamer */ + if (once) { + m = spat->spat_regexp->startp[0]; + d = spat->spat_regexp->endp[0]; + s = orig; + if (m - s > strend - d) { /* faster to shorten from end */ + if (clen) { + Copy(c, m, clen, char); + m += clen; + } + i = strend - d; + if (i > 0) { + Move(d, m, i, char); + m += i; + } + *m = '\0'; + str->str_cur = m - s; + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; + return sp; + } + /*SUPPRESS 560*/ + else if (i = m - s) { /* faster from front */ + d -= clen; + m = d; + str_chop(str,d-i); + s += i; + while (i--) + *--d = *--s; + if (clen) + Copy(c, m, clen, char); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; + return sp; + } + else if (clen) { + d -= clen; + str_chop(str,d); + Copy(c,d,clen,char); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; + return sp; + } + else { + str_chop(str,d); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; + return sp; + } + /* NOTREACHED */ + } + do { + if (iters++ > maxiters) + fatal("Substitution loop"); + m = spat->spat_regexp->startp[0]; + /*SUPPRESS 560*/ + if (i = m - s) { + if (s != d) + Move(s,d,i,char); + d += i; + } + if (clen) { + Copy(c,d,clen,char); + d += clen; + } + s = spat->spat_regexp->endp[0]; + } while (regexec(spat->spat_regexp, s, strend, orig, s == m, + Nullstr, TRUE)); /* (don't match same null twice) */ + if (s != d) { + i = strend - s; + str->str_cur = d - str->str_ptr + i; + Move(s,d,i+1,char); /* include the Null */ + } + STABSET(str); + str_numset(arg->arg_ptr.arg_str, (double)iters); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; + return sp; + } + str_numset(arg->arg_ptr.arg_str, 0.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + } + else + c = Nullch; + if (regexec(spat->spat_regexp, s, strend, orig, 0, + str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) { + long_way: + dstr = Str_new(25,str_len(str)); + str_nset(dstr,m,s-m); + if (spat->spat_regexp->subbase) + curspat = spat; + lastspat = spat; + do { + if (iters++ > maxiters) + fatal("Substitution loop"); + if (spat->spat_regexp->subbase + && spat->spat_regexp->subbase != orig) { + m = s; + s = orig; + orig = spat->spat_regexp->subbase; + s = orig + (m - s); + strend = s + (strend - m); + } + m = spat->spat_regexp->startp[0]; + str_ncat(dstr,s,m-s); + s = spat->spat_regexp->endp[0]; + if (c) { + if (clen) + str_ncat(dstr,c,clen); + } + else { + char *mysubbase = spat->spat_regexp->subbase; + + spat->spat_regexp->subbase = Nullch; /* so recursion works */ + (void)eval(rspat->spat_repl,G_SCALAR,sp); + str_scat(dstr,stack->ary_array[sp+1]); + if (spat->spat_regexp->subbase) + Safefree(spat->spat_regexp->subbase); + spat->spat_regexp->subbase = mysubbase; + } + if (once) + break; + } while (regexec(spat->spat_regexp, s, strend, orig, s == m, Nullstr, + safebase)); + str_ncat(dstr,s,strend - s); + str_replace(str,dstr); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, (double)iters); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; + return sp; + } + str_numset(arg->arg_ptr.arg_str, 0.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + +nope: + ++spat->spat_short->str_u.str_useful; + str_numset(arg->arg_ptr.arg_str, 0.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; +} +#ifdef BUGGY_MSC + #pragma intrinsic(memcmp) +#endif /* BUGGY_MSC */ + +int +do_trans(str,arg) +STR *str; +ARG *arg; +{ + register short *tbl; + register char *s; + register int matches = 0; + register int ch; + register char *send; + register char *d; + register int squash = arg[2].arg_len & 1; + + tbl = (short*) arg[2].arg_ptr.arg_cval; + s = str_get(str); + send = s + str->str_cur; + if (!tbl || !s) + fatal("panic: do_trans"); +#ifdef DEBUGGING + if (debug & 8) { + deb("2.TBL\n"); + } +#endif + if (!arg[2].arg_len) { + while (s < send) { + if ((ch = tbl[*s & 0377]) >= 0) { + matches++; + *s = ch; + } + s++; + } + } + else { + d = s; + while (s < send) { + if ((ch = tbl[*s & 0377]) >= 0) { + *d = ch; + if (matches++ && squash) { + if (d[-1] == *d) + matches--; + else + d++; + } + else + d++; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; /* -2 is delete character */ + s++; + } + matches += send - d; /* account for disappeared chars */ + *d = '\0'; + str->str_cur = d - str->str_ptr; + } + STABSET(str); + return matches; +} + +void +do_join(str,arglast) +register STR *str; +int *arglast; +{ + register STR **st = stack->ary_array; + int sp = arglast[1]; + register int items = arglast[2] - sp; + register char *delim = str_get(st[sp]); + register STRLEN len; + int delimlen = st[sp]->str_cur; + + st += sp + 1; + + len = (items > 0 ? (delimlen * (items - 1) ) : 0); + if (str->str_len < len + items) { /* current length is way too short */ + while (items-- > 0) { + if (*st) + len += (*st)->str_cur; + st++; + } + STR_GROW(str, len + 1); /* so try to pre-extend */ + + items = arglast[2] - sp; + st -= items; + } + + if (items-- > 0) + str_sset(str, *st++); + else + str_set(str,""); + len = delimlen; + if (len) { + for (; items > 0; items--,st++) { + str_ncat(str,delim,len); + str_scat(str,*st); + } + } + else { + for (; items > 0; items--,st++) + str_scat(str,*st); + } + STABSET(str); +} + +void +do_pack(str,arglast) +register STR *str; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items; + register char *pat = str_get(st[sp]); + register char *patend = pat + st[sp]->str_cur; + register int len; + int datumtype; + STR *fromstr; + /*SUPPRESS 442*/ + static char *null10 = "\0\0\0\0\0\0\0\0\0\0"; + static char *space10 = " "; + + /* These must not be in registers: */ + char achar; + short ashort; + int aint; + unsigned int auint; + long along; + unsigned long aulong; +#ifdef QUAD + quad aquad; + unsigned quad auquad; +#endif + char *aptr; + float afloat; + double adouble; + + items = arglast[2] - sp; + st += ++sp; + str_nset(str,"",0); + while (pat < patend) { +#define NEXTFROM (items-- > 0 ? *st++ : &str_no) + datumtype = *pat++; + if (*pat == '*') { + len = index("@Xxu",datumtype) ? 0 : items; + pat++; + } + else if (isDIGIT(*pat)) { + len = *pat++ - '0'; + while (isDIGIT(*pat)) + len = (len * 10) + (*pat++ - '0'); + } + else + len = 1; + switch(datumtype) { + default: + break; + case '%': + fatal("% may only be used in unpack"); + case '@': + len -= str->str_cur; + if (len > 0) + goto grow; + len = -len; + if (len > 0) + goto shrink; + break; + case 'X': + shrink: + if (str->str_cur < len) + fatal("X outside of string"); + str->str_cur -= len; + str->str_ptr[str->str_cur] = '\0'; + break; + case 'x': + grow: + while (len >= 10) { + str_ncat(str,null10,10); + len -= 10; + } + str_ncat(str,null10,len); + break; + case 'A': + case 'a': + fromstr = NEXTFROM; + aptr = str_get(fromstr); + if (pat[-1] == '*') + len = fromstr->str_cur; + if (fromstr->str_cur > len) + str_ncat(str,aptr,len); + else { + str_ncat(str,aptr,fromstr->str_cur); + len -= fromstr->str_cur; + if (datumtype == 'A') { + while (len >= 10) { + str_ncat(str,space10,10); + len -= 10; + } + str_ncat(str,space10,len); + } + else { + while (len >= 10) { + str_ncat(str,null10,10); + len -= 10; + } + str_ncat(str,null10,len); + } + } + break; + case 'B': + case 'b': + { + char *savepat = pat; + int saveitems; + + fromstr = NEXTFROM; + saveitems = items; + aptr = str_get(fromstr); + if (pat[-1] == '*') + len = fromstr->str_cur; + pat = aptr; + aint = str->str_cur; + str->str_cur += (len+7)/8; + STR_GROW(str, str->str_cur + 1); + aptr = str->str_ptr + aint; + if (len > fromstr->str_cur) + len = fromstr->str_cur; + aint = len; + items = 0; + if (datumtype == 'B') { + for (len = 0; len++ < aint;) { + items |= *pat++ & 1; + if (len & 7) + items <<= 1; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + else { + for (len = 0; len++ < aint;) { + if (*pat++ & 1) + items |= 128; + if (len & 7) + items >>= 1; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + if (aint & 7) { + if (datumtype == 'B') + items <<= 7 - (aint & 7); + else + items >>= 7 - (aint & 7); + *aptr++ = items & 0xff; + } + pat = str->str_ptr + str->str_cur; + while (aptr <= pat) + *aptr++ = '\0'; + + pat = savepat; + items = saveitems; + } + break; + case 'H': + case 'h': + { + char *savepat = pat; + int saveitems; + + fromstr = NEXTFROM; + saveitems = items; + aptr = str_get(fromstr); + if (pat[-1] == '*') + len = fromstr->str_cur; + pat = aptr; + aint = str->str_cur; + str->str_cur += (len+1)/2; + STR_GROW(str, str->str_cur + 1); + aptr = str->str_ptr + aint; + if (len > fromstr->str_cur) + len = fromstr->str_cur; + aint = len; + items = 0; + if (datumtype == 'H') { + for (len = 0; len++ < aint;) { + if (isALPHA(*pat)) + items |= ((*pat++ & 15) + 9) & 15; + else + items |= *pat++ & 15; + if (len & 1) + items <<= 4; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + else { + for (len = 0; len++ < aint;) { + if (isALPHA(*pat)) + items |= (((*pat++ & 15) + 9) & 15) << 4; + else + items |= (*pat++ & 15) << 4; + if (len & 1) + items >>= 4; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + if (aint & 1) + *aptr++ = items & 0xff; + pat = str->str_ptr + str->str_cur; + while (aptr <= pat) + *aptr++ = '\0'; + + pat = savepat; + items = saveitems; + } + break; + case 'C': + case 'c': + while (len-- > 0) { + fromstr = NEXTFROM; + aint = (int)str_gnum(fromstr); + achar = aint; + str_ncat(str,&achar,sizeof(char)); + } + break; + /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ + case 'f': + case 'F': + while (len-- > 0) { + fromstr = NEXTFROM; + afloat = (float)str_gnum(fromstr); + str_ncat(str, (char *)&afloat, sizeof (float)); + } + break; + case 'd': + case 'D': + while (len-- > 0) { + fromstr = NEXTFROM; + adouble = (double)str_gnum(fromstr); + str_ncat(str, (char *)&adouble, sizeof (double)); + } + break; + case 'n': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (short)str_gnum(fromstr); +#ifdef HAS_HTONS + ashort = htons(ashort); +#endif + str_ncat(str,(char*)&ashort,sizeof(short)); + } + break; + case 'v': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (short)str_gnum(fromstr); +#ifdef HAS_HTOVS + ashort = htovs(ashort); +#endif + str_ncat(str,(char*)&ashort,sizeof(short)); + } + break; + case 'S': + case 's': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (short)str_gnum(fromstr); + str_ncat(str,(char*)&ashort,sizeof(short)); + } + break; + case 'I': + while (len-- > 0) { + fromstr = NEXTFROM; + auint = U_I(str_gnum(fromstr)); + str_ncat(str,(char*)&auint,sizeof(unsigned int)); + } + break; + case 'i': + while (len-- > 0) { + fromstr = NEXTFROM; + aint = (int)str_gnum(fromstr); + str_ncat(str,(char*)&aint,sizeof(int)); + } + break; + case 'N': + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = U_L(str_gnum(fromstr)); +#ifdef HAS_HTONL + aulong = htonl(aulong); +#endif + str_ncat(str,(char*)&aulong,sizeof(unsigned long)); + } + break; + case 'V': + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = U_L(str_gnum(fromstr)); +#ifdef HAS_HTOVL + aulong = htovl(aulong); +#endif + str_ncat(str,(char*)&aulong,sizeof(unsigned long)); + } + break; + case 'L': + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = U_L(str_gnum(fromstr)); + str_ncat(str,(char*)&aulong,sizeof(unsigned long)); + } + break; + case 'l': + while (len-- > 0) { + fromstr = NEXTFROM; + along = (long)str_gnum(fromstr); + str_ncat(str,(char*)&along,sizeof(long)); + } + break; +#ifdef QUAD + case 'Q': + while (len-- > 0) { + fromstr = NEXTFROM; + auquad = (unsigned quad)str_gnum(fromstr); + str_ncat(str,(char*)&auquad,sizeof(unsigned quad)); + } + break; + case 'q': + while (len-- > 0) { + fromstr = NEXTFROM; + aquad = (quad)str_gnum(fromstr); + str_ncat(str,(char*)&aquad,sizeof(quad)); + } + break; +#endif /* QUAD */ + case 'p': + while (len-- > 0) { + fromstr = NEXTFROM; + aptr = str_get(fromstr); + str_ncat(str,(char*)&aptr,sizeof(char*)); + } + break; + case 'u': + fromstr = NEXTFROM; + aptr = str_get(fromstr); + aint = fromstr->str_cur; + STR_GROW(str,aint * 4 / 3); + if (len <= 1) + len = 45; + else + len = len / 3 * 3; + while (aint > 0) { + int todo; + + if (aint > len) + todo = len; + else + todo = aint; + doencodes(str, aptr, todo); + aint -= todo; + aptr += todo; + } + break; + } + } + STABSET(str); +} +#undef NEXTFROM + +static void +doencodes(str, s, len) +register STR *str; +register char *s; +register int len; +{ + char hunk[5]; + + *hunk = len + ' '; + str_ncat(str, hunk, 1); + hunk[4] = '\0'; + while (len > 0) { + hunk[0] = ' ' + (077 & (*s >> 2)); + hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017)); + hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03)); + hunk[3] = ' ' + (077 & (s[2] & 077)); + str_ncat(str, hunk, 4); + s += 3; + len -= 3; + } + for (s = str->str_ptr; *s; s++) { + if (*s == ' ') + *s = '`'; + } + str_ncat(str, "\n", 1); +} + +void +do_sprintf(str,len,sarg) +register STR *str; +register int len; +register STR **sarg; +{ + register char *s; + register char *t; + register char *f; + bool dolong; +#ifdef QUAD + bool doquad; +#endif /* QUAD */ + char ch; + static STR *sargnull = &str_no; + register char *send; + register STR *arg; + char *xs; + int xlen; + int pre; + int post; + double value; + + str_set(str,""); + len--; /* don't count pattern string */ + t = s = str_get(*sarg); + send = s + (*sarg)->str_cur; + sarg++; + for ( ; ; len--) { + + /*SUPPRESS 560*/ + if (len <= 0 || !(arg = *sarg++)) + arg = sargnull; + + /*SUPPRESS 530*/ + for ( ; t < send && *t != '%'; t++) ; + if (t >= send) + break; /* end of format string, ignore extra args */ + f = t; + *buf = '\0'; + xs = buf; +#ifdef QUAD + doquad = +#endif /* QUAD */ + dolong = FALSE; + pre = post = 0; + for (t++; t < send; t++) { + switch (*t) { + default: + ch = *(++t); + *t = '\0'; + (void)sprintf(xs,f); + len++, sarg--; + xlen = strlen(xs); + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + case '.': case '#': case '-': case '+': case ' ': + continue; + case 'l': +#ifdef QUAD + if (dolong) { + dolong = FALSE; + doquad = TRUE; + } else +#endif + dolong = TRUE; + continue; + case 'c': + ch = *(++t); + *t = '\0'; + xlen = (int)str_gnum(arg); + if (strEQ(f,"%c")) { /* some printfs fail on null chars */ + *xs = xlen; + xs[1] = '\0'; + xlen = 1; + } + else { + (void)sprintf(xs,f,xlen); + xlen = strlen(xs); + } + break; + case 'D': + dolong = TRUE; + /* FALL THROUGH */ + case 'd': + ch = *(++t); + *t = '\0'; +#ifdef QUAD + if (doquad) + (void)sprintf(buf,s,(quad)str_gnum(arg)); + else +#endif + if (dolong) + (void)sprintf(xs,f,(long)str_gnum(arg)); + else + (void)sprintf(xs,f,(int)str_gnum(arg)); + xlen = strlen(xs); + break; + case 'X': case 'O': + dolong = TRUE; + /* FALL THROUGH */ + case 'x': case 'o': case 'u': + ch = *(++t); + *t = '\0'; + value = str_gnum(arg); +#ifdef QUAD + if (doquad) + (void)sprintf(buf,s,(unsigned quad)value); + else +#endif + if (dolong) + (void)sprintf(xs,f,U_L(value)); + else + (void)sprintf(xs,f,U_I(value)); + xlen = strlen(xs); + break; + case 'E': case 'e': case 'f': case 'G': case 'g': + ch = *(++t); + *t = '\0'; + (void)sprintf(xs,f,str_gnum(arg)); + xlen = strlen(xs); + break; + case 's': + ch = *(++t); + *t = '\0'; + xs = str_get(arg); + xlen = arg->str_cur; + if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xs[3] == '\0' + && xlen == sizeof(STBP)) { + STR *tmpstr = Str_new(24,0); + + stab_efullname(tmpstr, ((STAB*)arg)); /* a stab value! */ + sprintf(tokenbuf,"*%s",tmpstr->str_ptr); + /* reformat to non-binary */ + xs = tokenbuf; + xlen = strlen(tokenbuf); + str_free(tmpstr); + } + if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */ + break; /* so handle simple cases */ + } + else if (f[1] == '-') { + char *mp = index(f, '.'); + int min = atoi(f+2); + + if (mp) { + int max = atoi(mp+1); + + if (xlen > max) + xlen = max; + } + if (xlen < min) + post = min - xlen; + break; + } + else if (isDIGIT(f[1])) { + char *mp = index(f, '.'); + int min = atoi(f+1); + + if (mp) { + int max = atoi(mp+1); + + if (xlen > max) + xlen = max; + } + if (xlen < min) + pre = min - xlen; + break; + } + strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */ + *t = ch; + (void)sprintf(buf,tokenbuf+64,xs); + xs = buf; + xlen = strlen(xs); + break; + } + /* end of switch, copy results */ + *t = ch; + STR_GROW(str, str->str_cur + (f - s) + xlen + 1 + pre + post); + str_ncat(str, s, f - s); + if (pre) { + repeatcpy(str->str_ptr + str->str_cur, " ", 1, pre); + str->str_cur += pre; + } + str_ncat(str, xs, xlen); + if (post) { + repeatcpy(str->str_ptr + str->str_cur, " ", 1, post); + str->str_cur += post; + } + s = t; + break; /* break from for loop */ + } + } + str_ncat(str, s, t - s); + STABSET(str); +} + +STR * +do_push(ary,arglast) +register ARRAY *ary; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register STR *str = &str_undef; + + for (st += ++sp; items > 0; items--,st++) { + str = Str_new(26,0); + if (*st) + str_sset(str,*st); + (void)apush(ary,str); + } + return str; +} + +void +do_unshift(ary,arglast) +register ARRAY *ary; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register STR *str; + register int i; + + aunshift(ary,items); + i = 0; + for (st += ++sp; i < items; i++,st++) { + str = Str_new(27,0); + str_sset(str,*st); + (void)astore(ary,i,str); + } +} + +int +do_subr(arg,gimme,arglast) +register ARG *arg; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register SUBR *sub; + SPAT * VOLATILE oldspat = curspat; + STR *str; + STAB *stab; + int oldsave = savestack->ary_fill; + int oldtmps_base = tmps_base; + int hasargs = ((arg[2].arg_type & A_MASK) != A_NULL); + register CSV *csv; + + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else { + STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab); + + if (tmpstr) + stab = stabent(str_get(tmpstr),TRUE); + else + stab = Nullstab; + } + if (!stab) + fatal("Undefined subroutine called"); + if (!(sub = stab_sub(stab))) { + STR *tmpstr = arg[0].arg_ptr.arg_str; + + stab_efullname(tmpstr, stab); + fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr); + } + if (arg->arg_type == O_DBSUBR && !sub->usersub) { + str = stab_val(DBsub); + saveitem(str); + stab_efullname(str,stab); + sub = stab_sub(DBsub); + if (!sub) + fatal("No DBsub routine"); + } + str = Str_new(15, sizeof(CSV)); + str->str_state = SS_SCSV; + (void)apush(savestack,str); + csv = (CSV*)str->str_ptr; + csv->sub = sub; + csv->stab = stab; + csv->curcsv = curcsv; + csv->curcmd = curcmd; + csv->depth = sub->depth; + csv->wantarray = gimme; + csv->hasargs = hasargs; + curcsv = csv; + tmps_base = tmps_max; + if (sub->usersub) { + csv->hasargs = 0; + csv->savearray = Null(ARRAY*);; + csv->argarray = Null(ARRAY*); + st[sp] = arg->arg_ptr.arg_str; + if (!hasargs) + items = 0; + sp = (*sub->usersub)(sub->userindex,sp,items); + } + else { + if (hasargs) { + csv->savearray = stab_xarray(defstab); + csv->argarray = afake(defstab, items, &st[sp+1]); + stab_xarray(defstab) = csv->argarray; + } + sub->depth++; + if (sub->depth >= 2) { /* save temporaries on recursion? */ + if (sub->depth == 100 && dowarn) + warn("Deep recursion on subroutine \"%s\"",stab_ename(stab)); + savelist(sub->tosave->ary_array,sub->tosave->ary_fill); + } + sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */ + } + + st = stack->ary_array; + tmps_base = oldtmps_base; + for (items = arglast[0] + 1; items <= sp; items++) + st[items] = str_mortal(st[items]); + /* in case restore wipes old str */ + restorelist(oldsave); + curspat = oldspat; + return sp; +} + +int +do_assign(arg,gimme,arglast) +register ARG *arg; +int gimme; +int *arglast; +{ + + register STR **st = stack->ary_array; + STR **firstrelem = st + arglast[1] + 1; + STR **firstlelem = st + arglast[0] + 1; + STR **lastrelem = st + arglast[2]; + STR **lastlelem = st + arglast[1]; + register STR **relem; + register STR **lelem; + + register STR *str; + register ARRAY *ary; + register int makelocal; + HASH *hash; + int i; + + makelocal = (arg->arg_flags & AF_LOCAL) != 0; + localizing = makelocal; + delaymagic = DM_DELAY; /* catch simultaneous items */ + + /* If there's a common identifier on both sides we have to take + * special care that assigning the identifier on the left doesn't + * clobber a value on the right that's used later in the list. + */ + if (arg->arg_flags & AF_COMMON) { + for (relem = firstrelem; relem <= lastrelem; relem++) { + /*SUPPRESS 560*/ + if (str = *relem) + *relem = str_mortal(str); + } + } + relem = firstrelem; + lelem = firstlelem; + ary = Null(ARRAY*); + hash = Null(HASH*); + while (lelem <= lastlelem) { + str = *lelem++; + if (str->str_state >= SS_HASH) { + if (str->str_state == SS_ARY) { + if (makelocal) + ary = saveary(str->str_u.str_stab); + else { + ary = stab_array(str->str_u.str_stab); + ary->ary_fill = -1; + } + i = 0; + while (relem <= lastrelem) { /* gobble up all the rest */ + str = Str_new(28,0); + if (*relem) + str_sset(str,*relem); + *(relem++) = str; + (void)astore(ary,i++,str); + } + } + else if (str->str_state == SS_HASH) { + char *tmps; + STR *tmpstr; + int magic = 0; + STAB *tmpstab = str->str_u.str_stab; + + if (makelocal) + hash = savehash(str->str_u.str_stab); + else { + hash = stab_hash(str->str_u.str_stab); + if (tmpstab == envstab) { + magic = 'E'; + environ[0] = Nullch; + } + else if (tmpstab == sigstab) { + magic = 'S'; +#ifndef NSIG +#define NSIG 32 +#endif + for (i = 1; i < NSIG; i++) + signal(i, SIG_DFL); /* crunch, crunch, crunch */ + } +#ifdef SOME_DBM + else if (hash->tbl_dbm) + magic = 'D'; +#endif + hclear(hash, magic == 'D'); /* wipe any dbm file too */ + + } + while (relem < lastrelem) { /* gobble up all the rest */ + if (*relem) + str = *(relem++); + else + str = &str_no, relem++; + tmps = str_get(str); + tmpstr = Str_new(29,0); + if (*relem) + str_sset(tmpstr,*relem); /* value */ + *(relem++) = tmpstr; + (void)hstore(hash,tmps,str->str_cur,tmpstr,0); + if (magic) { + str_magic(tmpstr, tmpstab, magic, tmps, str->str_cur); + stabset(tmpstr->str_magic, tmpstr); + } + } + } + else + fatal("panic: do_assign"); + } + else { + if (makelocal) + saveitem(str); + if (relem <= lastrelem) { + str_sset(str, *relem); + *(relem++) = str; + } + else { + str_sset(str, &str_undef); + if (gimme == G_ARRAY) { + i = ++lastrelem - firstrelem; + relem++; /* tacky, I suppose */ + astore(stack,i,str); + if (st != stack->ary_array) { + st = stack->ary_array; + firstrelem = st + arglast[1] + 1; + firstlelem = st + arglast[0] + 1; + lastlelem = st + arglast[1]; + lastrelem = st + i; + relem = lastrelem + 1; + } + } + } + STABSET(str); + } + } + if (delaymagic & ~DM_DELAY) { + if (delaymagic & DM_UID) { +#ifdef HAS_SETREUID + (void)setreuid(uid,euid); +#else /* not HAS_SETREUID */ +#ifdef HAS_SETRUID + if ((delaymagic & DM_UID) == DM_RUID) { + (void)setruid(uid); + delaymagic =~ DM_RUID; + } +#endif /* HAS_SETRUID */ +#ifdef HAS_SETEUID + if ((delaymagic & DM_UID) == DM_EUID) { + (void)seteuid(uid); + delaymagic =~ DM_EUID; + } +#endif /* HAS_SETEUID */ + if (delaymagic & DM_UID) { + if (uid != euid) + fatal("No setreuid available"); + (void)setuid(uid); + } +#endif /* not HAS_SETREUID */ + uid = (int)getuid(); + euid = (int)geteuid(); + } + if (delaymagic & DM_GID) { +#ifdef HAS_SETREGID + (void)setregid(gid,egid); +#else /* not HAS_SETREGID */ +#ifdef HAS_SETRGID + if ((delaymagic & DM_GID) == DM_RGID) { + (void)setrgid(gid); + delaymagic =~ DM_RGID; + } +#endif /* HAS_SETRGID */ +#ifdef HAS_SETEGID + if ((delaymagic & DM_GID) == DM_EGID) { + (void)setegid(gid); + delaymagic =~ DM_EGID; + } +#endif /* HAS_SETEGID */ + if (delaymagic & DM_GID) { + if (gid != egid) + fatal("No setregid available"); + (void)setgid(gid); + } +#endif /* not HAS_SETREGID */ + gid = (int)getgid(); + egid = (int)getegid(); + } + } + delaymagic = 0; + localizing = FALSE; + if (gimme == G_ARRAY) { + i = lastrelem - firstrelem + 1; + if (ary || hash) + Copy(firstrelem, firstlelem, i, STR*); + return arglast[0] + i; + } + else { + str_numset(arg->arg_ptr.arg_str,(double)(arglast[2] - arglast[1])); + *firstlelem = arg->arg_ptr.arg_str; + return arglast[0] + 1; + } +} + +int /*SUPPRESS 590*/ +do_study(str,arg,gimme,arglast) +STR *str; +ARG *arg; +int gimme; +int *arglast; +{ + register unsigned char *s; + register int pos = str->str_cur; + register int ch; + register int *sfirst; + register int *snext; + static int maxscream = -1; + static STR *lastscream = Nullstr; + int retval; + int retarg = arglast[0] + 1; + +#ifndef lint + s = (unsigned char*)(str_get(str)); +#else + s = Null(unsigned char*); +#endif + if (lastscream) + lastscream->str_pok &= ~SP_STUDIED; + lastscream = str; + if (pos <= 0) { + retval = 0; + goto ret; + } + if (pos > maxscream) { + if (maxscream < 0) { + maxscream = pos + 80; + New(301,screamfirst, 256, int); + New(302,screamnext, maxscream, int); + } + else { + maxscream = pos + pos / 4; + Renew(screamnext, maxscream, int); + } + } + + sfirst = screamfirst; + snext = screamnext; + + if (!sfirst || !snext) + fatal("do_study: out of memory"); + + for (ch = 256; ch; --ch) + *sfirst++ = -1; + sfirst -= 256; + + while (--pos >= 0) { + ch = s[pos]; + if (sfirst[ch] >= 0) + snext[pos] = sfirst[ch] - pos; + else + snext[pos] = -pos; + sfirst[ch] = pos; + + /* If there were any case insensitive searches, we must assume they + * all are. This speeds up insensitive searches much more than + * it slows down sensitive ones. + */ + if (sawi) + sfirst[fold[ch]] = pos; + } + + str->str_pok |= SP_STUDIED; + retval = 1; + ret: + str_numset(arg->arg_ptr.arg_str,(double)retval); + stack->ary_array[retarg] = arg->arg_ptr.arg_str; + return retarg; +} + +int /*SUPPRESS 590*/ +do_defined(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register int type; + register int retarg = arglast[0] + 1; + int retval; + ARRAY *ary; + HASH *hash; + + if ((arg[1].arg_type & A_MASK) != A_LEXPR) + fatal("Illegal argument to defined()"); + arg = arg[1].arg_ptr.arg_arg; + type = arg->arg_type; + + if (type == O_SUBR || type == O_DBSUBR) { + if ((arg[1].arg_type & A_MASK) == A_WORD) + retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0; + else { + STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab); + + retval = tmpstr && stab_sub(stabent(str_get(tmpstr),TRUE)) != 0; + } + } + else if (type == O_ARRAY || type == O_LARRAY || + type == O_ASLICE || type == O_LASLICE ) + retval = ((ary = stab_xarray(arg[1].arg_ptr.arg_stab)) != 0 + && ary->ary_max >= 0 ); + else if (type == O_HASH || type == O_LHASH || + type == O_HSLICE || type == O_LHSLICE ) + retval = ((hash = stab_xhash(arg[1].arg_ptr.arg_stab)) != 0 + && hash->tbl_array); + else + retval = FALSE; + str_numset(str,(double)retval); + stack->ary_array[retarg] = str; + return retarg; +} + +int /*SUPPRESS 590*/ +do_undef(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register int type; + register STAB *stab; + int retarg = arglast[0] + 1; + + if ((arg[1].arg_type & A_MASK) != A_LEXPR) + fatal("Illegal argument to undef()"); + arg = arg[1].arg_ptr.arg_arg; + type = arg->arg_type; + + if (type == O_ARRAY || type == O_LARRAY) { + stab = arg[1].arg_ptr.arg_stab; + afree(stab_xarray(stab)); + stab_xarray(stab) = anew(stab); /* so "@array" still works */ + } + else if (type == O_HASH || type == O_LHASH) { + stab = arg[1].arg_ptr.arg_stab; + if (stab == envstab) + environ[0] = Nullch; + else if (stab == sigstab) { + int i; + + for (i = 1; i < NSIG; i++) + signal(i, SIG_DFL); /* munch, munch, munch */ + } + (void)hfree(stab_xhash(stab), TRUE); + stab_xhash(stab) = Null(HASH*); + } + else if (type == O_SUBR || type == O_DBSUBR) { + stab = arg[1].arg_ptr.arg_stab; + if ((arg[1].arg_type & A_MASK) != A_WORD) { + STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab); + + if (tmpstr) + stab = stabent(str_get(tmpstr),TRUE); + else + stab = Nullstab; + } + if (stab && stab_sub(stab)) { + cmd_free(stab_sub(stab)->cmd); + stab_sub(stab)->cmd = Nullcmd; + afree(stab_sub(stab)->tosave); + Safefree(stab_sub(stab)); + stab_sub(stab) = Null(SUBR*); + } + } + else + fatal("Can't undefine that kind of object"); + str_numset(str,0.0); + stack->ary_array[retarg] = str; + return retarg; +} + +int +do_vec(lvalue,astr,arglast) +int lvalue; +STR *astr; +int *arglast; +{ + STR **st = stack->ary_array; + int sp = arglast[0]; + register STR *str = st[++sp]; + register int offset = (int)str_gnum(st[++sp]); + register int size = (int)str_gnum(st[++sp]); + unsigned char *s = (unsigned char*)str_get(str); + unsigned long retnum; + int len; + + sp = arglast[1]; + offset *= size; /* turn into bit offset */ + len = (offset + size + 7) / 8; + if (offset < 0 || size < 1) + retnum = 0; + else if (!lvalue && len > str->str_cur) + retnum = 0; + else { + if (len > str->str_cur) { + STR_GROW(str,len); + (void)memzero(str->str_ptr + str->str_cur, len - str->str_cur); + str->str_cur = len; + } + s = (unsigned char*)str_get(str); + if (size < 8) + retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); + else { + offset >>= 3; + if (size == 8) + retnum = s[offset]; + else if (size == 16) + retnum = ((unsigned long) s[offset] << 8) + s[offset+1]; + else if (size == 32) + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16) + + (s[offset + 2] << 8) + s[offset+3]; + } + + if (lvalue) { /* it's an lvalue! */ + struct lstring *lstr = (struct lstring*)astr; + + astr->str_magic = str; + st[sp]->str_rare = 'v'; + lstr->lstr_offset = offset; + lstr->lstr_len = size; + } + } + + str_numset(astr,(double)retnum); + st[sp] = astr; + return sp; +} + +void +do_vecset(mstr,str) +STR *mstr; +STR *str; +{ + struct lstring *lstr = (struct lstring*)str; + register int offset; + register int size; + register unsigned char *s = (unsigned char*)mstr->str_ptr; + register unsigned long lval = U_L(str_gnum(str)); + int mask; + + mstr->str_rare = 0; + str->str_magic = Nullstr; + offset = lstr->lstr_offset; + size = lstr->lstr_len; + if (size < 8) { + mask = (1 << size) - 1; + size = offset & 7; + lval &= mask; + offset >>= 3; + s[offset] &= ~(mask << size); + s[offset] |= lval << size; + } + else { + if (size == 8) + s[offset] = lval & 255; + else if (size == 16) { + s[offset] = (lval >> 8) & 255; + s[offset+1] = lval & 255; + } + else if (size == 32) { + s[offset] = (lval >> 24) & 255; + s[offset+1] = (lval >> 16) & 255; + s[offset+2] = (lval >> 8) & 255; + s[offset+3] = lval & 255; + } + } +} + +void +do_chop(astr,str) +register STR *astr; +register STR *str; +{ + register char *tmps; + register int i; + ARRAY *ary; + HASH *hash; + HENT *entry; + + if (!str) + return; + if (str->str_state == SS_ARY) { + ary = stab_array(str->str_u.str_stab); + for (i = 0; i <= ary->ary_fill; i++) + do_chop(astr,ary->ary_array[i]); + return; + } + if (str->str_state == SS_HASH) { + hash = stab_hash(str->str_u.str_stab); + (void)hiterinit(hash); + /*SUPPRESS 560*/ + while (entry = hiternext(hash)) + do_chop(astr,hiterval(hash,entry)); + return; + } + tmps = str_get(str); + if (tmps && str->str_cur) { + tmps += str->str_cur - 1; + str_nset(astr,tmps,1); /* remember last char */ + *tmps = '\0'; /* wipe it out */ + str->str_cur = tmps - str->str_ptr; + str->str_nok = 0; + STABSET(str); + } + else + str_nset(astr,"",0); +} + +void +do_vop(optype,str,left,right) +STR *str; +STR *left; +STR *right; +{ + register char *s; + register char *l = str_get(left); + register char *r = str_get(right); + register int len; + + len = left->str_cur; + if (len > right->str_cur) + len = right->str_cur; + if (str->str_cur > len) + str->str_cur = len; + else if (str->str_cur < len) { + STR_GROW(str,len); + (void)memzero(str->str_ptr + str->str_cur, len - str->str_cur); + str->str_cur = len; + } + str->str_pok = 1; + str->str_nok = 0; + s = str->str_ptr; + if (!s) { + str_nset(str,"",0); + s = str->str_ptr; + } + switch (optype) { + case O_BIT_AND: + while (len--) + *s++ = *l++ & *r++; + break; + case O_XOR: + while (len--) + *s++ = *l++ ^ *r++; + goto mop_up; + case O_BIT_OR: + while (len--) + *s++ = *l++ | *r++; + mop_up: + len = str->str_cur; + if (right->str_cur > len) + str_ncat(str,right->str_ptr+len,right->str_cur - len); + else if (left->str_cur > len) + str_ncat(str,left->str_ptr+len,left->str_cur - len); + break; + } +} + +int +do_syscall(arglast) +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; +#ifdef atarist + unsigned long arg[14]; /* yes, we really need that many ! */ +#else + unsigned long arg[8]; +#endif + register int i = 0; + int retval = -1; + +#ifdef HAS_SYSCALL +#ifdef TAINT + for (st += ++sp; items--; st++) + tainted |= (*st)->str_tainted; + st = stack->ary_array; + sp = arglast[1]; + items = arglast[2] - sp; +#endif +#ifdef TAINT + taintproper("Insecure dependency in syscall"); +#endif + /* This probably won't work on machines where sizeof(long) != sizeof(int) + * or where sizeof(long) != sizeof(char*). But such machines will + * not likely have syscall implemented either, so who cares? + */ + while (items--) { + if (st[++sp]->str_nok || !i) + arg[i++] = (unsigned long)str_gnum(st[sp]); +#ifndef lint + else + arg[i++] = (unsigned long)st[sp]->str_ptr; +#endif /* lint */ + } + sp = arglast[1]; + items = arglast[2] - sp; + switch (items) { + case 0: + fatal("Too few args to syscall"); + case 1: + retval = syscall(arg[0]); + break; + case 2: + retval = syscall(arg[0],arg[1]); + break; + case 3: + retval = syscall(arg[0],arg[1],arg[2]); + break; + case 4: + retval = syscall(arg[0],arg[1],arg[2],arg[3]); + break; + case 5: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4]); + break; + case 6: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5]); + break; + case 7: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6]); + break; + case 8: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7]); + break; +#ifdef atarist + case 9: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8]); + break; + case 10: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9]); + break; + case 11: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9], arg[10]); + break; + case 12: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9], arg[10], arg[11]); + break; + case 13: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9], arg[10], arg[11], arg[12]); + break; + case 14: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13]); + break; +#endif /* atarist */ + } + return retval; +#else + fatal("syscall() unimplemented"); +#endif +} + + diff --git a/gnu/usr.bin/perl/perl/doio.c b/gnu/usr.bin/perl/perl/doio.c new file mode 100644 index 0000000..eb1dac5 --- /dev/null +++ b/gnu/usr.bin/perl/perl/doio.c @@ -0,0 +1,2951 @@ +/* $RCSfile: doio.c,v $$Revision: 1.2 $$Date: 1994/03/09 22:24:27 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: doio.c,v $ + * Revision 1.2 1994/03/09 22:24:27 ache + * (cast) added for last argument of semctl + * + * Revision 1.1.1.1 1993/08/23 21:29:36 nate + * PERL! + * + * Revision 4.0.1.6 92/06/11 21:08:16 lwall + * patch34: some systems don't declare h_errno extern in header files + * + * Revision 4.0.1.5 92/06/08 13:00:21 lwall + * patch20: some machines don't define ENOTSOCK in errno.h + * patch20: new warnings for failed use of stat operators on filenames with \n + * patch20: wait failed when STDOUT or STDERR reopened to a pipe + * patch20: end of file latch not reset on reopen of STDIN + * patch20: seek(HANDLE, 0, 1) went to eof because of ancient Ultrix workaround + * patch20: fixed memory leak on system() for vfork() machines + * patch20: get*by* routines now return something useful in a scalar context + * patch20: h_errno now accessible via $? + * + * Revision 4.0.1.4 91/11/05 16:51:43 lwall + * patch11: prepared for ctype implementations that don't define isascii() + * patch11: perl mistook some streams for sockets because they return mode 0 too + * patch11: reopening STDIN, STDOUT and STDERR failed on some machines + * patch11: certain perl errors should set EBADF so that $! looks better + * patch11: truncate on a closed filehandle could dump + * patch11: stats of _ forgot whether prior stat was actually lstat + * patch11: -T returned true on NFS directory + * + * Revision 4.0.1.3 91/06/10 01:21:19 lwall + * patch10: read didn't work from character special files open for writing + * patch10: close-on-exec wrongly set on system file descriptors + * + * Revision 4.0.1.2 91/06/07 10:53:39 lwall + * patch4: new copyright notice + * patch4: system fd's are now treated specially + * patch4: added $^F variable to specify maximum system fd, default 2 + * patch4: character special files now opened with bidirectional stdio buffers + * patch4: taintchecks could improperly modify parent in vfork() + * patch4: many, many itty-bitty portability fixes + * + * Revision 4.0.1.1 91/04/11 17:41:06 lwall + * patch1: hopefully straightened out some of the Xenix mess + * + * Revision 4.0 91/03/20 01:07:06 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#include +#include +#include + + +#ifdef HAS_SOCKET +#include +#include +#ifndef ENOTSOCK +#include +#endif +#endif + +#ifdef HAS_SELECT +#ifdef I_SYS_SELECT +#ifndef I_SYS_TIME +#include +#endif +#endif +#endif + +#ifdef HOST_NOT_FOUND +extern int h_errno; +#endif + +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) +#include +#ifdef HAS_MSG +#include +#endif +#ifdef HAS_SEM +#include +#endif +#ifdef HAS_SHM +#include +#endif +#endif + +#ifdef I_PWD +#include +#endif +#ifdef I_GRP +#include +#endif +#ifdef I_UTIME +#include +#endif +#ifdef I_FCNTL +#include +#endif +#ifdef I_SYS_FILE +#include +#endif + +int laststatval = -1; +int laststype = O_STAT; + +static char* warn_nl = "Unsuccessful %s on filename containing newline"; + +bool +do_open(stab,name,len) +STAB *stab; +register char *name; +int len; +{ + FILE *fp; + register STIO *stio = stab_io(stab); + char *myname = savestr(name); + int result; + int fd; + int writing = 0; + char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ + FILE *saveifp = Nullfp; + FILE *saveofp = Nullfp; + char savetype = ' '; + + mode[0] = mode[1] = mode[2] = '\0'; + name = myname; + forkprocess = 1; /* assume true if no fork */ + while (len && isSPACE(name[len-1])) + name[--len] = '\0'; + if (!stio) + stio = stab_io(stab) = stio_new(); + else if (stio->ifp) { + fd = fileno(stio->ifp); + if (stio->type == '-') + result = 0; + else if (fd <= maxsysfd) { + saveifp = stio->ifp; + saveofp = stio->ofp; + savetype = stio->type; + result = 0; + } + else if (stio->type == '|') + result = mypclose(stio->ifp); + else if (stio->ifp != stio->ofp) { + if (stio->ofp) { + result = fclose(stio->ofp); + fclose(stio->ifp); /* clear stdio, fd already closed */ + } + else + result = fclose(stio->ifp); + } + else + result = fclose(stio->ifp); + if (result == EOF && fd > maxsysfd) + fprintf(stderr,"Warning: unable to close filehandle %s properly.\n", + stab_ename(stab)); + stio->ofp = stio->ifp = Nullfp; + } + if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */ + mode[1] = *name++; + mode[2] = '\0'; + --len; + writing = 1; + } + else { + mode[1] = '\0'; + } + stio->type = *name; + if (*name == '|') { + /*SUPPRESS 530*/ + for (name++; isSPACE(*name); name++) ; +#ifdef TAINT + taintenv(); + taintproper("Insecure dependency in piped open"); +#endif + fp = mypopen(name,"w"); + writing = 1; + } + else if (*name == '>') { +#ifdef TAINT + taintproper("Insecure dependency in open"); +#endif + name++; + if (*name == '>') { + mode[0] = stio->type = 'a'; + name++; + } + else + mode[0] = 'w'; + writing = 1; + if (*name == '&') { + duplicity: + name++; + while (isSPACE(*name)) + name++; + if (isDIGIT(*name)) + fd = atoi(name); + else { + stab = stabent(name,FALSE); + if (!stab || !stab_io(stab)) { +#ifdef EINVAL + errno = EINVAL; +#endif + goto say_false; + } + if (stab_io(stab) && stab_io(stab)->ifp) { + fd = fileno(stab_io(stab)->ifp); + if (stab_io(stab)->type == 's') + stio->type = 's'; + } + else + fd = -1; + } + if (!(fp = fdopen(fd = dup(fd),mode))) { + close(fd); + } + } + else { + while (isSPACE(*name)) + name++; + if (strEQ(name,"-")) { + fp = stdout; + stio->type = '-'; + } + else { + fp = fopen(name,mode); + } + } + } + else { + if (*name == '<') { + mode[0] = 'r'; + name++; + while (isSPACE(*name)) + name++; + if (*name == '&') + goto duplicity; + if (strEQ(name,"-")) { + fp = stdin; + stio->type = '-'; + } + else + fp = fopen(name,mode); + } + else if (name[len-1] == '|') { +#ifdef TAINT + taintenv(); + taintproper("Insecure dependency in piped open"); +#endif + name[--len] = '\0'; + while (len && isSPACE(name[len-1])) + name[--len] = '\0'; + /*SUPPRESS 530*/ + for (; isSPACE(*name); name++) ; + fp = mypopen(name,"r"); + stio->type = '|'; + } + else { + stio->type = '<'; + /*SUPPRESS 530*/ + for (; isSPACE(*name); name++) ; + if (strEQ(name,"-")) { + fp = stdin; + stio->type = '-'; + } + else + fp = fopen(name,"r"); + } + } + if (!fp) { + if (dowarn && stio->type == '<' && index(name, '\n')) + warn(warn_nl, "open"); + Safefree(myname); + goto say_false; + } + Safefree(myname); + if (stio->type && + stio->type != '|' && stio->type != '-') { + if (fstat(fileno(fp),&statbuf) < 0) { + (void)fclose(fp); + goto say_false; + } + if (S_ISSOCK(statbuf.st_mode)) + stio->type = 's'; /* in case a socket was passed in to us */ +#ifdef HAS_SOCKET + else if ( +#ifdef S_IFMT + !(statbuf.st_mode & S_IFMT) +#else + !statbuf.st_mode +#endif + ) { + int buflen = sizeof tokenbuf; + if (getsockname(fileno(fp), tokenbuf, &buflen) >= 0 + || errno != ENOTSOCK) + stio->type = 's'; /* some OS's return 0 on fstat()ed socket */ + /* but some return 0 for streams too, sigh */ + } +#endif + } + if (saveifp) { /* must use old fp? */ + fd = fileno(saveifp); + if (saveofp) { + fflush(saveofp); /* emulate fclose() */ + if (saveofp != saveifp) { /* was a socket? */ + fclose(saveofp); + if (fd > 2) + Safefree(saveofp); + } + } + if (fd != fileno(fp)) { + int pid; + STR *str; + + dup2(fileno(fp), fd); + str = afetch(fdpid,fileno(fp),TRUE); + pid = str->str_u.str_useful; + str->str_u.str_useful = 0; + str = afetch(fdpid,fd,TRUE); + str->str_u.str_useful = pid; + fclose(fp); + + } + fp = saveifp; + clearerr(fp); + } +#if defined(HAS_FCNTL) && defined(F_SETFD) + fd = fileno(fp); + fcntl(fd,F_SETFD,fd > maxsysfd); +#endif + stio->ifp = fp; + if (writing) { + if (stio->type == 's' + || (stio->type == '>' && S_ISCHR(statbuf.st_mode)) ) { + if (!(stio->ofp = fdopen(fileno(fp),"w"))) { + fclose(fp); + stio->ifp = Nullfp; + goto say_false; + } + } + else + stio->ofp = fp; + } + return TRUE; + +say_false: + stio->ifp = saveifp; + stio->ofp = saveofp; + stio->type = savetype; + return FALSE; +} + +FILE * +nextargv(stab) +register STAB *stab; +{ + register STR *str; +#ifndef FLEXFILENAMES + int filedev; + int fileino; +#endif + int fileuid; + int filegid; + static int filemode = 0; + static int lastfd; + static char *oldname; + + if (!argvoutstab) + argvoutstab = stabent("ARGVOUT",TRUE); + if (filemode & (S_ISUID|S_ISGID)) { + fflush(stab_io(argvoutstab)->ifp); /* chmod must follow last write */ +#ifdef HAS_FCHMOD + (void)fchmod(lastfd,filemode); +#else + (void)chmod(oldname,filemode); +#endif + } + filemode = 0; + while (alen(stab_xarray(stab)) >= 0) { + str = ashift(stab_xarray(stab)); + str_sset(stab_val(stab),str); + STABSET(stab_val(stab)); + oldname = str_get(stab_val(stab)); + if (do_open(stab,oldname,stab_val(stab)->str_cur)) { + if (inplace) { +#ifdef TAINT + taintproper("Insecure dependency in inplace open"); +#endif + if (strEQ(oldname,"-")) { + str_free(str); + defoutstab = stabent("STDOUT",TRUE); + return stab_io(stab)->ifp; + } +#ifndef FLEXFILENAMES + filedev = statbuf.st_dev; + fileino = statbuf.st_ino; +#endif + filemode = statbuf.st_mode; + fileuid = statbuf.st_uid; + filegid = statbuf.st_gid; + if (!S_ISREG(filemode)) { + warn("Can't do inplace edit: %s is not a regular file", + oldname ); + do_close(stab,FALSE); + str_free(str); + continue; + } + if (*inplace) { +#ifdef SUFFIX + add_suffix(str,inplace); +#else + str_cat(str,inplace); +#endif +#ifndef FLEXFILENAMES + if (stat(str->str_ptr,&statbuf) >= 0 + && statbuf.st_dev == filedev + && statbuf.st_ino == fileino ) { + warn("Can't do inplace edit: %s > 14 characters", + str->str_ptr ); + do_close(stab,FALSE); + str_free(str); + continue; + } +#endif +#ifdef HAS_RENAME +#ifndef DOSISH + if (rename(oldname,str->str_ptr) < 0) { + warn("Can't rename %s to %s: %s, skipping file", + oldname, str->str_ptr, strerror(errno) ); + do_close(stab,FALSE); + str_free(str); + continue; + } +#else + do_close(stab,FALSE); + (void)unlink(str->str_ptr); + (void)rename(oldname,str->str_ptr); + do_open(stab,str->str_ptr,stab_val(stab)->str_cur); +#endif /* MSDOS */ +#else + (void)UNLINK(str->str_ptr); + if (link(oldname,str->str_ptr) < 0) { + warn("Can't rename %s to %s: %s, skipping file", + oldname, str->str_ptr, strerror(errno) ); + do_close(stab,FALSE); + str_free(str); + continue; + } + (void)UNLINK(oldname); +#endif + } + else { +#ifndef DOSISH + if (UNLINK(oldname) < 0) { + warn("Can't rename %s to %s: %s, skipping file", + oldname, str->str_ptr, strerror(errno) ); + do_close(stab,FALSE); + str_free(str); + continue; + } +#else + fatal("Can't do inplace edit without backup"); +#endif + } + + str_nset(str,">",1); + str_cat(str,oldname); + errno = 0; /* in case sprintf set errno */ + if (!do_open(argvoutstab,str->str_ptr,str->str_cur)) { + warn("Can't do inplace edit on %s: %s", + oldname, strerror(errno) ); + do_close(stab,FALSE); + str_free(str); + continue; + } + defoutstab = argvoutstab; + lastfd = fileno(stab_io(argvoutstab)->ifp); + (void)fstat(lastfd,&statbuf); +#ifdef HAS_FCHMOD + (void)fchmod(lastfd,filemode); +#else + (void)chmod(oldname,filemode); +#endif + if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) { +#ifdef HAS_FCHOWN + (void)fchown(lastfd,fileuid,filegid); +#else +#ifdef HAS_CHOWN + (void)chown(oldname,fileuid,filegid); +#endif +#endif + } + } + str_free(str); + return stab_io(stab)->ifp; + } + else + fprintf(stderr,"Can't open %s: %s\n",str_get(str), strerror(errno)); + str_free(str); + } + if (inplace) { + (void)do_close(argvoutstab,FALSE); + defoutstab = stabent("STDOUT",TRUE); + } + return Nullfp; +} + +#ifdef HAS_PIPE +void +do_pipe(str, rstab, wstab) +STR *str; +STAB *rstab; +STAB *wstab; +{ + register STIO *rstio; + register STIO *wstio; + int fd[2]; + + if (!rstab) + goto badexit; + if (!wstab) + goto badexit; + + rstio = stab_io(rstab); + wstio = stab_io(wstab); + + if (!rstio) + rstio = stab_io(rstab) = stio_new(); + else if (rstio->ifp) + do_close(rstab,FALSE); + if (!wstio) + wstio = stab_io(wstab) = stio_new(); + else if (wstio->ifp) + do_close(wstab,FALSE); + + if (pipe(fd) < 0) + goto badexit; + rstio->ifp = fdopen(fd[0], "r"); + wstio->ofp = fdopen(fd[1], "w"); + wstio->ifp = wstio->ofp; + rstio->type = '<'; + wstio->type = '>'; + if (!rstio->ifp || !wstio->ofp) { + if (rstio->ifp) fclose(rstio->ifp); + else close(fd[0]); + if (wstio->ofp) fclose(wstio->ofp); + else close(fd[1]); + goto badexit; + } + + str_sset(str,&str_yes); + return; + +badexit: + str_sset(str,&str_undef); + return; +} +#endif + +bool +do_close(stab,explicit) +STAB *stab; +bool explicit; +{ + bool retval = FALSE; + register STIO *stio; + int status; + + if (!stab) + stab = argvstab; + if (!stab) { + errno = EBADF; + return FALSE; + } + stio = stab_io(stab); + if (!stio) { /* never opened */ + if (dowarn && explicit) + warn("Close on unopened file <%s>",stab_ename(stab)); + return FALSE; + } + if (stio->ifp) { + if (stio->type == '|') { + status = mypclose(stio->ifp); + retval = (status == 0); + statusvalue = (unsigned short)status & 0xffff; + } + else if (stio->type == '-') + retval = TRUE; + else { + if (stio->ofp && stio->ofp != stio->ifp) { /* a socket */ + retval = (fclose(stio->ofp) != EOF); + fclose(stio->ifp); /* clear stdio, fd already closed */ + } + else + retval = (fclose(stio->ifp) != EOF); + } + stio->ofp = stio->ifp = Nullfp; + } + if (explicit) + stio->lines = 0; + stio->type = ' '; + return retval; +} + +bool +do_eof(stab) +STAB *stab; +{ + register STIO *stio; + int ch; + + if (!stab) { /* eof() */ + if (argvstab) + stio = stab_io(argvstab); + else + return TRUE; + } + else + stio = stab_io(stab); + + if (!stio) + return TRUE; + + while (stio->ifp) { + +#ifdef STDSTDIO /* (the code works without this) */ + if (stio->ifp->_cnt > 0) /* cheat a little, since */ + return FALSE; /* this is the most usual case */ +#endif + + ch = getc(stio->ifp); + if (ch != EOF) { + (void)ungetc(ch, stio->ifp); + return FALSE; + } +#ifdef STDSTDIO + if (stio->ifp->_cnt < -1) + stio->ifp->_cnt = -1; +#endif + if (!stab) { /* not necessarily a real EOF yet? */ + if (!nextargv(argvstab)) /* get another fp handy */ + return TRUE; + } + else + return TRUE; /* normal fp, definitely end of file */ + } + return TRUE; +} + +long +do_tell(stab) +STAB *stab; +{ + register STIO *stio; + + if (!stab) + goto phooey; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto phooey; + +#ifdef ULTRIX_STDIO_BOTCH + if (feof(stio->ifp)) + (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */ +#endif + + return ftell(stio->ifp); + +phooey: + if (dowarn) + warn("tell() on unopened file"); + errno = EBADF; + return -1L; +} + +bool +do_seek(stab, pos, whence) +STAB *stab; +long pos; +int whence; +{ + register STIO *stio; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + +#ifdef ULTRIX_STDIO_BOTCH + if (feof(stio->ifp)) + (void)fseek (stio->ifp, 0L, 2); /* ultrix 1.2 workaround */ +#endif + + return fseek(stio->ifp, pos, whence) >= 0; + +nuts: + if (dowarn) + warn("seek() on unopened file"); + errno = EBADF; + return FALSE; +} + +int +do_ctl(optype,stab,func,argstr) +int optype; +STAB *stab; +int func; +STR *argstr; +{ + register STIO *stio; + register char *s; + int retval; + + if (!stab || !argstr || !(stio = stab_io(stab)) || !stio->ifp) { + errno = EBADF; /* well, sort of... */ + return -1; + } + + if (argstr->str_pok || !argstr->str_nok) { + if (!argstr->str_pok) + s = str_get(argstr); + +#ifdef IOCPARM_MASK +#ifndef IOCPARM_LEN +#define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK) +#endif +#endif +#ifdef IOCPARM_LEN + retval = IOCPARM_LEN(func); /* on BSDish systes we're safe */ +#else + retval = 256; /* otherwise guess at what's safe */ +#endif + if (argstr->str_cur < retval) { + Str_Grow(argstr,retval+1); + argstr->str_cur = retval; + } + + s = argstr->str_ptr; + s[argstr->str_cur] = 17; /* a little sanity check here */ + } + else { + retval = (int)str_gnum(argstr); +#ifdef DOSISH + s = (char*)(long)retval; /* ouch */ +#else + s = (char*)retval; /* ouch */ +#endif + } + +#ifndef lint + if (optype == O_IOCTL) + retval = ioctl(fileno(stio->ifp), func, s); + else +#ifdef DOSISH + fatal("fcntl is not implemented"); +#else +#ifdef HAS_FCNTL + retval = fcntl(fileno(stio->ifp), func, s); +#else + fatal("fcntl is not implemented"); +#endif +#endif +#else /* lint */ + retval = 0; +#endif /* lint */ + + if (argstr->str_pok) { + if (s[argstr->str_cur] != 17) + fatal("Return value overflowed string"); + s[argstr->str_cur] = 0; /* put our null back */ + } + return retval; +} + +int +do_stat(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0] + 1; + int max = 13; + + if ((arg[1].arg_type & A_MASK) == A_WORD) { + tmpstab = arg[1].arg_ptr.arg_stab; + if (tmpstab != defstab) { + laststype = O_STAT; + statstab = tmpstab; + str_set(statname,""); + if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp || + fstat(fileno(stab_io(tmpstab)->ifp),&statcache) < 0) { + max = 0; + laststatval = -1; + } + } + else if (laststatval < 0) + max = 0; + } + else { + str_set(statname,str_get(ary->ary_array[sp])); + statstab = Nullstab; +#ifdef HAS_LSTAT + laststype = arg->arg_type; + if (arg->arg_type == O_LSTAT) + laststatval = lstat(str_get(statname),&statcache); + else +#endif + laststatval = stat(str_get(statname),&statcache); + if (laststatval < 0) { + if (dowarn && index(str_get(statname), '\n')) + warn(warn_nl, "stat"); + max = 0; + } + } + + if (gimme != G_ARRAY) { + if (max) + str_sset(str,&str_yes); + else + str_sset(str,&str_undef); + STABSET(str); + ary->ary_array[sp] = str; + return sp; + } + sp--; + if (max) { +#ifndef lint + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_dev))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_ino))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_mode))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_nlink))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_uid))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_gid))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_rdev))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_size))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_atime))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_mtime))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_ctime))); +#ifdef STATBLOCKS + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_blksize))); + (void)astore(ary,++sp, + str_2mortal(str_nmake((double)statcache.st_blocks))); +#else + (void)astore(ary,++sp, + str_2mortal(str_make("",0))); + (void)astore(ary,++sp, + str_2mortal(str_make("",0))); +#endif +#else /* lint */ + (void)astore(ary,++sp,str_nmake(0.0)); +#endif /* lint */ + } + return sp; +} + +#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) + /* code courtesy of William Kucharski */ +#define HAS_CHSIZE + +int chsize(fd, length) +int fd; /* file descriptor */ +off_t length; /* length to set file to */ +{ + extern long lseek(); + struct flock fl; + struct stat filebuf; + + if (fstat(fd, &filebuf) < 0) + return -1; + + if (filebuf.st_size < length) { + + /* extend file length */ + + if ((lseek(fd, (length - 1), 0)) < 0) + return -1; + + /* write a "0" byte */ + + if ((write(fd, "", 1)) != 1) + return -1; + } + else { + /* truncate length */ + + fl.l_whence = 0; + fl.l_len = 0; + fl.l_start = length; + fl.l_type = F_WRLCK; /* write lock on file space */ + + /* + * This relies on the UNDOCUMENTED F_FREESP argument to + * fcntl(2), which truncates the file so that it ends at the + * position indicated by fl.l_start. + * + * Will minor miracles never cease? + */ + + if (fcntl(fd, F_FREESP, &fl) < 0) + return -1; + + } + + return 0; +} +#endif /* F_FREESP */ + +int /*SUPPRESS 590*/ +do_truncate(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0] + 1; + off_t len = (off_t)str_gnum(ary->ary_array[sp+1]); + int result = 1; + STAB *tmpstab; + +#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) +#ifdef HAS_TRUNCATE + if ((arg[1].arg_type & A_MASK) == A_WORD) { + tmpstab = arg[1].arg_ptr.arg_stab; + if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp || + ftruncate(fileno(stab_io(tmpstab)->ifp), len) < 0) + result = 0; + } + else if (truncate(str_get(ary->ary_array[sp]), len) < 0) + result = 0; +#else + if ((arg[1].arg_type & A_MASK) == A_WORD) { + tmpstab = arg[1].arg_ptr.arg_stab; + if (!stab_io(tmpstab) || !stab_io(tmpstab)->ifp || + chsize(fileno(stab_io(tmpstab)->ifp), len) < 0) + result = 0; + } + else { + int tmpfd; + + if ((tmpfd = open(str_get(ary->ary_array[sp]), 0)) < 0) + result = 0; + else { + if (chsize(tmpfd, len) < 0) + result = 0; + close(tmpfd); + } + } +#endif + + if (result) + str_sset(str,&str_yes); + else + str_sset(str,&str_undef); + STABSET(str); + ary->ary_array[sp] = str; + return sp; +#else + fatal("truncate not implemented"); +#endif +} + +int +looks_like_number(str) +STR *str; +{ + register char *s; + register char *send; + + if (!str->str_pok) + return TRUE; + s = str->str_ptr; + send = s + str->str_cur; + while (isSPACE(*s)) + s++; + if (s >= send) + return FALSE; + if (*s == '+' || *s == '-') + s++; + while (isDIGIT(*s)) + s++; + if (s == send) + return TRUE; + if (*s == '.') + s++; + else if (s == str->str_ptr) + return FALSE; + while (isDIGIT(*s)) + s++; + if (s == send) + return TRUE; + if (*s == 'e' || *s == 'E') { + s++; + if (*s == '+' || *s == '-') + s++; + while (isDIGIT(*s)) + s++; + } + while (isSPACE(*s)) + s++; + if (s >= send) + return TRUE; + return FALSE; +} + +bool +do_print(str,fp) +register STR *str; +FILE *fp; +{ + register char *tmps; + + if (!fp) { + if (dowarn) + warn("print to unopened file"); + errno = EBADF; + return FALSE; + } + if (!str) + return TRUE; + if (ofmt && + ((str->str_nok && str->str_u.str_nval != 0.0) + || (looks_like_number(str) && str_gnum(str) != 0.0) ) ) { + fprintf(fp, ofmt, str->str_u.str_nval); + return !ferror(fp); + } + else { + tmps = str_get(str); + if (*tmps == 'S' && tmps[1] == 't' && tmps[2] == 'B' && tmps[3] == '\0' + && str->str_cur == sizeof(STBP) && strlen(tmps) < str->str_cur) { + STR *tmpstr = str_mortal(&str_undef); + stab_efullname(tmpstr,((STAB*)str));/* a stab value, be nice */ + str = tmpstr; + tmps = str->str_ptr; + putc('*',fp); + } + if (str->str_cur && (fwrite(tmps,1,str->str_cur,fp) == 0 || ferror(fp))) + return FALSE; + } + return TRUE; +} + +bool +do_aprint(arg,fp,arglast) +register ARG *arg; +register FILE *fp; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int retval; + register int items = arglast[2] - sp; + + if (!fp) { + if (dowarn) + warn("print to unopened file"); + errno = EBADF; + return FALSE; + } + st += ++sp; + if (arg->arg_type == O_PRTF) { + do_sprintf(arg->arg_ptr.arg_str,items,st); + retval = do_print(arg->arg_ptr.arg_str,fp); + } + else { + retval = (items <= 0); + for (; items > 0; items--,st++) { + if (retval && ofslen) { + if (fwrite(ofs, 1, ofslen, fp) == 0 || ferror(fp)) { + retval = FALSE; + break; + } + } + if (!(retval = do_print(*st, fp))) + break; + } + if (retval && orslen) + if (fwrite(ors, 1, orslen, fp) == 0 || ferror(fp)) + retval = FALSE; + } + return retval; +} + +int +mystat(arg,str) +ARG *arg; +STR *str; +{ + STIO *stio; + + if (arg[1].arg_type & A_DONT) { + stio = stab_io(arg[1].arg_ptr.arg_stab); + if (stio && stio->ifp) { + statstab = arg[1].arg_ptr.arg_stab; + str_set(statname,""); + laststype = O_STAT; + return (laststatval = fstat(fileno(stio->ifp), &statcache)); + } + else { + if (arg[1].arg_ptr.arg_stab == defstab) + return laststatval; + if (dowarn) + warn("Stat on unopened file <%s>", + stab_ename(arg[1].arg_ptr.arg_stab)); + statstab = Nullstab; + str_set(statname,""); + return (laststatval = -1); + } + } + else { + statstab = Nullstab; + str_set(statname,str_get(str)); + laststype = O_STAT; + laststatval = stat(str_get(str),&statcache); + if (laststatval < 0 && dowarn && index(str_get(str), '\n')) + warn(warn_nl, "stat"); + return laststatval; + } +} + +int +mylstat(arg,str) +ARG *arg; +STR *str; +{ + if (arg[1].arg_type & A_DONT) { + if (arg[1].arg_ptr.arg_stab == defstab) { + if (laststype != O_LSTAT) + fatal("The stat preceding -l _ wasn't an lstat"); + return laststatval; + } + fatal("You can't use -l on a filehandle"); + } + + laststype = O_LSTAT; + statstab = Nullstab; + str_set(statname,str_get(str)); +#ifdef HAS_LSTAT + laststatval = lstat(str_get(str),&statcache); +#else + laststatval = stat(str_get(str),&statcache); +#endif + if (laststatval < 0 && dowarn && index(str_get(str), '\n')) + warn(warn_nl, "lstat"); + return laststatval; +} + +STR * +do_fttext(arg,str) +register ARG *arg; +STR *str; +{ + int i; + int len; + int odd = 0; + STDCHAR tbuf[512]; + register STDCHAR *s; + register STIO *stio; + + if (arg[1].arg_type & A_DONT) { + if (arg[1].arg_ptr.arg_stab == defstab) { + if (statstab) + stio = stab_io(statstab); + else { + str = statname; + goto really_filename; + } + } + else { + statstab = arg[1].arg_ptr.arg_stab; + str_set(statname,""); + stio = stab_io(statstab); + } + if (stio && stio->ifp) { +#if defined(STDSTDIO) || defined(atarist) /* this will work with atariST */ + fstat(fileno(stio->ifp),&statcache); + if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */ + return arg->arg_type == O_FTTEXT ? &str_no : &str_yes; + if (stio->ifp->_cnt <= 0) { + i = getc(stio->ifp); + if (i != EOF) + (void)ungetc(i,stio->ifp); + } + if (stio->ifp->_cnt <= 0) /* null file is anything */ + return &str_yes; + len = stio->ifp->_cnt + (stio->ifp->_ptr - stio->ifp->_base); + s = stio->ifp->_base; +#else + fatal("-T and -B not implemented on filehandles"); +#endif + } + else { + if (dowarn) + warn("Test on unopened file <%s>", + stab_ename(arg[1].arg_ptr.arg_stab)); + errno = EBADF; + return &str_undef; + } + } + else { + statstab = Nullstab; + str_set(statname,str_get(str)); + really_filename: + i = open(str_get(str),0); + if (i < 0) { + if (dowarn && index(str_get(str), '\n')) + warn(warn_nl, "open"); + return &str_undef; + } + fstat(i,&statcache); + len = read(i,tbuf,512); + (void)close(i); + if (len <= 0) { + if (S_ISDIR(statcache.st_mode) && arg->arg_type == O_FTTEXT) + return &str_no; /* special case NFS directories */ + return &str_yes; /* null file is anything */ + } + s = tbuf; + } + + /* now scan s to look for textiness */ + + for (i = 0; i < len; i++,s++) { + if (!*s) { /* null never allowed in text */ + odd += len; + break; + } + else if (*s & 128) + odd++; + else if (*s < 32 && + *s != '\n' && *s != '\r' && *s != '\b' && + *s != '\t' && *s != '\f' && *s != 27) + odd++; + } + + if ((odd * 10 > len) == (arg->arg_type == O_FTTEXT)) /* allow 10% odd */ + return &str_no; + else + return &str_yes; +} + +static char **Argv = Null(char **); +static char *Cmd = Nullch; + +bool +do_aexec(really,arglast) +STR *really; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register char **a; + char *tmps; + + if (items) { + New(401,Argv, items+1, char*); + a = Argv; + for (st += ++sp; items > 0; items--,st++) { + if (*st) + *a++ = str_get(*st); + else + *a++ = ""; + } + *a = Nullch; +#ifdef TAINT + if (*Argv[0] != '/') /* will execvp use PATH? */ + taintenv(); /* testing IFS here is overkill, probably */ +#endif + if (really && *(tmps = str_get(really))) + execvp(tmps,Argv); + else + execvp(Argv[0],Argv); + } + do_execfree(); + return FALSE; +} + +void +do_execfree() +{ + if (Argv) { + Safefree(Argv); + Argv = Null(char **); + } + if (Cmd) { + Safefree(Cmd); + Cmd = Nullch; + } +} + +bool +do_exec(cmd) +char *cmd; +{ + register char **a; + register char *s; + char flags[10]; + + /* save an extra exec if possible */ + +#ifdef CSH + if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) { + strcpy(flags,"-c"); + s = cmd+cshlen+3; + if (*s == 'f') { + s++; + strcat(flags,"f"); + } + if (*s == ' ') + s++; + if (*s++ == '\'') { + char *ncmd = s; + + while (*s) + s++; + if (s[-1] == '\n') + *--s = '\0'; + if (s[-1] == '\'') { + *--s = '\0'; + execl(cshname,"csh", flags,ncmd,(char*)0); + *s = '\''; + return FALSE; + } + } + } +#endif /* CSH */ + + /* see if there are shell metacharacters in it */ + + /*SUPPRESS 530*/ + for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ + if (*s == '=') + goto doshell; + for (s = cmd; *s; s++) { + if (*s != ' ' && !isALPHA(*s) && index("$&*(){}[]'\";\\|?<>~`\n",*s)) { + if (*s == '\n' && !s[1]) { + *s = '\0'; + break; + } + doshell: + execl("/bin/sh","sh","-c",cmd,(char*)0); + return FALSE; + } + } + New(402,Argv, (s - cmd) / 2 + 2, char*); + Cmd = nsavestr(cmd, s-cmd); + a = Argv; + for (s = Cmd; *s;) { + while (*s && isSPACE(*s)) s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) s++; + if (*s) + *s++ = '\0'; + } + *a = Nullch; + if (Argv[0]) { + execvp(Argv[0],Argv); + if (errno == ENOEXEC) { /* for system V NIH syndrome */ + do_execfree(); + goto doshell; + } + } + do_execfree(); + return FALSE; +} + +#ifdef HAS_SOCKET +int +do_socket(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int domain, type, protocol, fd; + + if (!stab) { + errno = EBADF; + return FALSE; + } + + stio = stab_io(stab); + if (!stio) + stio = stab_io(stab) = stio_new(); + else if (stio->ifp) + do_close(stab,FALSE); + + domain = (int)str_gnum(st[++sp]); + type = (int)str_gnum(st[++sp]); + protocol = (int)str_gnum(st[++sp]); +#ifdef TAINT + taintproper("Insecure dependency in socket"); +#endif + fd = socket(domain,type,protocol); + if (fd < 0) + return FALSE; + stio->ifp = fdopen(fd, "r"); /* stdio gets confused about sockets */ + stio->ofp = fdopen(fd, "w"); + stio->type = 's'; + if (!stio->ifp || !stio->ofp) { + if (stio->ifp) fclose(stio->ifp); + if (stio->ofp) fclose(stio->ofp); + if (!stio->ifp && !stio->ofp) close(fd); + return FALSE; + } + + return TRUE; +} + +int +do_bind(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + char *addr; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + addr = str_get(st[++sp]); +#ifdef TAINT + taintproper("Insecure dependency in bind"); +#endif + return bind(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0; + +nuts: + if (dowarn) + warn("bind() on closed fd"); + errno = EBADF; + return FALSE; + +} + +int +do_connect(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + char *addr; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + addr = str_get(st[++sp]); +#ifdef TAINT + taintproper("Insecure dependency in connect"); +#endif + return connect(fileno(stio->ifp), addr, st[sp]->str_cur) >= 0; + +nuts: + if (dowarn) + warn("connect() on closed fd"); + errno = EBADF; + return FALSE; + +} + +int +do_listen(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int backlog; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + backlog = (int)str_gnum(st[++sp]); + return listen(fileno(stio->ifp), backlog) >= 0; + +nuts: + if (dowarn) + warn("listen() on closed fd"); + errno = EBADF; + return FALSE; +} + +void +do_accept(str, nstab, gstab) +STR *str; +STAB *nstab; +STAB *gstab; +{ + register STIO *nstio; + register STIO *gstio; + int len = sizeof buf; + int fd; + + if (!nstab) + goto badexit; + if (!gstab) + goto nuts; + + gstio = stab_io(gstab); + nstio = stab_io(nstab); + + if (!gstio || !gstio->ifp) + goto nuts; + if (!nstio) + nstio = stab_io(nstab) = stio_new(); + else if (nstio->ifp) + do_close(nstab,FALSE); + + fd = accept(fileno(gstio->ifp),(struct sockaddr *)buf,&len); + if (fd < 0) + goto badexit; + nstio->ifp = fdopen(fd, "r"); + nstio->ofp = fdopen(fd, "w"); + nstio->type = 's'; + if (!nstio->ifp || !nstio->ofp) { + if (nstio->ifp) fclose(nstio->ifp); + if (nstio->ofp) fclose(nstio->ofp); + if (!nstio->ifp && !nstio->ofp) close(fd); + goto badexit; + } + + str_nset(str, buf, len); + return; + +nuts: + if (dowarn) + warn("accept() on closed fd"); + errno = EBADF; +badexit: + str_sset(str,&str_undef); + return; +} + +int +do_shutdown(stab, arglast) +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int how; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + how = (int)str_gnum(st[++sp]); + return shutdown(fileno(stio->ifp), how) >= 0; + +nuts: + if (dowarn) + warn("shutdown() on closed fd"); + errno = EBADF; + return FALSE; + +} + +int +do_sopt(optype, stab, arglast) +int optype; +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int fd; + unsigned int lvl; + unsigned int optname; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + fd = fileno(stio->ifp); + lvl = (unsigned int)str_gnum(st[sp+1]); + optname = (unsigned int)str_gnum(st[sp+2]); + switch (optype) { + case O_GSOCKOPT: + st[sp] = str_2mortal(Str_new(22,257)); + st[sp]->str_cur = 256; + st[sp]->str_pok = 1; + if (getsockopt(fd, lvl, optname, st[sp]->str_ptr, + (int*)&st[sp]->str_cur) < 0) + goto nuts; + break; + case O_SSOCKOPT: + st[sp] = st[sp+3]; + if (setsockopt(fd, lvl, optname, st[sp]->str_ptr, st[sp]->str_cur) < 0) + goto nuts; + st[sp] = &str_yes; + break; + } + + return sp; + +nuts: + if (dowarn) + warn("[gs]etsockopt() on closed fd"); + st[sp] = &str_undef; + errno = EBADF; + return sp; + +} + +int +do_getsockname(optype, stab, arglast) +int optype; +STAB *stab; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register STIO *stio; + int fd; + + if (!stab) + goto nuts; + + stio = stab_io(stab); + if (!stio || !stio->ifp) + goto nuts; + + st[sp] = str_2mortal(Str_new(22,257)); + st[sp]->str_cur = 256; + st[sp]->str_pok = 1; + fd = fileno(stio->ifp); + switch (optype) { + case O_GETSOCKNAME: + if (getsockname(fd, st[sp]->str_ptr, (int*)&st[sp]->str_cur) < 0) + goto nuts2; + break; + case O_GETPEERNAME: + if (getpeername(fd, st[sp]->str_ptr, (int*)&st[sp]->str_cur) < 0) + goto nuts2; + break; + } + + return sp; + +nuts: + if (dowarn) + warn("get{sock,peer}name() on closed fd"); + errno = EBADF; +nuts2: + st[sp] = &str_undef; + return sp; + +} + +int +do_ghent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct hostent *gethostbyname(); + struct hostent *gethostbyaddr(); +#ifdef HAS_GETHOSTENT + struct hostent *gethostent(); +#endif + struct hostent *hent; + unsigned long len; + + if (which == O_GHBYNAME) { + char *name = str_get(ary->ary_array[sp+1]); + + hent = gethostbyname(name); + } + else if (which == O_GHBYADDR) { + STR *addrstr = ary->ary_array[sp+1]; + int addrtype = (int)str_gnum(ary->ary_array[sp+2]); + char *addr = str_get(addrstr); + + hent = gethostbyaddr(addr,addrstr->str_cur,addrtype); + } + else +#ifdef HAS_GETHOSTENT + hent = gethostent(); +#else + fatal("gethostent not implemented"); +#endif + +#ifdef HOST_NOT_FOUND + if (!hent) + statusvalue = (unsigned short)h_errno & 0xffff; +#endif + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str = str_mortal(&str_undef)); + if (hent) { + if (which == O_GHBYNAME) { +#ifdef h_addr + str_nset(str, *hent->h_addr, hent->h_length); +#else + str_nset(str, hent->h_addr, hent->h_length); +#endif + } + else + str_set(str, hent->h_name); + } + return sp; + } + + if (hent) { +#ifndef lint + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, hent->h_name); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + for (elem = hent->h_aliases; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_numset(str, (double)hent->h_addrtype); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + len = hent->h_length; + str_numset(str, (double)len); +#ifdef h_addr + for (elem = hent->h_addr_list; *elem; elem++) { + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_nset(str, *elem, len); + } +#else + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_nset(str, hent->h_addr, len); +#endif /* h_addr */ +#else /* lint */ + elem = Nullch; + elem = elem; + (void)astore(ary, ++sp, str_mortal(&str_no)); +#endif /* lint */ + } + + return sp; +} + +int +do_gnent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct netent *getnetbyname(); + struct netent *getnetbyaddr(); + struct netent *getnetent(); + struct netent *nent; + + if (which == O_GNBYNAME) { + char *name = str_get(ary->ary_array[sp+1]); + + nent = getnetbyname(name); + } + else if (which == O_GNBYADDR) { + unsigned long addr = U_L(str_gnum(ary->ary_array[sp+1])); + int addrtype = (int)str_gnum(ary->ary_array[sp+2]); + + nent = getnetbyaddr((long)addr,addrtype); + } + else + nent = getnetent(); + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str = str_mortal(&str_undef)); + if (nent) { + if (which == O_GNBYNAME) + str_numset(str, (double)nent->n_net); + else + str_set(str, nent->n_name); + } + return sp; + } + + if (nent) { +#ifndef lint + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, nent->n_name); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + for (elem = nent->n_aliases; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_numset(str, (double)nent->n_addrtype); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_numset(str, (double)nent->n_net); +#else /* lint */ + elem = Nullch; + elem = elem; + (void)astore(ary, ++sp, str_mortal(&str_no)); +#endif /* lint */ + } + + return sp; +} + +int +do_gpent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct protoent *getprotobyname(); + struct protoent *getprotobynumber(); + struct protoent *getprotoent(); + struct protoent *pent; + + if (which == O_GPBYNAME) { + char *name = str_get(ary->ary_array[sp+1]); + + pent = getprotobyname(name); + } + else if (which == O_GPBYNUMBER) { + int proto = (int)str_gnum(ary->ary_array[sp+1]); + + pent = getprotobynumber(proto); + } + else + pent = getprotoent(); + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str = str_mortal(&str_undef)); + if (pent) { + if (which == O_GPBYNAME) + str_numset(str, (double)pent->p_proto); + else + str_set(str, pent->p_name); + } + return sp; + } + + if (pent) { +#ifndef lint + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, pent->p_name); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + for (elem = pent->p_aliases; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_numset(str, (double)pent->p_proto); +#else /* lint */ + elem = Nullch; + elem = elem; + (void)astore(ary, ++sp, str_mortal(&str_no)); +#endif /* lint */ + } + + return sp; +} + +int +do_gsent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct servent *getservbyname(); + struct servent *getservbynumber(); + struct servent *getservent(); + struct servent *sent; + + if (which == O_GSBYNAME) { + char *name = str_get(ary->ary_array[sp+1]); + char *proto = str_get(ary->ary_array[sp+2]); + + if (proto && !*proto) + proto = Nullch; + + sent = getservbyname(name,proto); + } + else if (which == O_GSBYPORT) { + int port = (int)str_gnum(ary->ary_array[sp+1]); + char *proto = str_get(ary->ary_array[sp+2]); + + sent = getservbyport(port,proto); + } + else + sent = getservent(); + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str = str_mortal(&str_undef)); + if (sent) { + if (which == O_GSBYNAME) { +#ifdef HAS_NTOHS + str_numset(str, (double)ntohs(sent->s_port)); +#else + str_numset(str, (double)(sent->s_port)); +#endif + } + else + str_set(str, sent->s_name); + } + return sp; + } + + if (sent) { +#ifndef lint + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, sent->s_name); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + for (elem = sent->s_aliases; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + (void)astore(ary, ++sp, str = str_mortal(&str_no)); +#ifdef HAS_NTOHS + str_numset(str, (double)ntohs(sent->s_port)); +#else + str_numset(str, (double)(sent->s_port)); +#endif + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, sent->s_proto); +#else /* lint */ + elem = Nullch; + elem = elem; + (void)astore(ary, ++sp, str_mortal(&str_no)); +#endif /* lint */ + } + + return sp; +} + +#endif /* HAS_SOCKET */ + +#ifdef HAS_SELECT +int +do_select(gimme,arglast) +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[0]; + register int i; + register int j; + register char *s; + register STR *str; + double value; + int maxlen = 0; + int nfound; + struct timeval timebuf; + struct timeval *tbuf = &timebuf; + int growsize; +#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 + int masksize; + int offset; + char *fd_sets[4]; + int k; + +#if BYTEORDER & 0xf0000 +#define ORDERBYTE (0x88888888 - BYTEORDER) +#else +#define ORDERBYTE (0x4444 - BYTEORDER) +#endif + +#endif + + for (i = 1; i <= 3; i++) { + j = st[sp+i]->str_cur; + if (maxlen < j) + maxlen = j; + } + +#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 + growsize = maxlen; /* little endians can use vecs directly */ +#else +#ifdef NFDBITS + +#ifndef NBBY +#define NBBY 8 +#endif + + masksize = NFDBITS / NBBY; +#else + masksize = sizeof(long); /* documented int, everyone seems to use long */ +#endif + growsize = maxlen + (masksize - (maxlen % masksize)); + Zero(&fd_sets[0], 4, char*); +#endif + + for (i = 1; i <= 3; i++) { + str = st[sp+i]; + j = str->str_len; + if (j < growsize) { + if (str->str_pok) { + Str_Grow(str,growsize); + s = str_get(str) + j; + while (++j <= growsize) { + *s++ = '\0'; + } + } + else if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_ptr = Nullch; + } + } +#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 + s = str->str_ptr; + if (s) { + New(403, fd_sets[i], growsize, char); + for (offset = 0; offset < growsize; offset += masksize) { + for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) + fd_sets[i][j+offset] = s[(k % masksize) + offset]; + } + } +#endif + } + str = st[sp+4]; + if (str->str_nok || str->str_pok) { + value = str_gnum(str); + if (value < 0.0) + value = 0.0; + timebuf.tv_sec = (long)value; + value -= (double)timebuf.tv_sec; + timebuf.tv_usec = (long)(value * 1000000.0); + } + else + tbuf = Null(struct timeval*); + +#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 + nfound = select( + maxlen * 8, + st[sp+1]->str_ptr, + st[sp+2]->str_ptr, + st[sp+3]->str_ptr, + tbuf); +#else + nfound = select( + maxlen * 8, + fd_sets[1], + fd_sets[2], + fd_sets[3], + tbuf); + for (i = 1; i <= 3; i++) { + if (fd_sets[i]) { + str = st[sp+i]; + s = str->str_ptr; + for (offset = 0; offset < growsize; offset += masksize) { + for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) + s[(k % masksize) + offset] = fd_sets[i][j+offset]; + } + Safefree(fd_sets[i]); + } + } +#endif + + st[++sp] = str_mortal(&str_no); + str_numset(st[sp], (double)nfound); + if (gimme == G_ARRAY && tbuf) { + value = (double)(timebuf.tv_sec) + + (double)(timebuf.tv_usec) / 1000000.0; + st[++sp] = str_mortal(&str_no); + str_numset(st[sp], value); + } + return sp; +} +#endif /* SELECT */ + +#ifdef HAS_SOCKET +int +do_spair(stab1, stab2, arglast) +STAB *stab1; +STAB *stab2; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[2]; + register STIO *stio1; + register STIO *stio2; + int domain, type, protocol, fd[2]; + + if (!stab1 || !stab2) + return FALSE; + + stio1 = stab_io(stab1); + stio2 = stab_io(stab2); + if (!stio1) + stio1 = stab_io(stab1) = stio_new(); + else if (stio1->ifp) + do_close(stab1,FALSE); + if (!stio2) + stio2 = stab_io(stab2) = stio_new(); + else if (stio2->ifp) + do_close(stab2,FALSE); + + domain = (int)str_gnum(st[++sp]); + type = (int)str_gnum(st[++sp]); + protocol = (int)str_gnum(st[++sp]); +#ifdef TAINT + taintproper("Insecure dependency in socketpair"); +#endif +#ifdef HAS_SOCKETPAIR + if (socketpair(domain,type,protocol,fd) < 0) + return FALSE; +#else + fatal("Socketpair unimplemented"); +#endif + stio1->ifp = fdopen(fd[0], "r"); + stio1->ofp = fdopen(fd[0], "w"); + stio1->type = 's'; + stio2->ifp = fdopen(fd[1], "r"); + stio2->ofp = fdopen(fd[1], "w"); + stio2->type = 's'; + if (!stio1->ifp || !stio1->ofp || !stio2->ifp || !stio2->ofp) { + if (stio1->ifp) fclose(stio1->ifp); + if (stio1->ofp) fclose(stio1->ofp); + if (!stio1->ifp && !stio1->ofp) close(fd[0]); + if (stio2->ifp) fclose(stio2->ifp); + if (stio2->ofp) fclose(stio2->ofp); + if (!stio2->ifp && !stio2->ofp) close(fd[1]); + return FALSE; + } + + return TRUE; +} + +#endif /* HAS_SOCKET */ + +int +do_gpwent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ +#ifdef I_PWD + register ARRAY *ary = stack; + register int sp = arglast[0]; + register STR *str; + struct passwd *getpwnam(); + struct passwd *getpwuid(); + struct passwd *getpwent(); + struct passwd *pwent; + + if (which == O_GPWNAM) { + char *name = str_get(ary->ary_array[sp+1]); + + pwent = getpwnam(name); + } + else if (which == O_GPWUID) { + int uid = (int)str_gnum(ary->ary_array[sp+1]); + + pwent = getpwuid(uid); + } + else + pwent = getpwent(); + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str = str_mortal(&str_undef)); + if (pwent) { + if (which == O_GPWNAM) + str_numset(str, (double)pwent->pw_uid); + else + str_set(str, pwent->pw_name); + } + return sp; + } + + if (pwent) { + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, pwent->pw_name); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, pwent->pw_passwd); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_numset(str, (double)pwent->pw_uid); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_numset(str, (double)pwent->pw_gid); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); +#ifdef PWCHANGE + str_numset(str, (double)pwent->pw_change); +#else +#ifdef PWQUOTA + str_numset(str, (double)pwent->pw_quota); +#else +#ifdef PWAGE + str_set(str, pwent->pw_age); +#endif +#endif +#endif + (void)astore(ary, ++sp, str = str_mortal(&str_no)); +#ifdef PWCLASS + str_set(str,pwent->pw_class); +#else +#ifdef PWCOMMENT + str_set(str, pwent->pw_comment); +#endif +#endif + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, pwent->pw_gecos); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, pwent->pw_dir); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, pwent->pw_shell); +#ifdef PWEXPIRE + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_numset(str, (double)pwent->pw_expire); +#endif + } + + return sp; +#else + fatal("password routines not implemented"); +#endif +} + +int +do_ggrent(which,gimme,arglast) +int which; +int gimme; +int *arglast; +{ +#ifdef I_GRP + register ARRAY *ary = stack; + register int sp = arglast[0]; + register char **elem; + register STR *str; + struct group *getgrnam(); + struct group *getgrgid(); + struct group *getgrent(); + struct group *grent; + + if (which == O_GGRNAM) { + char *name = str_get(ary->ary_array[sp+1]); + + grent = getgrnam(name); + } + else if (which == O_GGRGID) { + int gid = (int)str_gnum(ary->ary_array[sp+1]); + + grent = getgrgid(gid); + } + else + grent = getgrent(); + + if (gimme != G_ARRAY) { + astore(ary, ++sp, str = str_mortal(&str_undef)); + if (grent) { + if (which == O_GGRNAM) + str_numset(str, (double)grent->gr_gid); + else + str_set(str, grent->gr_name); + } + return sp; + } + + if (grent) { + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, grent->gr_name); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_set(str, grent->gr_passwd); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_numset(str, (double)grent->gr_gid); + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + for (elem = grent->gr_mem; *elem; elem++) { + str_cat(str, *elem); + if (elem[1]) + str_ncat(str," ",1); + } + } + + return sp; +#else + fatal("group routines not implemented"); +#endif +} + +int +do_dirop(optype,stab,gimme,arglast) +int optype; +STAB *stab; +int gimme; +int *arglast; +{ +#if defined(DIRENT) && defined(HAS_READDIR) + register ARRAY *ary = stack; + register STR **st = ary->ary_array; + register int sp = arglast[1]; + register STIO *stio; + long along; +#ifndef apollo + struct DIRENT *readdir(); +#endif + register struct DIRENT *dp; + + if (!stab) + goto nope; + if (!(stio = stab_io(stab))) + stio = stab_io(stab) = stio_new(); + if (!stio->dirp && optype != O_OPEN_DIR) + goto nope; + st[sp] = &str_yes; + switch (optype) { + case O_OPEN_DIR: + if (stio->dirp) + closedir(stio->dirp); + if (!(stio->dirp = opendir(str_get(st[sp+1])))) + goto nope; + break; + case O_READDIR: + if (gimme == G_ARRAY) { + --sp; + /*SUPPRESS 560*/ + while (dp = readdir(stio->dirp)) { +#ifdef DIRNAMLEN + (void)astore(ary,++sp, + str_2mortal(str_make(dp->d_name,dp->d_namlen))); +#else + (void)astore(ary,++sp, + str_2mortal(str_make(dp->d_name,0))); +#endif + } + } + else { + if (!(dp = readdir(stio->dirp))) + goto nope; + st[sp] = str_mortal(&str_undef); +#ifdef DIRNAMLEN + str_nset(st[sp], dp->d_name, dp->d_namlen); +#else + str_set(st[sp], dp->d_name); +#endif + } + break; +#if defined(HAS_TELLDIR) || defined(telldir) + case O_TELLDIR: { +#ifndef telldir + long telldir(); +#endif + st[sp] = str_mortal(&str_undef); + str_numset(st[sp], (double)telldir(stio->dirp)); + break; + } +#endif +#if defined(HAS_SEEKDIR) || defined(seekdir) + case O_SEEKDIR: + st[sp] = str_mortal(&str_undef); + along = (long)str_gnum(st[sp+1]); + (void)seekdir(stio->dirp,along); + break; +#endif +#if defined(HAS_REWINDDIR) || defined(rewinddir) + case O_REWINDDIR: + st[sp] = str_mortal(&str_undef); + (void)rewinddir(stio->dirp); + break; +#endif + case O_CLOSEDIR: + st[sp] = str_mortal(&str_undef); + (void)closedir(stio->dirp); + stio->dirp = 0; + break; + default: + goto phooey; + } + return sp; + +nope: + st[sp] = &str_undef; + if (!errno) + errno = EBADF; + return sp; + +#endif +phooey: + fatal("Unimplemented directory operation"); +} + +int +apply(type,arglast) +int type; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register int val; + register int val2; + register int tot = 0; + char *s; + +#ifdef TAINT + for (st += ++sp; items--; st++) + tainted |= (*st)->str_tainted; + st = stack->ary_array; + sp = arglast[1]; + items = arglast[2] - sp; +#endif + switch (type) { + case O_CHMOD: +#ifdef TAINT + taintproper("Insecure dependency in chmod"); +#endif + if (--items > 0) { + tot = items; + val = (int)str_gnum(st[++sp]); + while (items--) { + if (chmod(str_get(st[++sp]),val)) + tot--; + } + } + break; +#ifdef HAS_CHOWN + case O_CHOWN: +#ifdef TAINT + taintproper("Insecure dependency in chown"); +#endif + if (items > 2) { + items -= 2; + tot = items; + val = (int)str_gnum(st[++sp]); + val2 = (int)str_gnum(st[++sp]); + while (items--) { + if (chown(str_get(st[++sp]),val,val2)) + tot--; + } + } + break; +#endif +#ifdef HAS_KILL + case O_KILL: +#ifdef TAINT + taintproper("Insecure dependency in kill"); +#endif + if (--items > 0) { + tot = items; + s = str_get(st[++sp]); + if (isUPPER(*s)) { + if (*s == 'S' && s[1] == 'I' && s[2] == 'G') + s += 3; + if (!(val = whichsig(s))) + fatal("Unrecognized signal name \"%s\"",s); + } + else + val = (int)str_gnum(st[sp]); + if (val < 0) { + val = -val; + while (items--) { + int proc = (int)str_gnum(st[++sp]); +#ifdef HAS_KILLPG + if (killpg(proc,val)) /* BSD */ +#else + if (kill(-proc,val)) /* SYSV */ +#endif + tot--; + } + } + else { + while (items--) { + if (kill((int)(str_gnum(st[++sp])),val)) + tot--; + } + } + } + break; +#endif + case O_UNLINK: +#ifdef TAINT + taintproper("Insecure dependency in unlink"); +#endif + tot = items; + while (items--) { + s = str_get(st[++sp]); + if (euid || unsafe) { + if (UNLINK(s)) + tot--; + } + else { /* don't let root wipe out directories without -U */ +#ifdef HAS_LSTAT + if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) +#else + if (stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) +#endif + tot--; + else { + if (UNLINK(s)) + tot--; + } + } + } + break; + case O_UTIME: +#ifdef TAINT + taintproper("Insecure dependency in utime"); +#endif + if (items > 2) { +#ifdef I_UTIME + struct utimbuf utbuf; +#else + struct { + long actime; + long modtime; + } utbuf; +#endif + + Zero(&utbuf, sizeof utbuf, char); + utbuf.actime = (long)str_gnum(st[++sp]); /* time accessed */ + utbuf.modtime = (long)str_gnum(st[++sp]); /* time modified */ + items -= 2; +#ifndef lint + tot = items; + while (items--) { + if (utime(str_get(st[++sp]),&utbuf)) + tot--; + } +#endif + } + else + items = 0; + break; + } + return tot; +} + +/* Do the permissions allow some operation? Assumes statcache already set. */ + +int +cando(bit, effective, statbufp) +int bit; +int effective; +register struct stat *statbufp; +{ +#ifdef DOSISH + /* [Comments and code from Len Reed] + * MS-DOS "user" is similar to UNIX's "superuser," but can't write + * to write-protected files. The execute permission bit is set + * by the Miscrosoft C library stat() function for the following: + * .exe files + * .com files + * .bat files + * directories + * All files and directories are readable. + * Directories and special files, e.g. "CON", cannot be + * write-protected. + * [Comment by Tom Dinger -- a directory can have the write-protect + * bit set in the file system, but DOS permits changes to + * the directory anyway. In addition, all bets are off + * here for networked software, such as Novell and + * Sun's PC-NFS.] + */ + + /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat + * too so it will actually look into the files for magic numbers + */ + return (bit & statbufp->st_mode) ? TRUE : FALSE; + +#else /* ! MSDOS */ + if ((effective ? euid : uid) == 0) { /* root is special */ + if (bit == S_IXUSR) { + if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) + return TRUE; + } + else + return TRUE; /* root reads and writes anything */ + return FALSE; + } + if (statbufp->st_uid == (effective ? euid : uid) ) { + if (statbufp->st_mode & bit) + return TRUE; /* ok as "user" */ + } + else if (ingroup((int)statbufp->st_gid,effective)) { + if (statbufp->st_mode & bit >> 3) + return TRUE; /* ok as "group" */ + } + else if (statbufp->st_mode & bit >> 6) + return TRUE; /* ok as "other" */ + return FALSE; +#endif /* ! MSDOS */ +} + +int +ingroup(testgid,effective) +int testgid; +int effective; +{ + if (testgid == (effective ? egid : gid)) + return TRUE; +#ifdef HAS_GETGROUPS +#ifndef NGROUPS +#define NGROUPS 32 +#endif + { + GROUPSTYPE gary[NGROUPS]; + int anum; + + anum = getgroups(NGROUPS,gary); + while (--anum >= 0) + if (gary[anum] == testgid) + return TRUE; + } +#endif + return FALSE; +} + +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) + +int +do_ipcget(optype, arglast) +int optype; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[0]; + key_t key; + int n, flags; + + key = (key_t)str_gnum(st[++sp]); + n = (optype == O_MSGGET) ? 0 : (int)str_gnum(st[++sp]); + flags = (int)str_gnum(st[++sp]); + errno = 0; + switch (optype) + { +#ifdef HAS_MSG + case O_MSGGET: + return msgget(key, flags); +#endif +#ifdef HAS_SEM + case O_SEMGET: + return semget(key, n, flags); +#endif +#ifdef HAS_SHM + case O_SHMGET: + return shmget(key, n, flags); +#endif +#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) + default: + fatal("%s not implemented", opname[optype]); +#endif + } + return -1; /* should never happen */ +} + +int +do_ipcctl(optype, arglast) +int optype; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[0]; + STR *astr; + char *a; + int id, n, cmd, infosize, getinfo, ret; + + id = (int)str_gnum(st[++sp]); + n = (optype == O_SEMCTL) ? (int)str_gnum(st[++sp]) : 0; + cmd = (int)str_gnum(st[++sp]); + astr = st[++sp]; + + infosize = 0; + getinfo = (cmd == IPC_STAT); + + switch (optype) + { +#ifdef HAS_MSG + case O_MSGCTL: + if (cmd == IPC_STAT || cmd == IPC_SET) + infosize = sizeof(struct msqid_ds); + break; +#endif +#ifdef HAS_SHM + case O_SHMCTL: + if (cmd == IPC_STAT || cmd == IPC_SET) + infosize = sizeof(struct shmid_ds); + break; +#endif +#ifdef HAS_SEM + case O_SEMCTL: + if (cmd == IPC_STAT || cmd == IPC_SET) + infosize = sizeof(struct semid_ds); + else if (cmd == GETALL || cmd == SETALL) + { + struct semid_ds semds; + if (semctl(id, 0, IPC_STAT, (union semun)&semds) == -1) + return -1; + getinfo = (cmd == GETALL); + infosize = semds.sem_nsems * sizeof(short); + /* "short" is technically wrong but much more portable + than guessing about u_?short(_t)? */ + } + break; +#endif +#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) + default: + fatal("%s not implemented", opname[optype]); +#endif + } + + if (infosize) + { + if (getinfo) + { + STR_GROW(astr, infosize+1); + a = str_get(astr); + } + else + { + a = str_get(astr); + if (astr->str_cur != infosize) + { + errno = EINVAL; + return -1; + } + } + } + else + { + int i = (int)str_gnum(astr); + a = (char *)i; /* ouch */ + } + errno = 0; + switch (optype) + { +#ifdef HAS_MSG + case O_MSGCTL: + ret = msgctl(id, cmd, (struct msqid_ds *)a); + break; +#endif +#ifdef HAS_SEM + case O_SEMCTL: + ret = semctl(id, n, cmd, (union semun)((int)a)); + break; +#endif +#ifdef HAS_SHM + case O_SHMCTL: + ret = shmctl(id, cmd, (struct shmid_ds *)a); + break; +#endif + } + if (getinfo && ret >= 0) { + astr->str_cur = infosize; + astr->str_ptr[infosize] = '\0'; + } + return ret; +} + +int +do_msgsnd(arglast) +int *arglast; +{ +#ifdef HAS_MSG + register STR **st = stack->ary_array; + register int sp = arglast[0]; + STR *mstr; + char *mbuf; + int id, msize, flags; + + id = (int)str_gnum(st[++sp]); + mstr = st[++sp]; + flags = (int)str_gnum(st[++sp]); + mbuf = str_get(mstr); + if ((msize = mstr->str_cur - sizeof(long)) < 0) { + errno = EINVAL; + return -1; + } + errno = 0; + return msgsnd(id, (struct msgbuf *)mbuf, msize, flags); +#else + fatal("msgsnd not implemented"); +#endif +} + +int +do_msgrcv(arglast) +int *arglast; +{ +#ifdef HAS_MSG + register STR **st = stack->ary_array; + register int sp = arglast[0]; + STR *mstr; + char *mbuf; + long mtype; + int id, msize, flags, ret; + + id = (int)str_gnum(st[++sp]); + mstr = st[++sp]; + msize = (int)str_gnum(st[++sp]); + mtype = (long)str_gnum(st[++sp]); + flags = (int)str_gnum(st[++sp]); + mbuf = str_get(mstr); + if (mstr->str_cur < sizeof(long)+msize+1) { + STR_GROW(mstr, sizeof(long)+msize+1); + mbuf = str_get(mstr); + } + errno = 0; + ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); + if (ret >= 0) { + mstr->str_cur = sizeof(long)+ret; + mstr->str_ptr[sizeof(long)+ret] = '\0'; + } + return ret; +#else + fatal("msgrcv not implemented"); +#endif +} + +int +do_semop(arglast) +int *arglast; +{ +#ifdef HAS_SEM + register STR **st = stack->ary_array; + register int sp = arglast[0]; + STR *opstr; + char *opbuf; + int id, opsize; + + id = (int)str_gnum(st[++sp]); + opstr = st[++sp]; + opbuf = str_get(opstr); + opsize = opstr->str_cur; + if (opsize < sizeof(struct sembuf) + || (opsize % sizeof(struct sembuf)) != 0) { + errno = EINVAL; + return -1; + } + errno = 0; + return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf)); +#else + fatal("semop not implemented"); +#endif +} + +int +do_shmio(optype, arglast) +int optype; +int *arglast; +{ +#ifdef HAS_SHM + register STR **st = stack->ary_array; + register int sp = arglast[0]; + STR *mstr; + char *mbuf, *shm; + int id, mpos, msize; + struct shmid_ds shmds; +#ifndef VOIDSHMAT + extern char *shmat(); +#endif + + id = (int)str_gnum(st[++sp]); + mstr = st[++sp]; + mpos = (int)str_gnum(st[++sp]); + msize = (int)str_gnum(st[++sp]); + errno = 0; + if (shmctl(id, IPC_STAT, &shmds) == -1) + return -1; + if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) { + errno = EFAULT; /* can't do as caller requested */ + return -1; + } + shm = (char*)shmat(id, (char*)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0); + if (shm == (char *)-1) /* I hate System V IPC, I really do */ + return -1; + mbuf = str_get(mstr); + if (optype == O_SHMREAD) { + if (mstr->str_cur < msize) { + STR_GROW(mstr, msize+1); + mbuf = str_get(mstr); + } + Copy(shm + mpos, mbuf, msize, char); + mstr->str_cur = msize; + mstr->str_ptr[msize] = '\0'; + } + else { + int n; + + if ((n = mstr->str_cur) > msize) + n = msize; + Copy(mbuf, shm + mpos, n, char); + if (n < msize) + memzero(shm + mpos + n, msize - n); + } + return shmdt(shm); +#else + fatal("shm I/O not implemented"); +#endif +} + +#endif /* SYSV IPC */ diff --git a/gnu/usr.bin/perl/perl/dolist.c b/gnu/usr.bin/perl/perl/dolist.c new file mode 100644 index 0000000..f966479 --- /dev/null +++ b/gnu/usr.bin/perl/perl/dolist.c @@ -0,0 +1,1973 @@ +/* $RCSfile: dolist.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:36 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: dolist.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:36 nate + * PERL! + * + * Revision 4.0.1.5 92/06/08 13:13:27 lwall + * patch20: g pattern modifer sometimes returned extra values + * patch20: m/$pattern/g didn't work + * patch20: pattern modifiers i and o didn't interact right + * patch20: @ in unpack failed too often + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: slice on null list in scalar context returned random value + * patch20: splice with negative offset didn't work with $[ = 1 + * patch20: fixed some memory leaks in splice + * patch20: scalar keys %array now counts keys for you + * + * Revision 4.0.1.4 91/11/11 16:33:19 lwall + * patch19: added little-endian pack/unpack options + * patch19: sort $subname was busted by changes in 4.018 + * + * Revision 4.0.1.3 91/11/05 17:07:02 lwall + * patch11: prepared for ctype implementations that don't define isascii() + * patch11: /$foo/o optimizer could access deallocated data + * patch11: certain optimizations of //g in array context returned too many values + * patch11: regexp with no parens in array context returned wacky $`, $& and $' + * patch11: $' not set right on some //g + * patch11: added some support for 64-bit integers + * patch11: grep of a split lost its values + * patch11: added sort {} LIST + * patch11: multiple reallocations now avoided in 1 .. 100000 + * + * Revision 4.0.1.2 91/06/10 01:22:15 lwall + * patch10: //g only worked first time through + * + * Revision 4.0.1.1 91/06/07 10:58:28 lwall + * patch4: new copyright notice + * patch4: added global modifier for pattern matches + * patch4: // wouldn't use previous pattern if it started with a null character + * patch4: //o and s///o now optimize themselves fully at runtime + * patch4: $` was busted inside s/// + * patch4: caller($arg) didn't work except under debugger + * + * Revision 4.0 91/03/20 01:08:03 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +static int sortcmp(); +static int sortsub(); + +#ifdef BUGGY_MSC + #pragma function(memcmp) +#endif /* BUGGY_MSC */ + +int +do_match(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register SPAT *spat = arg[2].arg_ptr.arg_spat; + register char *t; + register int sp = arglast[0] + 1; + STR *srchstr = st[sp]; + register char *s = str_get(st[sp]); + char *strend = s + st[sp]->str_cur; + STR *tmpstr; + char *myhint = hint; + int global; + int safebase; + char *truebase = s; + register REGEXP *rx = spat->spat_regexp; + + hint = Nullch; + if (!spat) { + if (gimme == G_ARRAY) + return --sp; + str_set(str,Yes); + STABSET(str); + st[sp] = str; + return sp; + } + global = spat->spat_flags & SPAT_GLOBAL; + safebase = (gimme == G_ARRAY) || global; + if (!s) + fatal("panic: do_match"); + if (spat->spat_flags & SPAT_USED) { +#ifdef DEBUGGING + if (debug & 8) + deb("2.SPAT USED\n"); +#endif + if (gimme == G_ARRAY) + return --sp; + str_set(str,No); + STABSET(str); + st[sp] = str; + return sp; + } + --sp; + if (spat->spat_runtime) { + nointrp = "|)"; + sp = eval(spat->spat_runtime,G_SCALAR,sp); + st = stack->ary_array; + t = str_get(tmpstr = st[sp--]); + nointrp = ""; +#ifdef DEBUGGING + if (debug & 8) + deb("2.SPAT /%s/\n",t); +#endif + if (!global && rx) + regfree(rx); + spat->spat_regexp = Null(REGEXP*); /* crucial if regcomp aborts */ + spat->spat_regexp = regcomp(t,t+tmpstr->str_cur, + spat->spat_flags & SPAT_FOLD); + if (!spat->spat_regexp->prelen && lastspat) + spat = lastspat; + if (spat->spat_flags & SPAT_KEEP) { + if (!(spat->spat_flags & SPAT_FOLD)) + scanconst(spat,spat->spat_regexp->precomp, + spat->spat_regexp->prelen); + if (spat->spat_runtime) + arg_free(spat->spat_runtime); /* it won't change, so */ + spat->spat_runtime = Nullarg; /* no point compiling again */ + hoistmust(spat); + if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) { + curcmd->c_flags &= ~CF_OPTIMIZE; + opt_arg(curcmd, 1, curcmd->c_type == C_EXPR); + } + } + if (global) { + if (rx) { + if (rx->startp[0]) { + s = rx->endp[0]; + if (s == rx->startp[0]) + s++; + if (s > strend) { + regfree(rx); + rx = spat->spat_regexp; + goto nope; + } + } + regfree(rx); + } + } + else if (!spat->spat_regexp->nparens) + gimme = G_SCALAR; /* accidental array context? */ + rx = spat->spat_regexp; + if (regexec(rx, s, strend, s, 0, + srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr, + safebase)) { + if (rx->subbase || global) + curspat = spat; + lastspat = spat; + goto gotcha; + } + else { + if (gimme == G_ARRAY) + return sp; + str_sset(str,&str_no); + STABSET(str); + st[++sp] = str; + return sp; + } + } + else { +#ifdef DEBUGGING + if (debug & 8) { + char ch; + + if (spat->spat_flags & SPAT_ONCE) + ch = '?'; + else + ch = '/'; + deb("2.SPAT %c%s%c\n",ch,rx->precomp,ch); + } +#endif + if (!rx->prelen && lastspat) { + spat = lastspat; + rx = spat->spat_regexp; + } + t = s; + play_it_again: + if (global && rx->startp[0]) { + t = s = rx->endp[0]; + if (s == rx->startp[0]) + s++,t++; + if (s > strend) + goto nope; + } + if (myhint) { + if (myhint < s || myhint > strend) + fatal("panic: hint in do_match"); + s = myhint; + if (rx->regback >= 0) { + s -= rx->regback; + if (s < t) + s = t; + } + else + s = t; + } + else if (spat->spat_short) { + if (spat->spat_flags & SPAT_SCANFIRST) { + if (srchstr->str_pok & SP_STUDIED) { + if (screamfirst[spat->spat_short->str_rare] < 0) + goto nope; + else if (!(s = screaminstr(srchstr,spat->spat_short))) + goto nope; + else if (spat->spat_flags & SPAT_ALL) + goto yup; + } +#ifndef lint + else if (!(s = fbminstr((unsigned char*)s, + (unsigned char*)strend, spat->spat_short))) + goto nope; +#endif + else if (spat->spat_flags & SPAT_ALL) + goto yup; + if (s && rx->regback >= 0) { + ++spat->spat_short->str_u.str_useful; + s -= rx->regback; + if (s < t) + s = t; + } + else + s = t; + } + else if (!multiline && (*spat->spat_short->str_ptr != *s || + bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) )) + goto nope; + if (--spat->spat_short->str_u.str_useful < 0) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; /* opt is being useless */ + } + } + if (!rx->nparens && !global) { + gimme = G_SCALAR; /* accidental array context? */ + safebase = FALSE; + } + if (regexec(rx, s, strend, truebase, 0, + srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr, + safebase)) { + if (rx->subbase || global) + curspat = spat; + lastspat = spat; + if (spat->spat_flags & SPAT_ONCE) + spat->spat_flags |= SPAT_USED; + goto gotcha; + } + else { + if (global) + rx->startp[0] = Nullch; + if (gimme == G_ARRAY) + return sp; + str_sset(str,&str_no); + STABSET(str); + st[++sp] = str; + return sp; + } + } + /*NOTREACHED*/ + + gotcha: + if (gimme == G_ARRAY) { + int iters, i, len; + + iters = rx->nparens; + if (global && !iters) + i = 1; + else + i = 0; + if (sp + iters + i >= stack->ary_max) { + astore(stack,sp + iters + i, Nullstr); + st = stack->ary_array; /* possibly realloced */ + } + + for (i = !i; i <= iters; i++) { + st[++sp] = str_mortal(&str_no); + /*SUPPRESS 560*/ + if (s = rx->startp[i]) { + len = rx->endp[i] - s; + if (len > 0) + str_nset(st[sp],s,len); + } + } + if (global) { + truebase = rx->subbeg; + goto play_it_again; + } + return sp; + } + else { + str_sset(str,&str_yes); + STABSET(str); + st[++sp] = str; + return sp; + } + +yup: + ++spat->spat_short->str_u.str_useful; + lastspat = spat; + if (spat->spat_flags & SPAT_ONCE) + spat->spat_flags |= SPAT_USED; + if (global) { + rx->subbeg = t; + rx->subend = strend; + rx->startp[0] = s; + rx->endp[0] = s + spat->spat_short->str_cur; + curspat = spat; + goto gotcha; + } + if (sawampersand) { + char *tmps; + + if (rx->subbase) + Safefree(rx->subbase); + tmps = rx->subbase = nsavestr(t,strend-t); + rx->subbeg = tmps; + rx->subend = tmps + (strend-t); + tmps = rx->startp[0] = tmps + (s - t); + rx->endp[0] = tmps + spat->spat_short->str_cur; + curspat = spat; + } + str_sset(str,&str_yes); + STABSET(str); + st[++sp] = str; + return sp; + +nope: + rx->startp[0] = Nullch; + if (spat->spat_short) + ++spat->spat_short->str_u.str_useful; + if (gimme == G_ARRAY) + return sp; + str_sset(str,&str_no); + STABSET(str); + st[++sp] = str; + return sp; +} + +#ifdef BUGGY_MSC + #pragma intrinsic(memcmp) +#endif /* BUGGY_MSC */ + +int +do_split(str,spat,limit,gimme,arglast) +STR *str; +register SPAT *spat; +register int limit; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + STR **st = ary->ary_array; + register int sp = arglast[0] + 1; + register char *s = str_get(st[sp]); + char *strend = s + st[sp--]->str_cur; + register STR *dstr; + register char *m; + int iters = 0; + int maxiters = (strend - s) + 10; + int i; + char *orig; + int origlimit = limit; + int realarray = 0; + + if (!spat || !s) + fatal("panic: do_split"); + else if (spat->spat_runtime) { + nointrp = "|)"; + sp = eval(spat->spat_runtime,G_SCALAR,sp); + st = stack->ary_array; + m = str_get(dstr = st[sp--]); + nointrp = ""; + if (*m == ' ' && dstr->str_cur == 1) { + str_set(dstr,"\\s+"); + m = dstr->str_ptr; + spat->spat_flags |= SPAT_SKIPWHITE; + } + if (spat->spat_regexp) { + regfree(spat->spat_regexp); + spat->spat_regexp = Null(REGEXP*); /* avoid possible double free */ + } + spat->spat_regexp = regcomp(m,m+dstr->str_cur, + spat->spat_flags & SPAT_FOLD); + if (spat->spat_flags & SPAT_KEEP || + (spat->spat_runtime->arg_type == O_ITEM && + (spat->spat_runtime[1].arg_type & A_MASK) == A_SINGLE) ) { + arg_free(spat->spat_runtime); /* it won't change, so */ + spat->spat_runtime = Nullarg; /* no point compiling again */ + } + } +#ifdef DEBUGGING + if (debug & 8) { + deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); + } +#endif + ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab); + if (ary && (gimme != G_ARRAY || (spat->spat_flags & SPAT_ONCE))) { + realarray = 1; + if (!(ary->ary_flags & ARF_REAL)) { + ary->ary_flags |= ARF_REAL; + for (i = ary->ary_fill; i >= 0; i--) + ary->ary_array[i] = Nullstr; /* don't free mere refs */ + } + ary->ary_fill = -1; + sp = -1; /* temporarily switch stacks */ + } + else + ary = stack; + orig = s; + if (spat->spat_flags & SPAT_SKIPWHITE) { + while (isSPACE(*s)) + s++; + } + if (!limit) + limit = maxiters + 2; + if (strEQ("\\s+",spat->spat_regexp->precomp)) { + while (--limit) { + /*SUPPRESS 530*/ + for (m = s; m < strend && !isSPACE(*m); m++) ; + if (m >= strend) + break; + dstr = Str_new(30,m-s); + str_nset(dstr,s,m-s); + if (!realarray) + str_2mortal(dstr); + (void)astore(ary, ++sp, dstr); + /*SUPPRESS 530*/ + for (s = m + 1; s < strend && isSPACE(*s); s++) ; + } + } + else if (strEQ("^",spat->spat_regexp->precomp)) { + while (--limit) { + /*SUPPRESS 530*/ + for (m = s; m < strend && *m != '\n'; m++) ; + m++; + if (m >= strend) + break; + dstr = Str_new(30,m-s); + str_nset(dstr,s,m-s); + if (!realarray) + str_2mortal(dstr); + (void)astore(ary, ++sp, dstr); + s = m; + } + } + else if (spat->spat_short) { + i = spat->spat_short->str_cur; + if (i == 1) { + int fold = (spat->spat_flags & SPAT_FOLD); + + i = *spat->spat_short->str_ptr; + if (fold && isUPPER(i)) + i = tolower(i); + while (--limit) { + if (fold) { + for ( m = s; + m < strend && *m != i && + (!isUPPER(*m) || tolower(*m) != i); + m++) /*SUPPRESS 530*/ + ; + } + else /*SUPPRESS 530*/ + for (m = s; m < strend && *m != i; m++) ; + if (m >= strend) + break; + dstr = Str_new(30,m-s); + str_nset(dstr,s,m-s); + if (!realarray) + str_2mortal(dstr); + (void)astore(ary, ++sp, dstr); + s = m + 1; + } + } + else { +#ifndef lint + while (s < strend && --limit && + (m=fbminstr((unsigned char*)s, (unsigned char*)strend, + spat->spat_short)) ) +#endif + { + dstr = Str_new(31,m-s); + str_nset(dstr,s,m-s); + if (!realarray) + str_2mortal(dstr); + (void)astore(ary, ++sp, dstr); + s = m + i; + } + } + } + else { + maxiters += (strend - s) * spat->spat_regexp->nparens; + while (s < strend && --limit && + regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) { + if (spat->spat_regexp->subbase + && spat->spat_regexp->subbase != orig) { + m = s; + s = orig; + orig = spat->spat_regexp->subbase; + s = orig + (m - s); + strend = s + (strend - m); + } + m = spat->spat_regexp->startp[0]; + dstr = Str_new(32,m-s); + str_nset(dstr,s,m-s); + if (!realarray) + str_2mortal(dstr); + (void)astore(ary, ++sp, dstr); + if (spat->spat_regexp->nparens) { + for (i = 1; i <= spat->spat_regexp->nparens; i++) { + s = spat->spat_regexp->startp[i]; + m = spat->spat_regexp->endp[i]; + dstr = Str_new(33,m-s); + str_nset(dstr,s,m-s); + if (!realarray) + str_2mortal(dstr); + (void)astore(ary, ++sp, dstr); + } + } + s = spat->spat_regexp->endp[0]; + } + } + if (realarray) + iters = sp + 1; + else + iters = sp - arglast[0]; + if (iters > maxiters) + fatal("Split loop"); + if (s < strend || origlimit) { /* keep field after final delim? */ + dstr = Str_new(34,strend-s); + str_nset(dstr,s,strend-s); + if (!realarray) + str_2mortal(dstr); + (void)astore(ary, ++sp, dstr); + iters++; + } + else { +#ifndef I286x + while (iters > 0 && ary->ary_array[sp]->str_cur == 0) + iters--,sp--; +#else + char *zaps; + int zapb; + + if (iters > 0) { + zaps = str_get(afetch(ary,sp,FALSE)); + zapb = (int) *zaps; + } + + while (iters > 0 && (!zapb)) { + iters--,sp--; + if (iters > 0) { + zaps = str_get(afetch(ary,iters-1,FALSE)); + zapb = (int) *zaps; + } + } +#endif + } + if (realarray) { + ary->ary_fill = sp; + if (gimme == G_ARRAY) { + sp++; + astore(stack, arglast[0] + 1 + sp, Nullstr); + Copy(ary->ary_array, stack->ary_array + arglast[0] + 1, sp, STR*); + return arglast[0] + sp; + } + } + else { + if (gimme == G_ARRAY) + return sp; + } + sp = arglast[0] + 1; + str_numset(str,(double)iters); + STABSET(str); + st[sp] = str; + return sp; +} + +int +do_unpack(str,gimme,arglast) +STR *str; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register int sp = arglast[0] + 1; + register char *pat = str_get(st[sp++]); + register char *s = str_get(st[sp]); + char *strend = s + st[sp--]->str_cur; + char *strbeg = s; + register char *patend = pat + st[sp]->str_cur; + int datumtype; + register int len; + register int bits; + + /* These must not be in registers: */ + short ashort; + int aint; + long along; +#ifdef QUAD + quad aquad; +#endif + unsigned short aushort; + unsigned int auint; + unsigned long aulong; +#ifdef QUAD + unsigned quad auquad; +#endif + char *aptr; + float afloat; + double adouble; + int checksum = 0; + unsigned long culong; + double cdouble; + + if (gimme != G_ARRAY) { /* arrange to do first one only */ + /*SUPPRESS 530*/ + for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; + if (index("aAbBhH", *patend) || *pat == '%') { + patend++; + while (isDIGIT(*patend) || *patend == '*') + patend++; + } + else + patend++; + } + sp--; + while (pat < patend) { + reparse: + datumtype = *pat++; + if (pat >= patend) + len = 1; + else if (*pat == '*') { + len = strend - strbeg; /* long enough */ + pat++; + } + else if (isDIGIT(*pat)) { + len = *pat++ - '0'; + while (isDIGIT(*pat)) + len = (len * 10) + (*pat++ - '0'); + } + else + len = (datumtype != '@'); + switch(datumtype) { + default: + break; + case '%': + if (len == 1 && pat[-1] != '1') + len = 16; + checksum = len; + culong = 0; + cdouble = 0; + if (pat < patend) + goto reparse; + break; + case '@': + if (len > strend - strbeg) + fatal("@ outside of string"); + s = strbeg + len; + break; + case 'X': + if (len > s - strbeg) + fatal("X outside of string"); + s -= len; + break; + case 'x': + if (len > strend - s) + fatal("x outside of string"); + s += len; + break; + case 'A': + case 'a': + if (len > strend - s) + len = strend - s; + if (checksum) + goto uchar_checksum; + str = Str_new(35,len); + str_nset(str,s,len); + s += len; + if (datumtype == 'A') { + aptr = s; /* borrow register */ + s = str->str_ptr + len - 1; + while (s >= str->str_ptr && (!*s || isSPACE(*s))) + s--; + *++s = '\0'; + str->str_cur = s - str->str_ptr; + s = aptr; /* unborrow register */ + } + (void)astore(stack, ++sp, str_2mortal(str)); + break; + case 'B': + case 'b': + if (pat[-1] == '*' || len > (strend - s) * 8) + len = (strend - s) * 8; + str = Str_new(35, len + 1); + str->str_cur = len; + str->str_pok = 1; + aptr = pat; /* borrow register */ + pat = str->str_ptr; + if (datumtype == 'b') { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 7) /*SUPPRESS 595*/ + bits >>= 1; + else + bits = *s++; + *pat++ = '0' + (bits & 1); + } + } + else { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 7) + bits <<= 1; + else + bits = *s++; + *pat++ = '0' + ((bits & 128) != 0); + } + } + *pat = '\0'; + pat = aptr; /* unborrow register */ + (void)astore(stack, ++sp, str_2mortal(str)); + break; + case 'H': + case 'h': + if (pat[-1] == '*' || len > (strend - s) * 2) + len = (strend - s) * 2; + str = Str_new(35, len + 1); + str->str_cur = len; + str->str_pok = 1; + aptr = pat; /* borrow register */ + pat = str->str_ptr; + if (datumtype == 'h') { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 1) + bits >>= 4; + else + bits = *s++; + *pat++ = hexdigit[bits & 15]; + } + } + else { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 1) + bits <<= 4; + else + bits = *s++; + *pat++ = hexdigit[(bits >> 4) & 15]; + } + } + *pat = '\0'; + pat = aptr; /* unborrow register */ + (void)astore(stack, ++sp, str_2mortal(str)); + break; + case 'c': + if (len > strend - s) + len = strend - s; + if (checksum) { + while (len-- > 0) { + aint = *s++; + if (aint >= 128) /* fake up signed chars */ + aint -= 256; + culong += aint; + } + } + else { + while (len-- > 0) { + aint = *s++; + if (aint >= 128) /* fake up signed chars */ + aint -= 256; + str = Str_new(36,0); + str_numset(str,(double)aint); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 'C': + if (len > strend - s) + len = strend - s; + if (checksum) { + uchar_checksum: + while (len-- > 0) { + auint = *s++ & 255; + culong += auint; + } + } + else { + while (len-- > 0) { + auint = *s++ & 255; + str = Str_new(37,0); + str_numset(str,(double)auint); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 's': + along = (strend - s) / sizeof(short); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s,&ashort,1,short); + s += sizeof(short); + culong += ashort; + } + } + else { + while (len-- > 0) { + Copy(s,&ashort,1,short); + s += sizeof(short); + str = Str_new(38,0); + str_numset(str,(double)ashort); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 'v': + case 'n': + case 'S': + along = (strend - s) / sizeof(unsigned short); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s,&aushort,1,unsigned short); + s += sizeof(unsigned short); +#ifdef HAS_NTOHS + if (datumtype == 'n') + aushort = ntohs(aushort); +#endif +#ifdef HAS_VTOHS + if (datumtype == 'v') + aushort = vtohs(aushort); +#endif + culong += aushort; + } + } + else { + while (len-- > 0) { + Copy(s,&aushort,1,unsigned short); + s += sizeof(unsigned short); + str = Str_new(39,0); +#ifdef HAS_NTOHS + if (datumtype == 'n') + aushort = ntohs(aushort); +#endif +#ifdef HAS_VTOHS + if (datumtype == 'v') + aushort = vtohs(aushort); +#endif + str_numset(str,(double)aushort); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 'i': + along = (strend - s) / sizeof(int); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s,&aint,1,int); + s += sizeof(int); + if (checksum > 32) + cdouble += (double)aint; + else + culong += aint; + } + } + else { + while (len-- > 0) { + Copy(s,&aint,1,int); + s += sizeof(int); + str = Str_new(40,0); + str_numset(str,(double)aint); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 'I': + along = (strend - s) / sizeof(unsigned int); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s,&auint,1,unsigned int); + s += sizeof(unsigned int); + if (checksum > 32) + cdouble += (double)auint; + else + culong += auint; + } + } + else { + while (len-- > 0) { + Copy(s,&auint,1,unsigned int); + s += sizeof(unsigned int); + str = Str_new(41,0); + str_numset(str,(double)auint); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 'l': + along = (strend - s) / sizeof(long); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s,&along,1,long); + s += sizeof(long); + if (checksum > 32) + cdouble += (double)along; + else + culong += along; + } + } + else { + while (len-- > 0) { + Copy(s,&along,1,long); + s += sizeof(long); + str = Str_new(42,0); + str_numset(str,(double)along); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 'V': + case 'N': + case 'L': + along = (strend - s) / sizeof(unsigned long); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s,&aulong,1,unsigned long); + s += sizeof(unsigned long); +#ifdef HAS_NTOHL + if (datumtype == 'N') + aulong = ntohl(aulong); +#endif +#ifdef HAS_VTOHL + if (datumtype == 'V') + aulong = vtohl(aulong); +#endif + if (checksum > 32) + cdouble += (double)aulong; + else + culong += aulong; + } + } + else { + while (len-- > 0) { + Copy(s,&aulong,1,unsigned long); + s += sizeof(unsigned long); + str = Str_new(43,0); +#ifdef HAS_NTOHL + if (datumtype == 'N') + aulong = ntohl(aulong); +#endif +#ifdef HAS_VTOHL + if (datumtype == 'V') + aulong = vtohl(aulong); +#endif + str_numset(str,(double)aulong); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 'p': + along = (strend - s) / sizeof(char*); + if (len > along) + len = along; + while (len-- > 0) { + if (sizeof(char*) > strend - s) + break; + else { + Copy(s,&aptr,1,char*); + s += sizeof(char*); + } + str = Str_new(44,0); + if (aptr) + str_set(str,aptr); + (void)astore(stack, ++sp, str_2mortal(str)); + } + break; +#ifdef QUAD + case 'q': + while (len-- > 0) { + if (s + sizeof(quad) > strend) + aquad = 0; + else { + Copy(s,&aquad,1,quad); + s += sizeof(quad); + } + str = Str_new(42,0); + str_numset(str,(double)aquad); + (void)astore(stack, ++sp, str_2mortal(str)); + } + break; + case 'Q': + while (len-- > 0) { + if (s + sizeof(unsigned quad) > strend) + auquad = 0; + else { + Copy(s,&auquad,1,unsigned quad); + s += sizeof(unsigned quad); + } + str = Str_new(43,0); + str_numset(str,(double)auquad); + (void)astore(stack, ++sp, str_2mortal(str)); + } + break; +#endif + /* float and double added gnb@melba.bby.oz.au 22/11/89 */ + case 'f': + case 'F': + along = (strend - s) / sizeof(float); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &afloat,1, float); + s += sizeof(float); + cdouble += afloat; + } + } + else { + while (len-- > 0) { + Copy(s, &afloat,1, float); + s += sizeof(float); + str = Str_new(47, 0); + str_numset(str, (double)afloat); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 'd': + case 'D': + along = (strend - s) / sizeof(double); + if (len > along) + len = along; + if (checksum) { + while (len-- > 0) { + Copy(s, &adouble,1, double); + s += sizeof(double); + cdouble += adouble; + } + } + else { + while (len-- > 0) { + Copy(s, &adouble,1, double); + s += sizeof(double); + str = Str_new(48, 0); + str_numset(str, (double)adouble); + (void)astore(stack, ++sp, str_2mortal(str)); + } + } + break; + case 'u': + along = (strend - s) * 3 / 4; + str = Str_new(42,along); + while (s < strend && *s > ' ' && *s < 'a') { + int a,b,c,d; + char hunk[4]; + + hunk[3] = '\0'; + len = (*s++ - ' ') & 077; + while (len > 0) { + if (s < strend && *s >= ' ') + a = (*s++ - ' ') & 077; + else + a = 0; + if (s < strend && *s >= ' ') + b = (*s++ - ' ') & 077; + else + b = 0; + if (s < strend && *s >= ' ') + c = (*s++ - ' ') & 077; + else + c = 0; + if (s < strend && *s >= ' ') + d = (*s++ - ' ') & 077; + else + d = 0; + hunk[0] = a << 2 | b >> 4; + hunk[1] = b << 4 | c >> 2; + hunk[2] = c << 6 | d; + str_ncat(str,hunk, len > 3 ? 3 : len); + len -= 3; + } + if (*s == '\n') + s++; + else if (s[1] == '\n') /* possible checksum byte */ + s += 2; + } + (void)astore(stack, ++sp, str_2mortal(str)); + break; + } + if (checksum) { + str = Str_new(42,0); + if (index("fFdD", datumtype) || + (checksum > 32 && index("iIlLN", datumtype)) ) { + double modf(); + double trouble; + + adouble = 1.0; + while (checksum >= 16) { + checksum -= 16; + adouble *= 65536.0; + } + while (checksum >= 4) { + checksum -= 4; + adouble *= 16.0; + } + while (checksum--) + adouble *= 2.0; + along = (1 << checksum) - 1; + while (cdouble < 0.0) + cdouble += adouble; + cdouble = modf(cdouble / adouble, &trouble) * adouble; + str_numset(str,cdouble); + } + else { + if (checksum < 32) { + along = (1 << checksum) - 1; + culong &= (unsigned long)along; + } + str_numset(str,(double)culong); + } + (void)astore(stack, ++sp, str_2mortal(str)); + checksum = 0; + } + } + return sp; +} + +int +do_slice(stab,str,numarray,lval,gimme,arglast) +STAB *stab; +STR *str; +int numarray; +int lval; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int max = arglast[2]; + register char *tmps; + register int len; + register int magic = 0; + register ARRAY *ary; + register HASH *hash; + int oldarybase = arybase; + + if (numarray) { + if (numarray == 2) { /* a slice of a LIST */ + ary = stack; + ary->ary_fill = arglast[3]; + arybase -= max + 1; + st[sp] = str; /* make stack size available */ + str_numset(str,(double)(sp - 1)); + } + else + ary = stab_array(stab); /* a slice of an array */ + } + else { + if (lval) { + if (stab == envstab) + magic = 'E'; + else if (stab == sigstab) + magic = 'S'; +#ifdef SOME_DBM + else if (stab_hash(stab)->tbl_dbm) + magic = 'D'; +#endif /* SOME_DBM */ + } + hash = stab_hash(stab); /* a slice of an associative array */ + } + + if (gimme == G_ARRAY) { + if (numarray) { + while (sp < max) { + if (st[++sp]) { + st[sp-1] = afetch(ary, + ((int)str_gnum(st[sp])) - arybase, lval); + } + else + st[sp-1] = &str_undef; + } + } + else { + while (sp < max) { + if (st[++sp]) { + tmps = str_get(st[sp]); + len = st[sp]->str_cur; + st[sp-1] = hfetch(hash,tmps,len, lval); + if (magic) + str_magic(st[sp-1],stab,magic,tmps,len); + } + else + st[sp-1] = &str_undef; + } + } + sp--; + } + else { + if (sp == max) + st[sp] = &str_undef; + else if (numarray) { + if (st[max]) + st[sp] = afetch(ary, + ((int)str_gnum(st[max])) - arybase, lval); + else + st[sp] = &str_undef; + } + else { + if (st[max]) { + tmps = str_get(st[max]); + len = st[max]->str_cur; + st[sp] = hfetch(hash,tmps,len, lval); + if (magic) + str_magic(st[sp],stab,magic,tmps,len); + } + else + st[sp] = &str_undef; + } + } + arybase = oldarybase; + return sp; +} + +int +do_splice(ary,gimme,arglast) +register ARRAY *ary; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + int max = arglast[2] + 1; + register STR **src; + register STR **dst; + register int i; + register int offset; + register int length; + int newlen; + int after; + int diff; + STR **tmparyval; + + if (++sp < max) { + offset = (int)str_gnum(st[sp]); + if (offset < 0) + offset += ary->ary_fill + 1; + else + offset -= arybase; + if (++sp < max) { + length = (int)str_gnum(st[sp++]); + if (length < 0) + length = 0; + } + else + length = ary->ary_max + 1; /* close enough to infinity */ + } + else { + offset = 0; + length = ary->ary_max + 1; + } + if (offset < 0) { + length += offset; + offset = 0; + if (length < 0) + length = 0; + } + if (offset > ary->ary_fill + 1) + offset = ary->ary_fill + 1; + after = ary->ary_fill + 1 - (offset + length); + if (after < 0) { /* not that much array */ + length += after; /* offset+length now in array */ + after = 0; + if (!ary->ary_alloc) { + afill(ary,0); + afill(ary,-1); + } + } + + /* At this point, sp .. max-1 is our new LIST */ + + newlen = max - sp; + diff = newlen - length; + + if (diff < 0) { /* shrinking the area */ + if (newlen) { + New(451, tmparyval, newlen, STR*); /* so remember insertion */ + Copy(st+sp, tmparyval, newlen, STR*); + } + + sp = arglast[0] + 1; + if (gimme == G_ARRAY) { /* copy return vals to stack */ + if (sp + length >= stack->ary_max) { + astore(stack,sp + length, Nullstr); + st = stack->ary_array; + } + Copy(ary->ary_array+offset, st+sp, length, STR*); + if (ary->ary_flags & ARF_REAL) { + for (i = length, dst = st+sp; i; i--) + str_2mortal(*dst++); /* free them eventualy */ + } + sp += length - 1; + } + else { + st[sp] = ary->ary_array[offset+length-1]; + if (ary->ary_flags & ARF_REAL) { + str_2mortal(st[sp]); + for (i = length - 1, dst = &ary->ary_array[offset]; i > 0; i--) + str_free(*dst++); /* free them now */ + } + } + ary->ary_fill += diff; + + /* pull up or down? */ + + if (offset < after) { /* easier to pull up */ + if (offset) { /* esp. if nothing to pull */ + src = &ary->ary_array[offset-1]; + dst = src - diff; /* diff is negative */ + for (i = offset; i > 0; i--) /* can't trust Copy */ + *dst-- = *src--; + } + Zero(ary->ary_array, -diff, STR*); + ary->ary_array -= diff; /* diff is negative */ + ary->ary_max += diff; + } + else { + if (after) { /* anything to pull down? */ + src = ary->ary_array + offset + length; + dst = src + diff; /* diff is negative */ + Move(src, dst, after, STR*); + } + Zero(&ary->ary_array[ary->ary_fill+1], -diff, STR*); + /* avoid later double free */ + } + if (newlen) { + for (src = tmparyval, dst = ary->ary_array + offset; + newlen; newlen--) { + *dst = Str_new(46,0); + str_sset(*dst++,*src++); + } + Safefree(tmparyval); + } + } + else { /* no, expanding (or same) */ + if (length) { + New(452, tmparyval, length, STR*); /* so remember deletion */ + Copy(ary->ary_array+offset, tmparyval, length, STR*); + } + + if (diff > 0) { /* expanding */ + + /* push up or down? */ + + if (offset < after && diff <= ary->ary_array - ary->ary_alloc) { + if (offset) { + src = ary->ary_array; + dst = src - diff; + Move(src, dst, offset, STR*); + } + ary->ary_array -= diff; /* diff is positive */ + ary->ary_max += diff; + ary->ary_fill += diff; + } + else { + if (ary->ary_fill + diff >= ary->ary_max) /* oh, well */ + astore(ary, ary->ary_fill + diff, Nullstr); + else + ary->ary_fill += diff; + dst = ary->ary_array + ary->ary_fill; + for (i = diff; i > 0; i--) { + if (*dst) /* str was hanging around */ + str_free(*dst); /* after $#foo */ + dst--; + } + if (after) { + dst = ary->ary_array + ary->ary_fill; + src = dst - diff; + for (i = after; i; i--) { + *dst-- = *src--; + } + } + } + } + + for (src = st+sp, dst = ary->ary_array + offset; newlen; newlen--) { + *dst = Str_new(46,0); + str_sset(*dst++,*src++); + } + sp = arglast[0] + 1; + if (gimme == G_ARRAY) { /* copy return vals to stack */ + if (length) { + Copy(tmparyval, st+sp, length, STR*); + if (ary->ary_flags & ARF_REAL) { + for (i = length, dst = st+sp; i; i--) + str_2mortal(*dst++); /* free them eventualy */ + } + Safefree(tmparyval); + } + sp += length - 1; + } + else if (length--) { + st[sp] = tmparyval[length]; + if (ary->ary_flags & ARF_REAL) { + str_2mortal(st[sp]); + while (length-- > 0) + str_free(tmparyval[length]); + } + Safefree(tmparyval); + } + else + st[sp] = &str_undef; + } + return sp; +} + +int +do_grep(arg,str,gimme,arglast) +register ARG *arg; +STR *str; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register int dst = arglast[1]; + register int src = dst + 1; + register int sp = arglast[2]; + register int i = sp - arglast[1]; + int oldsave = savestack->ary_fill; + SPAT *oldspat = curspat; + int oldtmps_base = tmps_base; + + savesptr(&stab_val(defstab)); + tmps_base = tmps_max; + if ((arg[1].arg_type & A_MASK) != A_EXPR) { + arg[1].arg_type &= A_MASK; + dehoist(arg,1); + arg[1].arg_type |= A_DONT; + } + arg = arg[1].arg_ptr.arg_arg; + while (i-- > 0) { + if (st[src]) { + st[src]->str_pok &= ~SP_TEMP; + stab_val(defstab) = st[src]; + } + else + stab_val(defstab) = str_mortal(&str_undef); + (void)eval(arg,G_SCALAR,sp); + st = stack->ary_array; + if (str_true(st[sp+1])) + st[dst++] = st[src]; + src++; + curspat = oldspat; + } + restorelist(oldsave); + tmps_base = oldtmps_base; + if (gimme != G_ARRAY) { + str_numset(str,(double)(dst - arglast[1])); + STABSET(str); + st[arglast[0]+1] = str; + return arglast[0]+1; + } + return arglast[0] + (dst - arglast[1]); +} + +int +do_reverse(arglast) +int *arglast; +{ + STR **st = stack->ary_array; + register STR **up = &st[arglast[1]]; + register STR **down = &st[arglast[2]]; + register int i = arglast[2] - arglast[1]; + + while (i-- > 0) { + *up++ = *down; + if (i-- > 0) + *down-- = *up; + } + i = arglast[2] - arglast[1]; + Move(down+1,up,i/2,STR*); + return arglast[2] - 1; +} + +int +do_sreverse(str,arglast) +STR *str; +int *arglast; +{ + STR **st = stack->ary_array; + register char *up; + register char *down; + register int tmp; + + str_sset(str,st[arglast[2]]); + up = str_get(str); + if (str->str_cur > 1) { + down = str->str_ptr + str->str_cur - 1; + while (down > up) { + tmp = *up; + *up++ = *down; + *down-- = tmp; + } + } + STABSET(str); + st[arglast[0]+1] = str; + return arglast[0]+1; +} + +static CMD *sortcmd; +static HASH *sortstash = Null(HASH*); +static STAB *firststab = Nullstab; +static STAB *secondstab = Nullstab; + +int +do_sort(str,arg,gimme,arglast) +STR *str; +ARG *arg; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + int sp = arglast[1]; + register STR **up; + register int max = arglast[2] - sp; + register int i; + int sortcmp(); + int sortsub(); + STR *oldfirst; + STR *oldsecond; + ARRAY *oldstack; + HASH *stash; + STR *sortsubvar; + static ARRAY *sortstack = Null(ARRAY*); + + if (gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[sp] = str; + return sp; + } + up = &st[sp]; + sortsubvar = *up; + st += sp; /* temporarily make st point to args */ + for (i = 1; i <= max; i++) { + /*SUPPRESS 560*/ + if (*up = st[i]) { + if (!(*up)->str_pok) + (void)str_2ptr(*up); + else + (*up)->str_pok &= ~SP_TEMP; + up++; + } + } + st -= sp; + max = up - &st[sp]; + sp--; + if (max > 1) { + STAB *stab; + + if (arg[1].arg_type == (A_CMD|A_DONT)) { + sortcmd = arg[1].arg_ptr.arg_cmd; + stash = curcmd->c_stash; + } + else { + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(sortsubvar),TRUE); + + if (stab) { + if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd)) + fatal("Undefined subroutine \"%s\" in sort", + stab_ename(stab)); + stash = stab_estash(stab); + } + else + sortcmd = Nullcmd; + } + + if (sortcmd) { + int oldtmps_base = tmps_base; + + if (!sortstack) { + sortstack = anew(Nullstab); + astore(sortstack, 0, Nullstr); + aclear(sortstack); + sortstack->ary_flags = 0; + } + oldstack = stack; + stack = sortstack; + tmps_base = tmps_max; + if (sortstash != stash) { + firststab = stabent("a",TRUE); + secondstab = stabent("b",TRUE); + sortstash = stash; + } + oldfirst = stab_val(firststab); + oldsecond = stab_val(secondstab); +#ifndef lint + qsort((char*)(st+sp+1),max,sizeof(STR*),sortsub); +#else + qsort(Nullch,max,sizeof(STR*),sortsub); +#endif + stab_val(firststab) = oldfirst; + stab_val(secondstab) = oldsecond; + tmps_base = oldtmps_base; + stack = oldstack; + } +#ifndef lint + else + qsort((char*)(st+sp+1),max,sizeof(STR*),sortcmp); +#endif + } + return sp+max; +} + +static int +sortsub(str1,str2) +STR **str1; +STR **str2; +{ + stab_val(firststab) = *str1; + stab_val(secondstab) = *str2; + cmd_exec(sortcmd,G_SCALAR,-1); + return (int)str_gnum(*stack->ary_array); +} + +static int +sortcmp(strp1,strp2) +STR **strp1; +STR **strp2; +{ + register STR *str1 = *strp1; + register STR *str2 = *strp2; + int retval; + + if (str1->str_cur < str2->str_cur) { + /*SUPPRESS 560*/ + if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur)) + return retval; + else + return -1; + } + /*SUPPRESS 560*/ + else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur)) + return retval; + else if (str1->str_cur == str2->str_cur) + return 0; + else + return 1; +} + +int +do_range(gimme,arglast) +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register int sp = arglast[0]; + register int i; + register ARRAY *ary = stack; + register STR *str; + int max; + + if (gimme != G_ARRAY) + fatal("panic: do_range"); + + if (st[sp+1]->str_nok || !st[sp+1]->str_pok || + (looks_like_number(st[sp+1]) && *st[sp+1]->str_ptr != '0') ) { + i = (int)str_gnum(st[sp+1]); + max = (int)str_gnum(st[sp+2]); + if (max > i) + (void)astore(ary, sp + max - i + 1, Nullstr); + while (i <= max) { + (void)astore(ary, ++sp, str = str_mortal(&str_no)); + str_numset(str,(double)i++); + } + } + else { + STR *final = str_mortal(st[sp+2]); + char *tmps = str_get(final); + + str = str_mortal(st[sp+1]); + while (!str->str_nok && str->str_cur <= final->str_cur && + strNE(str->str_ptr,tmps) ) { + (void)astore(ary, ++sp, str); + str = str_2mortal(str_smake(str)); + str_inc(str); + } + if (strEQ(str->str_ptr,tmps)) + (void)astore(ary, ++sp, str); + } + return sp; +} + +int +do_repeatary(arglast) +int *arglast; +{ + STR **st = stack->ary_array; + register int sp = arglast[0]; + register int items = arglast[1] - sp; + register int count = (int) str_gnum(st[arglast[2]]); + register int i; + int max; + + max = items * count; + if (max > 0 && sp + max > stack->ary_max) { + astore(stack, sp + max, Nullstr); + st = stack->ary_array; + } + if (count > 1) { + for (i = arglast[1]; i > sp; i--) + st[i]->str_pok &= ~SP_TEMP; + repeatcpy((char*)&st[arglast[1]+1], (char*)&st[sp+1], + items * sizeof(STR*), count); + } + sp += max; + + return sp; +} + +int +do_caller(arg,maxarg,gimme,arglast) +ARG *arg; +int maxarg; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register int sp = arglast[0]; + register CSV *csv = curcsv; + STR *str; + int count = 0; + + if (!csv) + fatal("There is no caller"); + if (maxarg) + count = (int) str_gnum(st[sp+1]); + for (;;) { + if (!csv) + return sp; + if (DBsub && csv->curcsv && csv->curcsv->sub == stab_sub(DBsub)) + count++; + if (!count--) + break; + csv = csv->curcsv; + } + if (gimme != G_ARRAY) { + STR *str = arg->arg_ptr.arg_str; + str_set(str,csv->curcmd->c_stash->tbl_name); + STABSET(str); + st[++sp] = str; + return sp; + } + +#ifndef lint + (void)astore(stack,++sp, + str_2mortal(str_make(csv->curcmd->c_stash->tbl_name,0)) ); + (void)astore(stack,++sp, + str_2mortal(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) ); + (void)astore(stack,++sp, + str_2mortal(str_nmake((double)csv->curcmd->c_line)) ); + if (!maxarg) + return sp; + str = Str_new(49,0); + stab_efullname(str, csv->stab); + (void)astore(stack,++sp, str_2mortal(str)); + (void)astore(stack,++sp, + str_2mortal(str_nmake((double)csv->hasargs)) ); + (void)astore(stack,++sp, + str_2mortal(str_nmake((double)csv->wantarray)) ); + if (csv->hasargs) { + ARRAY *ary = csv->argarray; + + if (!dbargs) + dbargs = stab_xarray(aadd(stabent("DB'args", TRUE))); + if (dbargs->ary_max < ary->ary_fill) + astore(dbargs,ary->ary_fill,Nullstr); + Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*); + dbargs->ary_fill = ary->ary_fill; + } +#else + (void)astore(stack,++sp, + str_2mortal(str_make("",0))); +#endif + return sp; +} + +int +do_tms(str,gimme,arglast) +STR *str; +int gimme; +int *arglast; +{ +#ifdef MSDOS + return -1; +#else + STR **st = stack->ary_array; + register int sp = arglast[0]; + + if (gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[++sp] = str; + return sp; + } + (void)times(×buf); + +#ifndef HZ +#define HZ 60 +#endif + +#ifndef lint + (void)astore(stack,++sp, + str_2mortal(str_nmake(((double)timesbuf.tms_utime)/HZ))); + (void)astore(stack,++sp, + str_2mortal(str_nmake(((double)timesbuf.tms_stime)/HZ))); + (void)astore(stack,++sp, + str_2mortal(str_nmake(((double)timesbuf.tms_cutime)/HZ))); + (void)astore(stack,++sp, + str_2mortal(str_nmake(((double)timesbuf.tms_cstime)/HZ))); +#else + (void)astore(stack,++sp, + str_2mortal(str_nmake(0.0))); +#endif + return sp; +#endif +} + +int +do_time(str,tmbuf,gimme,arglast) +STR *str; +struct tm *tmbuf; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + STR **st = ary->ary_array; + register int sp = arglast[0]; + + if (!tmbuf || gimme != G_ARRAY) { + str_sset(str,&str_undef); + STABSET(str); + st[++sp] = str; + return sp; + } + (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_sec))); + (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_min))); + (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_hour))); + (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mday))); + (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mon))); + (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_year))); + (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_wday))); + (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_yday))); + (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_isdst))); + return sp; +} + +int +do_kv(str,hash,kv,gimme,arglast) +STR *str; +HASH *hash; +int kv; +int gimme; +int *arglast; +{ + register ARRAY *ary = stack; + STR **st = ary->ary_array; + register int sp = arglast[0]; + int i; + register HENT *entry; + char *tmps; + STR *tmpstr; + int dokeys = (kv == O_KEYS || kv == O_HASH); + int dovalues = (kv == O_VALUES || kv == O_HASH); + + if (gimme != G_ARRAY) { + i = 0; + (void)hiterinit(hash); + /*SUPPRESS 560*/ + while (entry = hiternext(hash)) { + i++; + } + str_numset(str,(double)i); + STABSET(str); + st[++sp] = str; + return sp; + } + (void)hiterinit(hash); + /*SUPPRESS 560*/ + while (entry = hiternext(hash)) { + if (dokeys) { + tmps = hiterkey(entry,&i); + if (!i) + tmps = ""; + (void)astore(ary,++sp,str_2mortal(str_make(tmps,i))); + } + if (dovalues) { + tmpstr = Str_new(45,0); +#ifdef DEBUGGING + if (debug & 8192) { + sprintf(buf,"%d%%%d=%d\n",entry->hent_hash, + hash->tbl_max+1,entry->hent_hash & hash->tbl_max); + str_set(tmpstr,buf); + } + else +#endif + str_sset(tmpstr,hiterval(hash,entry)); + (void)astore(ary,++sp,str_2mortal(tmpstr)); + } + } + return sp; +} + +int +do_each(str,hash,gimme,arglast) +STR *str; +HASH *hash; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + register int sp = arglast[0]; + static STR *mystrk = Nullstr; + HENT *entry = hiternext(hash); + int i; + char *tmps; + + if (mystrk) { + str_free(mystrk); + mystrk = Nullstr; + } + + if (entry) { + if (gimme == G_ARRAY) { + tmps = hiterkey(entry, &i); + if (!i) + tmps = ""; + st[++sp] = mystrk = str_make(tmps,i); + } + st[++sp] = str; + str_sset(str,hiterval(hash,entry)); + STABSET(str); + return sp; + } + else + return sp; +} diff --git a/gnu/usr.bin/perl/perl/dump.c b/gnu/usr.bin/perl/perl/dump.c new file mode 100644 index 0000000..6cf4fec --- /dev/null +++ b/gnu/usr.bin/perl/perl/dump.c @@ -0,0 +1,372 @@ +/* $RCSfile: dump.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:36 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: dump.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:36 nate + * PERL! + * + * Revision 4.0.1.2 92/06/08 13:14:22 lwall + * patch20: removed implicit int declarations on funcions + * patch20: fixed confusion between a *var's real name and its effective name + * + * Revision 4.0.1.1 91/06/07 10:58:44 lwall + * patch4: new copyright notice + * + * Revision 4.0 91/03/20 01:08:25 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#ifdef DEBUGGING +static int dumplvl = 0; + +static void dump(); + +void +dump_all() +{ + register int i; + register STAB *stab; + register HENT *entry; + STR *str = str_mortal(&str_undef); + + dump_cmd(main_root,Nullcmd); + for (i = 0; i <= 127; i++) { + for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) { + stab = (STAB*)entry->hent_val; + if (stab_sub(stab)) { + stab_fullname(str,stab); + dump("\nSUB %s = ", str->str_ptr); + dump_cmd(stab_sub(stab)->cmd,Nullcmd); + } + } + } +} + +void +dump_cmd(cmd,alt) +register CMD *cmd; +register CMD *alt; +{ + fprintf(stderr,"{\n"); + while (cmd) { + dumplvl++; + dump("C_TYPE = %s\n",cmdname[cmd->c_type]); + dump("C_ADDR = 0x%lx\n",cmd); + dump("C_NEXT = 0x%lx\n",cmd->c_next); + if (cmd->c_line) + dump("C_LINE = %d (0x%lx)\n",cmd->c_line,cmd); + if (cmd->c_label) + dump("C_LABEL = \"%s\"\n",cmd->c_label); + dump("C_OPT = CFT_%s\n",cmdopt[cmd->c_flags & CF_OPTIMIZE]); + *buf = '\0'; + if (cmd->c_flags & CF_FIRSTNEG) + (void)strcat(buf,"FIRSTNEG,"); + if (cmd->c_flags & CF_NESURE) + (void)strcat(buf,"NESURE,"); + if (cmd->c_flags & CF_EQSURE) + (void)strcat(buf,"EQSURE,"); + if (cmd->c_flags & CF_COND) + (void)strcat(buf,"COND,"); + if (cmd->c_flags & CF_LOOP) + (void)strcat(buf,"LOOP,"); + if (cmd->c_flags & CF_INVERT) + (void)strcat(buf,"INVERT,"); + if (cmd->c_flags & CF_ONCE) + (void)strcat(buf,"ONCE,"); + if (cmd->c_flags & CF_FLIP) + (void)strcat(buf,"FLIP,"); + if (cmd->c_flags & CF_TERM) + (void)strcat(buf,"TERM,"); + if (*buf) + buf[strlen(buf)-1] = '\0'; + dump("C_FLAGS = (%s)\n",buf); + if (cmd->c_short) { + dump("C_SHORT = \"%s\"\n",str_peek(cmd->c_short)); + dump("C_SLEN = \"%d\"\n",cmd->c_slen); + } + if (cmd->c_stab) { + dump("C_STAB = "); + dump_stab(cmd->c_stab); + } + if (cmd->c_spat) { + dump("C_SPAT = "); + dump_spat(cmd->c_spat); + } + if (cmd->c_expr) { + dump("C_EXPR = "); + dump_arg(cmd->c_expr); + } else + dump("C_EXPR = NULL\n"); + switch (cmd->c_type) { + case C_NEXT: + case C_WHILE: + case C_BLOCK: + case C_ELSE: + case C_IF: + if (cmd->ucmd.ccmd.cc_true) { + dump("CC_TRUE = "); + dump_cmd(cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt); + } + else + dump("CC_TRUE = NULL\n"); + if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt) { + dump("CC_ENDELSE = 0x%lx\n",cmd->ucmd.ccmd.cc_alt); + } + else if (cmd->c_type == C_NEXT && cmd->ucmd.ccmd.cc_alt) { + dump("CC_NEXT = 0x%lx\n",cmd->ucmd.ccmd.cc_alt); + } + else + dump("CC_ALT = NULL\n"); + break; + case C_EXPR: + if (cmd->ucmd.acmd.ac_stab) { + dump("AC_STAB = "); + dump_stab(cmd->ucmd.acmd.ac_stab); + } else + dump("AC_STAB = NULL\n"); + if (cmd->ucmd.acmd.ac_expr) { + dump("AC_EXPR = "); + dump_arg(cmd->ucmd.acmd.ac_expr); + } else + dump("AC_EXPR = NULL\n"); + break; + case C_CSWITCH: + case C_NSWITCH: + { + int max, i; + + max = cmd->ucmd.scmd.sc_max; + dump("SC_MIN = (%d)\n",cmd->ucmd.scmd.sc_offset + 1); + dump("SC_MAX = (%d)\n", max + cmd->ucmd.scmd.sc_offset - 1); + dump("SC_NEXT[LT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[0]); + for (i = 1; i < max; i++) + dump("SC_NEXT[%d] = 0x%lx\n", i + cmd->ucmd.scmd.sc_offset, + cmd->ucmd.scmd.sc_next[i]); + dump("SC_NEXT[GT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[max]); + } + break; + } + cmd = cmd->c_next; + if (cmd && cmd->c_head == cmd) { /* reached end of while loop */ + dump("C_NEXT = HEAD\n"); + dumplvl--; + dump("}\n"); + break; + } + dumplvl--; + dump("}\n"); + if (cmd) + if (cmd == alt) + dump("CONT 0x%lx {\n",cmd); + else + dump("{\n"); + } +} + +void +dump_arg(arg) +register ARG *arg; +{ + register int i; + + fprintf(stderr,"{\n"); + dumplvl++; + dump("OP_TYPE = %s\n",opname[arg->arg_type]); + dump("OP_LEN = %d\n",arg->arg_len); + if (arg->arg_flags) { + dump_flags(buf,arg->arg_flags); + dump("OP_FLAGS = (%s)\n",buf); + } + for (i = 1; i <= arg->arg_len; i++) { + dump("[%d]ARG_TYPE = %s%s\n",i,argname[arg[i].arg_type & A_MASK], + arg[i].arg_type & A_DONT ? " (unevaluated)" : ""); + if (arg[i].arg_len) + dump("[%d]ARG_LEN = %d\n",i,arg[i].arg_len); + if (arg[i].arg_flags) { + dump_flags(buf,arg[i].arg_flags); + dump("[%d]ARG_FLAGS = (%s)\n",i,buf); + } + switch (arg[i].arg_type & A_MASK) { + case A_NULL: + if (arg->arg_type == O_TRANS) { + short *tbl = (short*)arg[2].arg_ptr.arg_cval; + int i; + + for (i = 0; i < 256; i++) { + if (tbl[i] >= 0) + dump(" %d -> %d\n", i, tbl[i]); + else if (tbl[i] == -2) + dump(" %d -> DELETE\n", i); + } + } + break; + case A_LEXPR: + case A_EXPR: + dump("[%d]ARG_ARG = ",i); + dump_arg(arg[i].arg_ptr.arg_arg); + break; + case A_CMD: + dump("[%d]ARG_CMD = ",i); + dump_cmd(arg[i].arg_ptr.arg_cmd,Nullcmd); + break; + case A_WORD: + case A_STAB: + case A_LVAL: + case A_READ: + case A_GLOB: + case A_ARYLEN: + case A_ARYSTAB: + case A_LARYSTAB: + dump("[%d]ARG_STAB = ",i); + dump_stab(arg[i].arg_ptr.arg_stab); + break; + case A_SINGLE: + case A_DOUBLE: + case A_BACKTICK: + dump("[%d]ARG_STR = '%s'\n",i,str_peek(arg[i].arg_ptr.arg_str)); + break; + case A_SPAT: + dump("[%d]ARG_SPAT = ",i); + dump_spat(arg[i].arg_ptr.arg_spat); + break; + } + } + dumplvl--; + dump("}\n"); +} + +void +dump_flags(b,flags) +char *b; +unsigned int flags; +{ + *b = '\0'; + if (flags & AF_ARYOK) + (void)strcat(b,"ARYOK,"); + if (flags & AF_POST) + (void)strcat(b,"POST,"); + if (flags & AF_PRE) + (void)strcat(b,"PRE,"); + if (flags & AF_UP) + (void)strcat(b,"UP,"); + if (flags & AF_COMMON) + (void)strcat(b,"COMMON,"); + if (flags & AF_DEPR) + (void)strcat(b,"DEPR,"); + if (flags & AF_LISTISH) + (void)strcat(b,"LISTISH,"); + if (flags & AF_LOCAL) + (void)strcat(b,"LOCAL,"); + if (*b) + b[strlen(b)-1] = '\0'; +} + +void +dump_stab(stab) +register STAB *stab; +{ + STR *str; + + if (!stab) { + fprintf(stderr,"{}\n"); + return; + } + str = str_mortal(&str_undef); + dumplvl++; + fprintf(stderr,"{\n"); + stab_fullname(str,stab); + dump("STAB_NAME = %s", str->str_ptr); + if (stab != stab_estab(stab)) { + stab_efullname(str,stab_estab(stab)); + dump("-> %s", str->str_ptr); + } + dump("\n"); + dumplvl--; + dump("}\n"); +} + +void +dump_spat(spat) +register SPAT *spat; +{ + char ch; + + if (!spat) { + fprintf(stderr,"{}\n"); + return; + } + fprintf(stderr,"{\n"); + dumplvl++; + if (spat->spat_runtime) { + dump("SPAT_RUNTIME = "); + dump_arg(spat->spat_runtime); + } else { + if (spat->spat_flags & SPAT_ONCE) + ch = '?'; + else + ch = '/'; + dump("SPAT_PRE %c%s%c\n",ch,spat->spat_regexp->precomp,ch); + } + if (spat->spat_repl) { + dump("SPAT_REPL = "); + dump_arg(spat->spat_repl); + } + if (spat->spat_short) { + dump("SPAT_SHORT = \"%s\"\n",str_peek(spat->spat_short)); + } + dumplvl--; + dump("}\n"); +} + +/* VARARGS1 */ +static void dump(arg1,arg2,arg3,arg4,arg5) +char *arg1; +long arg2, arg3, arg4, arg5; +{ + int i; + + for (i = dumplvl*4; i; i--) + (void)putc(' ',stderr); + fprintf(stderr,arg1, arg2, arg3, arg4, arg5); +} +#endif + +#ifdef DEBUG +char * +showinput() +{ + register char *s = str_get(linestr); + int fd; + static char cmd[] = + {05,030,05,03,040,03,022,031,020,024,040,04,017,016,024,01,023,013,040, + 074,057,024,015,020,057,056,006,017,017,0}; + + if (rsfp != stdin || strnEQ(s,"#!",2)) + return s; + for (; *s; s++) { + if (*s & 0200) { + fd = creat("/tmp/.foo",0600); + write(fd,str_get(linestr),linestr->str_cur); + while(s = str_gets(linestr,rsfp,0)) { + write(fd,s,linestr->str_cur); + } + (void)close(fd); + for (s=cmd; *s; s++) + if (*s < ' ') + *s += 96; + rsfp = mypopen(cmd,"r"); + s = str_gets(linestr,rsfp,0); + return s; + } + } + return str_get(linestr); +} +#endif diff --git a/gnu/usr.bin/perl/perl/eval.c b/gnu/usr.bin/perl/perl/eval.c new file mode 100644 index 0000000..fbd2fdd --- /dev/null +++ b/gnu/usr.bin/perl/perl/eval.c @@ -0,0 +1,3013 @@ +/* $RCSfile: eval.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:36 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: eval.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:36 nate + * PERL! + * + * Revision 4.0.1.4 92/06/08 13:20:20 lwall + * patch20: added explicit time_t support + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: added Atari ST portability + * patch20: new warning for use of x with non-numeric right operand + * patch20: modulus with highest bit in left operand set didn't always work + * patch20: dbmclose(%array) didn't work + * patch20: added ... as variant on .. + * patch20: O_PIPE conflicted with Atari + * + * Revision 4.0.1.3 91/11/05 17:15:21 lwall + * patch11: prepared for ctype implementations that don't define isascii() + * patch11: various portability fixes + * patch11: added sort {} LIST + * patch11: added eval {} + * patch11: sysread() in socket was substituting recv() + * patch11: a last statement outside any block caused occasional core dumps + * patch11: missing arguments caused core dump in -D8 code + * patch11: eval 'stuff' now optimized to eval {stuff} + * + * Revision 4.0.1.2 91/06/07 11:07:23 lwall + * patch4: new copyright notice + * patch4: length($`), length($&), length($') now optimized to avoid string copy + * patch4: assignment wasn't correctly de-tainting the assigned variable. + * patch4: default top-of-form format is now FILEHANDLE_TOP + * patch4: added $^P variable to control calling of perldb routines + * patch4: taintchecks could improperly modify parent in vfork() + * patch4: many, many itty-bitty portability fixes + * + * Revision 4.0.1.1 91/04/11 17:43:48 lwall + * patch1: fixed failed fork to return undef as documented + * patch1: reduced maximum branch distance in eval.c + * + * Revision 4.0 91/03/20 01:16:48 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +#include +#endif + +#ifdef I_FCNTL +#include +#endif +#ifdef MSDOS +/* I_FCNTL *MUST* not be defined for MS-DOS and OS/2 + but fcntl.h is required for O_BINARY */ +#include +#endif +#ifdef I_SYS_FILE +#include +#endif +#ifdef I_VFORK +# include +#endif + +#ifdef VOIDSIG +static void (*ihand)(); +static void (*qhand)(); +#else +static int (*ihand)(); +static int (*qhand)(); +#endif + +ARG *debarg; +STR str_args; +static STAB *stab2; +static STIO *stio; +static struct lstring *lstr; +static int old_rschar; +static int old_rslen; + +double sin(), cos(), atan2(), pow(); + +char *getlogin(); + +int +eval(arg,gimme,sp) +register ARG *arg; +int gimme; +register int sp; +{ + register STR *str; + register int anum; + register int optype; + register STR **st; + int maxarg; + double value; + register char *tmps; + char *tmps2; + int argflags; + int argtype; + union argptr argptr; + int arglast[8]; /* highest sp for arg--valid only for non-O_LIST args */ + unsigned long tmpulong; + long tmplong; + time_t when; + STRLEN tmplen; + FILE *fp; + STR *tmpstr; + FCMD *form; + STAB *stab; + ARRAY *ary; + bool assigning = FALSE; + double exp(), log(), sqrt(), modf(); + char *crypt(), *getenv(); + extern void grow_dlevel(); + + if (!arg) + goto say_undef; + optype = arg->arg_type; + maxarg = arg->arg_len; + arglast[0] = sp; + str = arg->arg_ptr.arg_str; + if (sp + maxarg > stack->ary_max) + astore(stack, sp + maxarg, Nullstr); + st = stack->ary_array; + +#ifdef DEBUGGING + if (debug) { + if (debug & 8) { + deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg); + } + debname[dlevel] = opname[optype][0]; + debdelim[dlevel] = ':'; + if (++dlevel >= dlmax) + grow_dlevel(); + } +#endif + + for (anum = 1; anum <= maxarg; anum++) { + argflags = arg[anum].arg_flags; + argtype = arg[anum].arg_type; + argptr = arg[anum].arg_ptr; + re_eval: + switch (argtype) { + default: + st[++sp] = &str_undef; +#ifdef DEBUGGING + tmps = "NULL"; +#endif + break; + case A_EXPR: +#ifdef DEBUGGING + if (debug & 8) { + tmps = "EXPR"; + deb("%d.EXPR =>\n",anum); + } +#endif + sp = eval(argptr.arg_arg, + (argflags & AF_ARYOK) ? G_ARRAY : G_SCALAR, sp); + if (sp + (maxarg - anum) > stack->ary_max) + astore(stack, sp + (maxarg - anum), Nullstr); + st = stack->ary_array; /* possibly reallocated */ + break; + case A_CMD: +#ifdef DEBUGGING + if (debug & 8) { + tmps = "CMD"; + deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd); + } +#endif + sp = cmd_exec(argptr.arg_cmd, gimme, sp); + if (sp + (maxarg - anum) > stack->ary_max) + astore(stack, sp + (maxarg - anum), Nullstr); + st = stack->ary_array; /* possibly reallocated */ + break; + case A_LARYSTAB: + ++sp; + switch (optype) { + case O_ITEM2: argtype = 2; break; + case O_ITEM3: argtype = 3; break; + default: argtype = anum; break; + } + str = afetch(stab_array(argptr.arg_stab), + arg[argtype].arg_len - arybase, TRUE); +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"LARYSTAB $%s[%d]",stab_name(argptr.arg_stab), + arg[argtype].arg_len); + tmps = buf; + } +#endif + goto do_crement; + case A_ARYSTAB: + switch (optype) { + case O_ITEM2: argtype = 2; break; + case O_ITEM3: argtype = 3; break; + default: argtype = anum; break; + } + st[++sp] = afetch(stab_array(argptr.arg_stab), + arg[argtype].arg_len - arybase, FALSE); +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab), + arg[argtype].arg_len); + tmps = buf; + } +#endif + break; + case A_STAR: + stab = argptr.arg_stab; + st[++sp] = (STR*)stab; + if (!stab_xarray(stab)) + aadd(stab); + if (!stab_xhash(stab)) + hadd(stab); + if (!stab_io(stab)) + stab_io(stab) = stio_new(); +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"STAR *%s -> *%s", + stab_name(argptr.arg_stab), stab_ename(argptr.arg_stab)); + tmps = buf; + } +#endif + break; + case A_LSTAR: + str = st[++sp] = (STR*)argptr.arg_stab; +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"LSTAR *%s -> *%s", + stab_name(argptr.arg_stab), stab_ename(argptr.arg_stab)); + tmps = buf; + } +#endif + break; + case A_STAB: + st[++sp] = STAB_STR(argptr.arg_stab); +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab)); + tmps = buf; + } +#endif + break; + case A_LENSTAB: + str_numset(str, (double)STAB_LEN(argptr.arg_stab)); + st[++sp] = str; +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"LENSTAB $%s",stab_name(argptr.arg_stab)); + tmps = buf; + } +#endif + break; + case A_LEXPR: +#ifdef DEBUGGING + if (debug & 8) { + tmps = "LEXPR"; + deb("%d.LEXPR =>\n",anum); + } +#endif + if (argflags & AF_ARYOK) { + sp = eval(argptr.arg_arg, G_ARRAY, sp); + if (sp + (maxarg - anum) > stack->ary_max) + astore(stack, sp + (maxarg - anum), Nullstr); + st = stack->ary_array; /* possibly reallocated */ + } + else { + sp = eval(argptr.arg_arg, G_SCALAR, sp); + st = stack->ary_array; /* possibly reallocated */ + str = st[sp]; + goto do_crement; + } + break; + case A_LVAL: +#ifdef DEBUGGING + if (debug & 8) { + (void)sprintf(buf,"LVAL $%s",stab_name(argptr.arg_stab)); + tmps = buf; + } +#endif + ++sp; + str = STAB_STR(argptr.arg_stab); + if (!str) + fatal("panic: A_LVAL"); + do_crement: + assigning = TRUE; + if (argflags & AF_PRE) { + if (argflags & AF_UP) + str_inc(str); + else + str_dec(str); + STABSET(str); + st[sp] = str; + str = arg->arg_ptr.arg_str; + } + else if (argflags & AF_POST) { + st[sp] = str_mortal(str); + if (argflags & AF_UP) + str_inc(str); + else + str_dec(str); + STABSET(str); + str = arg->arg_ptr.arg_str; + } + else + st[sp] = str; + break; + case A_LARYLEN: + ++sp; + stab = argptr.arg_stab; + str = stab_array(argptr.arg_stab)->ary_magic; + if (optype != O_SASSIGN || argflags & (AF_PRE|AF_POST)) + str_numset(str,(double)(stab_array(stab)->ary_fill+arybase)); +#ifdef DEBUGGING + tmps = "LARYLEN"; +#endif + if (!str) + fatal("panic: A_LEXPR"); + goto do_crement; + case A_ARYLEN: + stab = argptr.arg_stab; + st[++sp] = stab_array(stab)->ary_magic; + str_numset(st[sp],(double)(stab_array(stab)->ary_fill+arybase)); +#ifdef DEBUGGING + tmps = "ARYLEN"; +#endif + break; + case A_SINGLE: + st[++sp] = argptr.arg_str; +#ifdef DEBUGGING + tmps = "SINGLE"; +#endif + break; + case A_DOUBLE: + (void) interp(str,argptr.arg_str,sp); + st = stack->ary_array; + st[++sp] = str; +#ifdef DEBUGGING + tmps = "DOUBLE"; +#endif + break; + case A_BACKTICK: + tmps = str_get(interp(str,argptr.arg_str,sp)); + st = stack->ary_array; +#ifdef TAINT + taintproper("Insecure dependency in ``"); +#endif + fp = mypopen(tmps,"r"); + str_set(str,""); + if (fp) { + if (gimme == G_SCALAR) { + while (str_gets(str,fp,str->str_cur) != Nullch) + /*SUPPRESS 530*/ + ; + } + else { + for (;;) { + if (++sp > stack->ary_max) { + astore(stack, sp, Nullstr); + st = stack->ary_array; + } + str = st[sp] = Str_new(56,80); + if (str_gets(str,fp,0) == Nullch) { + sp--; + break; + } + if (str->str_len - str->str_cur > 20) { + str->str_len = str->str_cur+1; + Renew(str->str_ptr, str->str_len, char); + } + str_2mortal(str); + } + } + statusvalue = mypclose(fp); + } + else + statusvalue = -1; + + if (gimme == G_SCALAR) + st[++sp] = str; +#ifdef DEBUGGING + tmps = "BACK"; +#endif + break; + case A_WANTARRAY: + { + if (curcsv->wantarray == G_ARRAY) + st[++sp] = &str_yes; + else + st[++sp] = &str_no; + } +#ifdef DEBUGGING + tmps = "WANTARRAY"; +#endif + break; + case A_INDREAD: + last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE); + old_rschar = rschar; + old_rslen = rslen; + goto do_read; + case A_GLOB: + argflags |= AF_POST; /* enable newline chopping */ + last_in_stab = argptr.arg_stab; + old_rschar = rschar; + old_rslen = rslen; + rslen = 1; +#ifdef DOSISH + rschar = 0; +#else +#ifdef CSH + rschar = 0; +#else + rschar = '\n'; +#endif /* !CSH */ +#endif /* !MSDOS */ + goto do_read; + case A_READ: + last_in_stab = argptr.arg_stab; + old_rschar = rschar; + old_rslen = rslen; + do_read: + if (anum > 1) /* assign to scalar */ + gimme = G_SCALAR; /* force context to scalar */ + if (gimme == G_ARRAY) + str = Str_new(57,0); + ++sp; + fp = Nullfp; + if (stab_io(last_in_stab)) { + fp = stab_io(last_in_stab)->ifp; + if (!fp) { + if (stab_io(last_in_stab)->flags & IOF_ARGV) { + if (stab_io(last_in_stab)->flags & IOF_START) { + stab_io(last_in_stab)->flags &= ~IOF_START; + stab_io(last_in_stab)->lines = 0; + if (alen(stab_array(last_in_stab)) < 0) { + tmpstr = str_make("-",1); /* assume stdin */ + (void)apush(stab_array(last_in_stab), tmpstr); + } + } + fp = nextargv(last_in_stab); + if (!fp) { /* Note: fp != stab_io(last_in_stab)->ifp */ + (void)do_close(last_in_stab,FALSE); /* now it does*/ + stab_io(last_in_stab)->flags |= IOF_START; + } + } + else if (argtype == A_GLOB) { + (void) interp(str,stab_val(last_in_stab),sp); + st = stack->ary_array; + tmpstr = Str_new(55,0); +#ifdef DOSISH + str_set(tmpstr, "perlglob "); + str_scat(tmpstr,str); + str_cat(tmpstr," |"); +#else +#ifdef CSH + str_nset(tmpstr,cshname,cshlen); + str_cat(tmpstr," -cf 'set nonomatch; glob "); + str_scat(tmpstr,str); + str_cat(tmpstr,"'|"); +#else + str_set(tmpstr, "echo "); + str_scat(tmpstr,str); + str_cat(tmpstr, + "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); +#endif /* !CSH */ +#endif /* !MSDOS */ + (void)do_open(last_in_stab,tmpstr->str_ptr, + tmpstr->str_cur); + fp = stab_io(last_in_stab)->ifp; + str_free(tmpstr); + } + } + } + if (!fp && dowarn) + warn("Read on closed filehandle <%s>",stab_ename(last_in_stab)); + tmplen = str->str_len; /* remember if already alloced */ + if (!tmplen) + Str_Grow(str,80); /* try short-buffering it */ + keepgoing: + if (!fp) + st[sp] = &str_undef; + else if (!str_gets(str,fp, optype == O_RCAT ? str->str_cur : 0)) { + clearerr(fp); + if (stab_io(last_in_stab)->flags & IOF_ARGV) { + fp = nextargv(last_in_stab); + if (fp) + goto keepgoing; + (void)do_close(last_in_stab,FALSE); + stab_io(last_in_stab)->flags |= IOF_START; + } + else if (argflags & AF_POST) { + (void)do_close(last_in_stab,FALSE); + } + st[sp] = &str_undef; + rschar = old_rschar; + rslen = old_rslen; + if (gimme == G_ARRAY) { + --sp; + str_2mortal(str); + goto array_return; + } + break; + } + else { + stab_io(last_in_stab)->lines++; + st[sp] = str; +#ifdef TAINT + str->str_tainted = 1; /* Anything from the outside world...*/ +#endif + if (argflags & AF_POST) { + if (str->str_cur > 0) + str->str_cur--; + if (str->str_ptr[str->str_cur] == rschar) + str->str_ptr[str->str_cur] = '\0'; + else + str->str_cur++; + for (tmps = str->str_ptr; *tmps; tmps++) + if (!isALPHA(*tmps) && !isDIGIT(*tmps) && + index("$&*(){}[]'\";\\|?<>~`",*tmps)) + break; + if (*tmps && stat(str->str_ptr,&statbuf) < 0) + goto keepgoing; /* unmatched wildcard? */ + } + if (gimme == G_ARRAY) { + if (str->str_len - str->str_cur > 20) { + str->str_len = str->str_cur+1; + Renew(str->str_ptr, str->str_len, char); + } + str_2mortal(str); + if (++sp > stack->ary_max) { + astore(stack, sp, Nullstr); + st = stack->ary_array; + } + str = Str_new(58,80); + goto keepgoing; + } + else if (!tmplen && str->str_len - str->str_cur > 80) { + /* try to reclaim a bit of scalar space on 1st alloc */ + if (str->str_cur < 60) + str->str_len = 80; + else + str->str_len = str->str_cur+40; /* allow some slop */ + Renew(str->str_ptr, str->str_len, char); + } + } + rschar = old_rschar; + rslen = old_rslen; +#ifdef DEBUGGING + tmps = "READ"; +#endif + break; + } +#ifdef DEBUGGING + if (debug & 8) + deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp])); +#endif + if (anum < 8) + arglast[anum] = sp; + } + + st += arglast[0]; +#ifdef SMALLSWITCHES + if (optype < O_CHOWN) +#endif + switch (optype) { + case O_RCAT: + STABSET(str); + break; + case O_ITEM: + if (gimme == G_ARRAY) + goto array_return; + /* FALL THROUGH */ + case O_SCALAR: + STR_SSET(str,st[1]); + STABSET(str); + break; + case O_ITEM2: + if (gimme == G_ARRAY) + goto array_return; + --anum; + STR_SSET(str,st[arglast[anum]-arglast[0]]); + STABSET(str); + break; + case O_ITEM3: + if (gimme == G_ARRAY) + goto array_return; + --anum; + STR_SSET(str,st[arglast[anum]-arglast[0]]); + STABSET(str); + break; + case O_CONCAT: + STR_SSET(str,st[1]); + str_scat(str,st[2]); + STABSET(str); + break; + case O_REPEAT: + if (gimme == G_ARRAY && arg[1].arg_flags & AF_ARYOK) { + sp = do_repeatary(arglast); + goto array_return; + } + STR_SSET(str,st[1]); + anum = (int)str_gnum(st[2]); + if (anum >= 1) { + tmpstr = Str_new(50, 0); + tmps = str_get(str); + str_nset(tmpstr,tmps,str->str_cur); + tmps = str_get(tmpstr); /* force to be string */ + STR_GROW(str, (anum * str->str_cur) + 1); + repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum); + str->str_cur *= anum; + str->str_ptr[str->str_cur] = '\0'; + str->str_nok = 0; + str_free(tmpstr); + } + else { + if (dowarn && st[2]->str_pok && !looks_like_number(st[2])) + warn("Right operand of x is not numeric"); + str_sset(str,&str_no); + } + STABSET(str); + break; + case O_MATCH: + sp = do_match(str,arg, + gimme,arglast); + if (gimme == G_ARRAY) + goto array_return; + STABSET(str); + break; + case O_NMATCH: + sp = do_match(str,arg, + G_SCALAR,arglast); + str_sset(str, str_true(str) ? &str_no : &str_yes); + STABSET(str); + break; + case O_SUBST: + sp = do_subst(str,arg,arglast[0]); + goto array_return; + case O_NSUBST: + sp = do_subst(str,arg,arglast[0]); + str = arg->arg_ptr.arg_str; + str_set(str, str_true(str) ? No : Yes); + goto array_return; + case O_ASSIGN: + if (arg[1].arg_flags & AF_ARYOK) { + if (arg->arg_len == 1) { + arg->arg_type = O_LOCAL; + goto local; + } + else { + arg->arg_type = O_AASSIGN; + goto aassign; + } + } + else { + arg->arg_type = O_SASSIGN; + goto sassign; + } + case O_LOCAL: + local: + arglast[2] = arglast[1]; /* push a null array */ + /* FALL THROUGH */ + case O_AASSIGN: + aassign: + sp = do_assign(arg, + gimme,arglast); + goto array_return; + case O_SASSIGN: + sassign: +#ifdef TAINT + if (tainted && !st[2]->str_tainted) + tainted = 0; +#endif + STR_SSET(str, st[2]); + STABSET(str); + break; + case O_CHOP: + st -= arglast[0]; + str = arg->arg_ptr.arg_str; + for (sp = arglast[0] + 1; sp <= arglast[1]; sp++) + do_chop(str,st[sp]); + st += arglast[0]; + break; + case O_DEFINED: + if (arg[1].arg_type & A_DONT) { + sp = do_defined(str,arg, + gimme,arglast); + goto array_return; + } + else if (str->str_pok || str->str_nok) + goto say_yes; + goto say_no; + case O_UNDEF: + if (arg[1].arg_type & A_DONT) { + sp = do_undef(str,arg, + gimme,arglast); + goto array_return; + } + else if (str != stab_val(defstab)) { + if (str->str_len) { + if (str->str_state == SS_INCR) + Str_Grow(str,0); + Safefree(str->str_ptr); + str->str_ptr = Nullch; + str->str_len = 0; + } + str->str_pok = str->str_nok = 0; + STABSET(str); + } + goto say_undef; + case O_STUDY: + sp = do_study(str,arg, + gimme,arglast); + goto array_return; + case O_POW: + value = str_gnum(st[1]); + value = pow(value,str_gnum(st[2])); + goto donumset; + case O_MULTIPLY: + value = str_gnum(st[1]); + value *= str_gnum(st[2]); + goto donumset; + case O_DIVIDE: + if ((value = str_gnum(st[2])) == 0.0) + fatal("Illegal division by zero"); +#ifdef SLOPPYDIVIDE + /* insure that 20./5. == 4. */ + { + double x; + int k; + x = str_gnum(st[1]); + if ((double)(int)x == x && + (double)(int)value == value && + (k = (int)x/(int)value)*(int)value == (int)x) { + value = k; + } else { + value = x/value; + } + } +#else + value = str_gnum(st[1]) / value; +#endif + goto donumset; + case O_MODULO: + tmpulong = (unsigned long) str_gnum(st[2]); + if (tmpulong == 0L) + fatal("Illegal modulus zero"); +#ifndef lint + value = str_gnum(st[1]); + if (value >= 0.0) + value = (double)(((unsigned long)value) % tmpulong); + else { + tmplong = (long)value; + value = (double)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1; + } +#endif + goto donumset; + case O_ADD: + value = str_gnum(st[1]); + value += str_gnum(st[2]); + goto donumset; + case O_SUBTRACT: + value = str_gnum(st[1]); + value -= str_gnum(st[2]); + goto donumset; + case O_LEFT_SHIFT: + value = str_gnum(st[1]); + anum = (int)str_gnum(st[2]); +#ifndef lint + value = (double)(U_L(value) << anum); +#endif + goto donumset; + case O_RIGHT_SHIFT: + value = str_gnum(st[1]); + anum = (int)str_gnum(st[2]); +#ifndef lint + value = (double)(U_L(value) >> anum); +#endif + goto donumset; + case O_LT: + value = str_gnum(st[1]); + value = (value < str_gnum(st[2])) ? 1.0 : 0.0; + goto donumset; + case O_GT: + value = str_gnum(st[1]); + value = (value > str_gnum(st[2])) ? 1.0 : 0.0; + goto donumset; + case O_LE: + value = str_gnum(st[1]); + value = (value <= str_gnum(st[2])) ? 1.0 : 0.0; + goto donumset; + case O_GE: + value = str_gnum(st[1]); + value = (value >= str_gnum(st[2])) ? 1.0 : 0.0; + goto donumset; + case O_EQ: + if (dowarn) { + if ((!st[1]->str_nok && !looks_like_number(st[1])) || + (!st[2]->str_nok && !looks_like_number(st[2])) ) + warn("Possible use of == on string value"); + } + value = str_gnum(st[1]); + value = (value == str_gnum(st[2])) ? 1.0 : 0.0; + goto donumset; + case O_NE: + value = str_gnum(st[1]); + value = (value != str_gnum(st[2])) ? 1.0 : 0.0; + goto donumset; + case O_NCMP: + value = str_gnum(st[1]); + value -= str_gnum(st[2]); + if (value > 0.0) + value = 1.0; + else if (value < 0.0) + value = -1.0; + goto donumset; + case O_BIT_AND: + if (!sawvec || st[1]->str_nok || st[2]->str_nok) { + value = str_gnum(st[1]); +#ifndef lint + value = (double)(U_L(value) & U_L(str_gnum(st[2]))); +#endif + goto donumset; + } + else + do_vop(optype,str,st[1],st[2]); + break; + case O_XOR: + if (!sawvec || st[1]->str_nok || st[2]->str_nok) { + value = str_gnum(st[1]); +#ifndef lint + value = (double)(U_L(value) ^ U_L(str_gnum(st[2]))); +#endif + goto donumset; + } + else + do_vop(optype,str,st[1],st[2]); + break; + case O_BIT_OR: + if (!sawvec || st[1]->str_nok || st[2]->str_nok) { + value = str_gnum(st[1]); +#ifndef lint + value = (double)(U_L(value) | U_L(str_gnum(st[2]))); +#endif + goto donumset; + } + else + do_vop(optype,str,st[1],st[2]); + break; +/* use register in evaluating str_true() */ + case O_AND: + if (str_true(st[1])) { + anum = 2; + optype = O_ITEM2; + argflags = arg[anum].arg_flags; + if (gimme == G_ARRAY) + argflags |= AF_ARYOK; + argtype = arg[anum].arg_type & A_MASK; + argptr = arg[anum].arg_ptr; + maxarg = anum = 1; + sp = arglast[0]; + st -= sp; + goto re_eval; + } + else { + if (assigning) { + str_sset(str, st[1]); + STABSET(str); + } + else + str = st[1]; + break; + } + case O_OR: + if (str_true(st[1])) { + if (assigning) { + str_sset(str, st[1]); + STABSET(str); + } + else + str = st[1]; + break; + } + else { + anum = 2; + optype = O_ITEM2; + argflags = arg[anum].arg_flags; + if (gimme == G_ARRAY) + argflags |= AF_ARYOK; + argtype = arg[anum].arg_type & A_MASK; + argptr = arg[anum].arg_ptr; + maxarg = anum = 1; + sp = arglast[0]; + st -= sp; + goto re_eval; + } + case O_COND_EXPR: + anum = (str_true(st[1]) ? 2 : 3); + optype = (anum == 2 ? O_ITEM2 : O_ITEM3); + argflags = arg[anum].arg_flags; + if (gimme == G_ARRAY) + argflags |= AF_ARYOK; + argtype = arg[anum].arg_type & A_MASK; + argptr = arg[anum].arg_ptr; + maxarg = anum = 1; + sp = arglast[0]; + st -= sp; + goto re_eval; + case O_COMMA: + if (gimme == G_ARRAY) + goto array_return; + str = st[2]; + break; + case O_NEGATE: + value = -str_gnum(st[1]); + goto donumset; + case O_NOT: +#ifdef NOTNOT + { char xxx = str_true(st[1]); value = (double) !xxx; } +#else + value = (double) !str_true(st[1]); +#endif + goto donumset; + case O_COMPLEMENT: + if (!sawvec || st[1]->str_nok) { +#ifndef lint + value = (double) ~U_L(str_gnum(st[1])); +#endif + goto donumset; + } + else { + STR_SSET(str,st[1]); + tmps = str_get(str); + for (anum = str->str_cur; anum; anum--, tmps++) + *tmps = ~*tmps; + } + break; + case O_SELECT: + stab_efullname(str,defoutstab); + if (maxarg > 0) { + if ((arg[1].arg_type & A_MASK) == A_WORD) + defoutstab = arg[1].arg_ptr.arg_stab; + else + defoutstab = stabent(str_get(st[1]),TRUE); + if (!stab_io(defoutstab)) + stab_io(defoutstab) = stio_new(); + curoutstab = defoutstab; + } + STABSET(str); + break; + case O_WRITE: + if (maxarg == 0) + stab = defoutstab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) { + if (!(stab = arg[1].arg_ptr.arg_stab)) + stab = defoutstab; + } + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab_io(stab)) { + str_set(str, No); + STABSET(str); + break; + } + curoutstab = stab; + fp = stab_io(stab)->ofp; + debarg = arg; + if (stab_io(stab)->fmt_stab) + form = stab_form(stab_io(stab)->fmt_stab); + else + form = stab_form(stab); + if (!form || !fp) { + if (dowarn) { + if (form) + warn("No format for filehandle"); + else { + if (stab_io(stab)->ifp) + warn("Filehandle only opened for input"); + else + warn("Write on closed filehandle"); + } + } + str_set(str, No); + STABSET(str); + break; + } + format(&outrec,form,sp); + do_write(&outrec,stab,sp); + if (stab_io(stab)->flags & IOF_FLUSH) + (void)fflush(fp); + str_set(str, Yes); + STABSET(str); + break; + case O_DBMOPEN: +#ifdef SOME_DBM + anum = arg[1].arg_type & A_MASK; + if (anum == A_WORD || anum == A_STAB) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (st[3]->str_nok || st[3]->str_pok) + anum = (int)str_gnum(st[3]); + else + anum = -1; + value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum); + goto donumset; +#else + fatal("No dbm or ndbm on this machine"); +#endif + case O_DBMCLOSE: +#ifdef SOME_DBM + anum = arg[1].arg_type & A_MASK; + if (anum == A_WORD || anum == A_STAB) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + hdbmclose(stab_hash(stab)); + goto say_yes; +#else + fatal("No dbm or ndbm on this machine"); +#endif + case O_OPEN: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + tmps = str_get(st[2]); + if (do_open(stab,tmps,st[2]->str_cur)) { + value = (double)forkprocess; + stab_io(stab)->lines = 0; + goto donumset; + } + else if (forkprocess == 0) /* we are a new child */ + goto say_zero; + else + goto say_undef; + /* break; */ + case O_TRANS: + value = (double) do_trans(str,arg); + str = arg->arg_ptr.arg_str; + goto donumset; + case O_NTRANS: + str_set(arg->arg_ptr.arg_str, do_trans(str,arg) == 0 ? Yes : No); + str = arg->arg_ptr.arg_str; + break; + case O_CLOSE: + if (maxarg == 0) + stab = defoutstab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + str_set(str, do_close(stab,TRUE) ? Yes : No ); + STABSET(str); + break; + case O_EACH: + sp = do_each(str,stab_hash(arg[1].arg_ptr.arg_stab), + gimme,arglast); + goto array_return; + case O_VALUES: + case O_KEYS: + sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype, + gimme,arglast); + goto array_return; + case O_LARRAY: + str->str_nok = str->str_pok = 0; + str->str_u.str_stab = arg[1].arg_ptr.arg_stab; + str->str_state = SS_ARY; + break; + case O_ARRAY: + ary = stab_array(arg[1].arg_ptr.arg_stab); + maxarg = ary->ary_fill + 1; + if (gimme == G_ARRAY) { /* array wanted */ + sp = arglast[0]; + st -= sp; + if (maxarg > 0 && sp + maxarg > stack->ary_max) { + astore(stack,sp + maxarg, Nullstr); + st = stack->ary_array; + } + st += sp; + Copy(ary->ary_array, &st[1], maxarg, STR*); + sp += maxarg; + goto array_return; + } + else { + value = (double)maxarg; + goto donumset; + } + case O_AELEM: + anum = ((int)str_gnum(st[2])) - arybase; + str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,FALSE); + break; + case O_DELETE: + tmpstab = arg[1].arg_ptr.arg_stab; + tmps = str_get(st[2]); + str = hdelete(stab_hash(tmpstab),tmps,st[2]->str_cur); + if (tmpstab == envstab) + my_setenv(tmps,Nullch); + if (!str) + goto say_undef; + break; + case O_LHASH: + str->str_nok = str->str_pok = 0; + str->str_u.str_stab = arg[1].arg_ptr.arg_stab; + str->str_state = SS_HASH; + break; + case O_HASH: + if (gimme == G_ARRAY) { /* array wanted */ + sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype, + gimme,arglast); + goto array_return; + } + else { + tmpstab = arg[1].arg_ptr.arg_stab; + if (!stab_hash(tmpstab)->tbl_fill) + goto say_zero; + sprintf(buf,"%d/%d",stab_hash(tmpstab)->tbl_fill, + stab_hash(tmpstab)->tbl_max+1); + str_set(str,buf); + } + break; + case O_HELEM: + tmpstab = arg[1].arg_ptr.arg_stab; + tmps = str_get(st[2]); + str = hfetch(stab_hash(tmpstab),tmps,st[2]->str_cur,FALSE); + break; + case O_LAELEM: + anum = ((int)str_gnum(st[2])) - arybase; + str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,TRUE); + if (!str || str == &str_undef) + fatal("Assignment to non-creatable value, subscript %d",anum); + break; + case O_LHELEM: + tmpstab = arg[1].arg_ptr.arg_stab; + tmps = str_get(st[2]); + anum = st[2]->str_cur; + str = hfetch(stab_hash(tmpstab),tmps,anum,TRUE); + if (!str || str == &str_undef) + fatal("Assignment to non-creatable value, subscript \"%s\"",tmps); + if (tmpstab == envstab) /* heavy wizardry going on here */ + str_magic(str, tmpstab, 'E', tmps, anum); /* str is now magic */ + /* he threw the brick up into the air */ + else if (tmpstab == sigstab) + str_magic(str, tmpstab, 'S', tmps, anum); +#ifdef SOME_DBM + else if (stab_hash(tmpstab)->tbl_dbm) + str_magic(str, tmpstab, 'D', tmps, anum); +#endif + else if (tmpstab == DBline) + str_magic(str, tmpstab, 'L', tmps, anum); + break; + case O_LSLICE: + anum = 2; + argtype = FALSE; + goto do_slice_already; + case O_ASLICE: + anum = 1; + argtype = FALSE; + goto do_slice_already; + case O_HSLICE: + anum = 0; + argtype = FALSE; + goto do_slice_already; + case O_LASLICE: + anum = 1; + argtype = TRUE; + goto do_slice_already; + case O_LHSLICE: + anum = 0; + argtype = TRUE; + do_slice_already: + sp = do_slice(arg[1].arg_ptr.arg_stab,str,anum,argtype, + gimme,arglast); + goto array_return; + case O_SPLICE: + sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),gimme,arglast); + goto array_return; + case O_PUSH: + if (arglast[2] - arglast[1] != 1) + str = do_push(stab_array(arg[1].arg_ptr.arg_stab),arglast); + else { + str = Str_new(51,0); /* must copy the STR */ + str_sset(str,st[2]); + (void)apush(stab_array(arg[1].arg_ptr.arg_stab),str); + } + break; + case O_POP: + str = apop(ary = stab_array(arg[1].arg_ptr.arg_stab)); + goto staticalization; + case O_SHIFT: + str = ashift(ary = stab_array(arg[1].arg_ptr.arg_stab)); + staticalization: + if (!str) + goto say_undef; + if (ary->ary_flags & ARF_REAL) + (void)str_2mortal(str); + break; + case O_UNPACK: + sp = do_unpack(str,gimme,arglast); + goto array_return; + case O_SPLIT: + value = str_gnum(st[3]); + sp = do_split(str, arg[2].arg_ptr.arg_spat, (int)value, + gimme,arglast); + goto array_return; + case O_LENGTH: + if (maxarg < 1) + value = (double)str_len(stab_val(defstab)); + else + value = (double)str_len(st[1]); + goto donumset; + case O_SPRINTF: + do_sprintf(str, sp-arglast[0], st+1); + break; + case O_SUBSTR: + anum = ((int)str_gnum(st[2])) - arybase; /* anum=where to start*/ + tmps = str_get(st[1]); /* force conversion to string */ + /*SUPPRESS 560*/ + if (argtype = (str == st[1])) + str = arg->arg_ptr.arg_str; + if (anum < 0) + anum += st[1]->str_cur + arybase; + if (anum < 0 || anum > st[1]->str_cur) + str_nset(str,"",0); + else { + optype = maxarg < 3 ? st[1]->str_cur : (int)str_gnum(st[3]); + if (optype < 0) + optype = 0; + tmps += anum; + anum = st[1]->str_cur - anum; /* anum=how many bytes left*/ + if (anum > optype) + anum = optype; + str_nset(str, tmps, anum); + if (argtype) { /* it's an lvalue! */ + lstr = (struct lstring*)str; + str->str_magic = st[1]; + st[1]->str_rare = 's'; + lstr->lstr_offset = tmps - str_get(st[1]); + lstr->lstr_len = anum; + } + } + break; + case O_PACK: + /*SUPPRESS 701*/ + (void)do_pack(str,arglast); + break; + case O_GREP: + sp = do_grep(arg,str,gimme,arglast); + goto array_return; + case O_JOIN: + do_join(str,arglast); + break; + case O_SLT: + tmps = str_get(st[1]); + value = (double) (str_cmp(st[1],st[2]) < 0); + goto donumset; + case O_SGT: + tmps = str_get(st[1]); + value = (double) (str_cmp(st[1],st[2]) > 0); + goto donumset; + case O_SLE: + tmps = str_get(st[1]); + value = (double) (str_cmp(st[1],st[2]) <= 0); + goto donumset; + case O_SGE: + tmps = str_get(st[1]); + value = (double) (str_cmp(st[1],st[2]) >= 0); + goto donumset; + case O_SEQ: + tmps = str_get(st[1]); + value = (double) str_eq(st[1],st[2]); + goto donumset; + case O_SNE: + tmps = str_get(st[1]); + value = (double) !str_eq(st[1],st[2]); + goto donumset; + case O_SCMP: + tmps = str_get(st[1]); + value = (double) str_cmp(st[1],st[2]); + goto donumset; + case O_SUBR: + sp = do_subr(arg,gimme,arglast); + st = stack->ary_array + arglast[0]; /* maybe realloced */ + goto array_return; + case O_DBSUBR: + sp = do_subr(arg,gimme,arglast); + st = stack->ary_array + arglast[0]; /* maybe realloced */ + goto array_return; + case O_CALLER: + sp = do_caller(arg,maxarg,gimme,arglast); + st = stack->ary_array + arglast[0]; /* maybe realloced */ + goto array_return; + case O_SORT: + sp = do_sort(str,arg, + gimme,arglast); + goto array_return; + case O_REVERSE: + if (gimme == G_ARRAY) + sp = do_reverse(arglast); + else + sp = do_sreverse(str, arglast); + goto array_return; + case O_WARN: + if (arglast[2] - arglast[1] != 1) { + do_join(str,arglast); + tmps = str_get(str); + } + else { + str = st[2]; + tmps = str_get(st[2]); + } + if (!tmps || !*tmps) + tmps = "Warning: something's wrong"; + warn("%s",tmps); + goto say_yes; + case O_DIE: + if (arglast[2] - arglast[1] != 1) { + do_join(str,arglast); + tmps = str_get(str); + } + else { + str = st[2]; + tmps = str_get(st[2]); + } + if (!tmps || !*tmps) + tmps = "Died"; + fatal("%s",tmps); + goto say_zero; + case O_PRTF: + case O_PRINT: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab) + stab = defoutstab; + if (!stab_io(stab)) { + if (dowarn) + warn("Filehandle never opened"); + goto say_zero; + } + if (!(fp = stab_io(stab)->ofp)) { + if (dowarn) { + if (stab_io(stab)->ifp) + warn("Filehandle opened only for input"); + else + warn("Print on closed filehandle"); + } + goto say_zero; + } + else { + if (optype == O_PRTF || arglast[2] - arglast[1] != 1) + value = (double)do_aprint(arg,fp,arglast); + else { + value = (double)do_print(st[2],fp); + if (orslen && optype == O_PRINT) + if (fwrite(ors, 1, orslen, fp) == 0) + goto say_zero; + } + if (stab_io(stab)->flags & IOF_FLUSH) + if (fflush(fp) == EOF) + goto say_zero; + } + goto donumset; + case O_CHDIR: + if (maxarg < 1) + tmps = Nullch; + else + tmps = str_get(st[1]); + if (!tmps || !*tmps) { + tmpstr = hfetch(stab_hash(envstab),"HOME",4,FALSE); + tmps = str_get(tmpstr); + } + if (!tmps || !*tmps) { + tmpstr = hfetch(stab_hash(envstab),"LOGDIR",6,FALSE); + tmps = str_get(tmpstr); + } +#ifdef TAINT + taintproper("Insecure dependency in chdir"); +#endif + value = (double)(chdir(tmps) >= 0); + goto donumset; + case O_EXIT: + if (maxarg < 1) + anum = 0; + else + anum = (int)str_gnum(st[1]); + exit(anum); + goto say_zero; + case O_RESET: + if (maxarg < 1) + tmps = ""; + else + tmps = str_get(st[1]); + str_reset(tmps,curcmd->c_stash); + value = 1.0; + goto donumset; + case O_LIST: + if (gimme == G_ARRAY) + goto array_return; + if (maxarg > 0) + str = st[sp - arglast[0]]; /* unwanted list, return last item */ + else + str = &str_undef; + break; + case O_EOF: + if (maxarg <= 0) + stab = last_in_stab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + str_set(str, do_eof(stab) ? Yes : No); + STABSET(str); + break; + case O_GETC: + if (maxarg <= 0) + stab = stdinstab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab) + stab = argvstab; + if (!stab || do_eof(stab)) /* make sure we have fp with something */ + goto say_undef; + else { +#ifdef TAINT + tainted = 1; +#endif + str_set(str," "); + *str->str_ptr = getc(stab_io(stab)->ifp); /* should never be EOF */ + } + STABSET(str); + break; + case O_TELL: + if (maxarg <= 0) + stab = last_in_stab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_tell(stab); +#else + (void)do_tell(stab); +#endif + goto donumset; + case O_RECV: + case O_READ: + case O_SYSREAD: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + tmps = str_get(st[2]); + anum = (int)str_gnum(st[3]); + errno = 0; + maxarg = sp - arglast[0]; + if (maxarg > 4) + warn("Too many args on read"); + if (maxarg == 4) + maxarg = (int)str_gnum(st[4]); + else + maxarg = 0; + if (!stab_io(stab) || !stab_io(stab)->ifp) + goto say_undef; +#ifdef HAS_SOCKET + if (optype == O_RECV) { + argtype = sizeof buf; + STR_GROW(st[2], anum+1), (tmps = str_get(st[2])); /* sneaky */ + anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, maxarg, + buf, &argtype); + if (anum >= 0) { + st[2]->str_cur = anum; + st[2]->str_ptr[anum] = '\0'; + str_nset(str,buf,argtype); + } + else + str_sset(str,&str_undef); + break; + } +#else + if (optype == O_RECV) + goto badsock; +#endif + STR_GROW(st[2], anum+maxarg+1), (tmps = str_get(st[2])); /* sneaky */ + if (optype == O_SYSREAD) { + anum = read(fileno(stab_io(stab)->ifp), tmps+maxarg, anum); + } + else +#ifdef HAS_SOCKET + if (stab_io(stab)->type == 's') { + argtype = sizeof buf; + anum = recvfrom(fileno(stab_io(stab)->ifp), tmps+maxarg, anum, 0, + buf, &argtype); + } + else +#endif + anum = fread(tmps+maxarg, 1, anum, stab_io(stab)->ifp); + if (anum < 0) + goto say_undef; + st[2]->str_cur = anum+maxarg; + st[2]->str_ptr[anum+maxarg] = '\0'; + value = (double)anum; + goto donumset; + case O_SYSWRITE: + case O_SEND: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + tmps = str_get(st[2]); + anum = (int)str_gnum(st[3]); + errno = 0; + stio = stab_io(stab); + maxarg = sp - arglast[0]; + if (!stio || !stio->ifp) { + anum = -1; + if (dowarn) { + if (optype == O_SYSWRITE) + warn("Syswrite on closed filehandle"); + else + warn("Send on closed socket"); + } + } + else if (optype == O_SYSWRITE) { + if (maxarg > 4) + warn("Too many args on syswrite"); + if (maxarg == 4) + optype = (int)str_gnum(st[4]); + else + optype = 0; + anum = write(fileno(stab_io(stab)->ifp), tmps+optype, anum); + } +#ifdef HAS_SOCKET + else if (maxarg >= 4) { + if (maxarg > 4) + warn("Too many args on send"); + tmps2 = str_get(st[4]); + anum = sendto(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, + anum, tmps2, st[4]->str_cur); + } + else + anum = send(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, anum); +#else + else + goto badsock; +#endif + if (anum < 0) + goto say_undef; + value = (double)anum; + goto donumset; + case O_SEEK: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + value = str_gnum(st[2]); + str_set(str, do_seek(stab, + (long)value, (int)str_gnum(st[3]) ) ? Yes : No); + STABSET(str); + break; + case O_RETURN: + tmps = "_SUB_"; /* just fake up a "last _SUB_" */ + optype = O_LAST; + if (curcsv && curcsv->wantarray == G_ARRAY) { + lastretstr = Nullstr; + lastspbase = arglast[1]; + lastsize = arglast[2] - arglast[1]; + } + else + lastretstr = str_mortal(st[arglast[2] - arglast[0]]); + goto dopop; + case O_REDO: + case O_NEXT: + case O_LAST: + tmps = Nullch; + if (maxarg > 0) { + tmps = str_get(arg[1].arg_ptr.arg_str); + dopop: + while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label || + strNE(tmps,loop_stack[loop_ptr].loop_label) )) { +#ifdef DEBUGGING + if (debug & 4) { + deb("(Skipping label #%d %s)\n",loop_ptr, + loop_stack[loop_ptr].loop_label); + } +#endif + loop_ptr--; + } +#ifdef DEBUGGING + if (debug & 4) { + deb("(Found label #%d %s)\n",loop_ptr, + loop_stack[loop_ptr].loop_label); + } +#endif + } + if (loop_ptr < 0) { + if (tmps && strEQ(tmps, "_SUB_")) + fatal("Can't return outside a subroutine"); + fatal("Bad label: %s", maxarg > 0 ? tmps : ""); + } + if (!lastretstr && optype == O_LAST && lastsize) { + st -= arglast[0]; + st += lastspbase + 1; + optype = loop_stack[loop_ptr].loop_sp - lastspbase; /* negative */ + if (optype) { + for (anum = lastsize; anum > 0; anum--,st++) + st[optype] = str_mortal(st[0]); + } + longjmp(loop_stack[loop_ptr].loop_env, O_LAST); + } + longjmp(loop_stack[loop_ptr].loop_env, optype); + case O_DUMP: + case O_GOTO:/* shudder */ + goto_targ = str_get(arg[1].arg_ptr.arg_str); + if (!*goto_targ) + goto_targ = Nullch; /* just restart from top */ + if (optype == O_DUMP) { + do_undump = 1; + my_unexec(); + } + longjmp(top_env, 1); + case O_INDEX: + tmps = str_get(st[1]); + if (maxarg < 3) + anum = 0; + else { + anum = (int) str_gnum(st[3]) - arybase; + if (anum < 0) + anum = 0; + else if (anum > st[1]->str_cur) + anum = st[1]->str_cur; + } +#ifndef lint + if (!(tmps2 = fbminstr((unsigned char*)tmps + anum, + (unsigned char*)tmps + st[1]->str_cur, st[2]))) +#else + if (tmps2 = fbminstr(Null(unsigned char*),Null(unsigned char*),Nullstr)) +#endif + value = (double)(-1 + arybase); + else + value = (double)(tmps2 - tmps + arybase); + goto donumset; + case O_RINDEX: + tmps = str_get(st[1]); + tmps2 = str_get(st[2]); + if (maxarg < 3) + anum = st[1]->str_cur; + else { + anum = (int) str_gnum(st[3]) - arybase + st[2]->str_cur; + if (anum < 0) + anum = 0; + else if (anum > st[1]->str_cur) + anum = st[1]->str_cur; + } +#ifndef lint + if (!(tmps2 = rninstr(tmps, tmps + anum, + tmps2, tmps2 + st[2]->str_cur))) +#else + if (tmps2 = rninstr(Nullch,Nullch,Nullch,Nullch)) +#endif + value = (double)(-1 + arybase); + else + value = (double)(tmps2 - tmps + arybase); + goto donumset; + case O_TIME: +#ifndef lint + value = (double) time(Null(long*)); +#endif + goto donumset; + case O_TMS: + sp = do_tms(str,gimme,arglast); + goto array_return; + case O_LOCALTIME: + if (maxarg < 1) + (void)time(&when); + else + when = (time_t)str_gnum(st[1]); + sp = do_time(str,localtime(&when), + gimme,arglast); + goto array_return; + case O_GMTIME: + if (maxarg < 1) + (void)time(&when); + else + when = (time_t)str_gnum(st[1]); + sp = do_time(str,gmtime(&when), + gimme,arglast); + goto array_return; + case O_TRUNCATE: + sp = do_truncate(str,arg, + gimme,arglast); + goto array_return; + case O_LSTAT: + case O_STAT: + sp = do_stat(str,arg, + gimme,arglast); + goto array_return; + case O_CRYPT: +#ifdef HAS_CRYPT + tmps = str_get(st[1]); +#ifdef FCRYPT + str_set(str,fcrypt(tmps,str_get(st[2]))); +#else + str_set(str,crypt(tmps,str_get(st[2]))); +#endif +#else + fatal( + "The crypt() function is unimplemented due to excessive paranoia."); +#endif + break; + case O_ATAN2: + value = str_gnum(st[1]); + value = atan2(value,str_gnum(st[2])); + goto donumset; + case O_SIN: + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + value = sin(value); + goto donumset; + case O_COS: + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + value = cos(value); + goto donumset; + case O_RAND: + if (maxarg < 1) + value = 1.0; + else + value = str_gnum(st[1]); + if (value == 0.0) + value = 1.0; +#if RANDBITS == 31 + value = rand() * value / 2147483648.0; +#else +#if RANDBITS == 16 + value = rand() * value / 65536.0; +#else +#if RANDBITS == 15 + value = rand() * value / 32768.0; +#else + value = rand() * value / (double)(((unsigned long)1) << RANDBITS); +#endif +#endif +#endif + goto donumset; + case O_SRAND: + if (maxarg < 1) { + (void)time(&when); + anum = when; + } + else + anum = (int)str_gnum(st[1]); + (void)srand(anum); + goto say_yes; + case O_EXP: + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + value = exp(value); + goto donumset; + case O_LOG: + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + if (value <= 0.0) + fatal("Can't take log of %g\n", value); + value = log(value); + goto donumset; + case O_SQRT: + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + if (value < 0.0) + fatal("Can't take sqrt of %g\n", value); + value = sqrt(value); + goto donumset; + case O_INT: + if (maxarg < 1) + value = str_gnum(stab_val(defstab)); + else + value = str_gnum(st[1]); + if (value >= 0.0) + (void)modf(value,&value); + else { + (void)modf(-value,&value); + value = -value; + } + goto donumset; + case O_ORD: + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); +#ifndef I286 + value = (double) (*tmps & 255); +#else + anum = (int) *tmps; + value = (double) (anum & 255); +#endif + goto donumset; + case O_ALARM: +#ifdef HAS_ALARM + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); + if (!tmps) + tmps = "0"; + anum = alarm((unsigned int)atoi(tmps)); + if (anum < 0) + goto say_undef; + value = (double)anum; + goto donumset; +#else + fatal("Unsupported function alarm"); + break; +#endif + case O_SLEEP: + if (maxarg < 1) + tmps = Nullch; + else + tmps = str_get(st[1]); + (void)time(&when); + if (!tmps || !*tmps) + sleep((32767<<16)+32767); + else + sleep((unsigned int)atoi(tmps)); +#ifndef lint + value = (double)when; + (void)time(&when); + value = ((double)when) - value; +#endif + goto donumset; + case O_RANGE: + sp = do_range(gimme,arglast); + goto array_return; + case O_F_OR_R: + if (gimme == G_ARRAY) { /* it's a range */ + /* can we optimize to constant array? */ + if ((arg[1].arg_type & A_MASK) == A_SINGLE && + (arg[2].arg_type & A_MASK) == A_SINGLE) { + st[2] = arg[2].arg_ptr.arg_str; + sp = do_range(gimme,arglast); + st = stack->ary_array; + maxarg = sp - arglast[0]; + str_free(arg[1].arg_ptr.arg_str); + arg[1].arg_ptr.arg_str = Nullstr; + str_free(arg[2].arg_ptr.arg_str); + arg[2].arg_ptr.arg_str = Nullstr; + arg->arg_type = O_ARRAY; + arg[1].arg_type = A_STAB|A_DONT; + arg->arg_len = 1; + stab = arg[1].arg_ptr.arg_stab = aadd(genstab()); + ary = stab_array(stab); + afill(ary,maxarg - 1); + anum = maxarg; + st += arglast[0]+1; + while (maxarg-- > 0) + ary->ary_array[maxarg] = str_smake(st[maxarg]); + st -= arglast[0]+1; + goto array_return; + } + arg->arg_type = optype = O_RANGE; + maxarg = arg->arg_len = 2; + anum = 2; + arg[anum].arg_flags &= ~AF_ARYOK; + argflags = arg[anum].arg_flags; + argtype = arg[anum].arg_type & A_MASK; + arg[anum].arg_type = argtype; + argptr = arg[anum].arg_ptr; + sp = arglast[0]; + st -= sp; + sp++; + goto re_eval; + } + arg->arg_type = O_FLIP; + /* FALL THROUGH */ + case O_FLIP: + if ((arg[1].arg_type & A_MASK) == A_SINGLE ? + last_in_stab && (int)str_gnum(st[1]) == stab_io(last_in_stab)->lines + : + str_true(st[1]) ) { + arg[2].arg_type &= ~A_DONT; + arg[1].arg_type |= A_DONT; + arg->arg_type = optype = O_FLOP; + if (arg->arg_flags & AF_COMMON) { + str_numset(str,0.0); + anum = 2; + argflags = arg[2].arg_flags; + argtype = arg[2].arg_type & A_MASK; + argptr = arg[2].arg_ptr; + sp = arglast[0]; + st -= sp++; + goto re_eval; + } + else { + str_numset(str,1.0); + break; + } + } + str_set(str,""); + break; + case O_FLOP: + str_inc(str); + if ((arg[2].arg_type & A_MASK) == A_SINGLE ? + last_in_stab && (int)str_gnum(st[2]) == stab_io(last_in_stab)->lines + : + str_true(st[2]) ) { + arg->arg_type = O_FLIP; + arg[1].arg_type &= ~A_DONT; + arg[2].arg_type |= A_DONT; + str_cat(str,"E0"); + } + break; + case O_FORK: +#ifdef HAS_FORK + anum = fork(); + if (anum < 0) + goto say_undef; + if (!anum) { + /*SUPPRESS 560*/ + if (tmpstab = stabent("$",allstabs)) + str_numset(STAB_STR(tmpstab),(double)getpid()); + hclear(pidstatus, FALSE); /* no kids, so don't wait for 'em */ + } + value = (double)anum; + goto donumset; +#else + fatal("Unsupported function fork"); + break; +#endif + case O_WAIT: +#ifdef HAS_WAIT +#ifndef lint + anum = wait(&argflags); + if (anum > 0) + pidgone(anum,argflags); + value = (double)anum; +#endif + statusvalue = (unsigned short)argflags; + goto donumset; +#else + fatal("Unsupported function wait"); + break; +#endif + case O_WAITPID: +#ifdef HAS_WAIT +#ifndef lint + anum = (int)str_gnum(st[1]); + optype = (int)str_gnum(st[2]); + anum = wait4pid(anum, &argflags,optype); + value = (double)anum; +#endif + statusvalue = (unsigned short)argflags; + goto donumset; +#else + fatal("Unsupported function wait"); + break; +#endif + case O_SYSTEM: +#ifdef HAS_FORK +#ifdef TAINT + if (arglast[2] - arglast[1] == 1) { + taintenv(); + tainted |= st[2]->str_tainted; + taintproper("Insecure dependency in system"); + } +#endif + while ((anum = vfork()) == -1) { + if (errno != EAGAIN) { + value = -1.0; + goto donumset; + } + sleep(5); + } + if (anum > 0) { +#ifndef lint + ihand = signal(SIGINT, SIG_IGN); + qhand = signal(SIGQUIT, SIG_IGN); + argtype = wait4pid(anum, &argflags, 0); +#else + ihand = qhand = 0; +#endif + (void)signal(SIGINT, ihand); + (void)signal(SIGQUIT, qhand); + statusvalue = (unsigned short)argflags; + if (argtype < 0) + value = -1.0; + else { + value = (double)((unsigned int)argflags & 0xffff); + } + do_execfree(); /* free any memory child malloced on vfork */ + goto donumset; + } + if ((arg[1].arg_type & A_MASK) == A_STAB) + value = (double)do_aexec(st[1],arglast); + else if (arglast[2] - arglast[1] != 1) + value = (double)do_aexec(Nullstr,arglast); + else { + value = (double)do_exec(str_get(str_mortal(st[2]))); + } + _exit(-1); +#else /* ! FORK */ + if ((arg[1].arg_type & A_MASK) == A_STAB) + value = (double)do_aspawn(st[1],arglast); + else if (arglast[2] - arglast[1] != 1) + value = (double)do_aspawn(Nullstr,arglast); + else { + value = (double)do_spawn(str_get(str_mortal(st[2]))); + } + goto donumset; +#endif /* FORK */ + case O_EXEC_OP: + if ((arg[1].arg_type & A_MASK) == A_STAB) + value = (double)do_aexec(st[1],arglast); + else if (arglast[2] - arglast[1] != 1) + value = (double)do_aexec(Nullstr,arglast); + else { +#ifdef TAINT + taintenv(); + tainted |= st[2]->str_tainted; + taintproper("Insecure dependency in exec"); +#endif + value = (double)do_exec(str_get(str_mortal(st[2]))); + } + goto donumset; + case O_HEX: + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); + value = (double)scanhex(tmps, 99, &argtype); + goto donumset; + + case O_OCT: + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); + while (*tmps && (isSPACE(*tmps) || *tmps == '0')) + tmps++; + if (*tmps == 'x') + value = (double)scanhex(++tmps, 99, &argtype); + else + value = (double)scanoct(tmps, 99, &argtype); + goto donumset; + +/* These common exits are hidden here in the middle of the switches for the + benefit of those machines with limited branch addressing. Sigh. */ + +array_return: +#ifdef DEBUGGING + if (debug) { + dlevel--; + if (debug & 8) { + anum = sp - arglast[0]; + switch (anum) { + case 0: + deb("%s RETURNS ()\n",opname[optype]); + break; + case 1: + deb("%s RETURNS (\"%s\")\n",opname[optype], + st[1] ? str_get(st[1]) : ""); + break; + default: + tmps = st[1] ? str_get(st[1]) : ""; + deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\")\n",opname[optype], + anum,tmps,anum==2?"":"...,", + st[anum] ? str_get(st[anum]) : ""); + break; + } + } + } +#endif + return sp; + +say_yes: + str = &str_yes; + goto normal_return; + +say_no: + str = &str_no; + goto normal_return; + +say_undef: + str = &str_undef; + goto normal_return; + +say_zero: + value = 0.0; + /* FALL THROUGH */ + +donumset: + str_numset(str,value); + STABSET(str); + st[1] = str; +#ifdef DEBUGGING + if (debug) { + dlevel--; + if (debug & 8) + deb("%s RETURNS \"%f\"\n",opname[optype],value); + } +#endif + return arglast[0] + 1; +#ifdef SMALLSWITCHES + } + else + switch (optype) { +#endif + case O_CHOWN: +#ifdef HAS_CHOWN + value = (double)apply(optype,arglast); + goto donumset; +#else + fatal("Unsupported function chown"); + break; +#endif + case O_KILL: +#ifdef HAS_KILL + value = (double)apply(optype,arglast); + goto donumset; +#else + fatal("Unsupported function kill"); + break; +#endif + case O_UNLINK: + case O_CHMOD: + case O_UTIME: + value = (double)apply(optype,arglast); + goto donumset; + case O_UMASK: +#ifdef HAS_UMASK + if (maxarg < 1) { + anum = umask(0); + (void)umask(anum); + } + else + anum = umask((int)str_gnum(st[1])); + value = (double)anum; +#ifdef TAINT + taintproper("Insecure dependency in umask"); +#endif + goto donumset; +#else + fatal("Unsupported function umask"); + break; +#endif +#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) + case O_MSGGET: + case O_SHMGET: + case O_SEMGET: + if ((anum = do_ipcget(optype, arglast)) == -1) + goto say_undef; + value = (double)anum; + goto donumset; + case O_MSGCTL: + case O_SHMCTL: + case O_SEMCTL: + anum = do_ipcctl(optype, arglast); + if (anum == -1) + goto say_undef; + if (anum != 0) { + value = (double)anum; + goto donumset; + } + str_set(str,"0 but true"); + STABSET(str); + break; + case O_MSGSND: + value = (double)(do_msgsnd(arglast) >= 0); + goto donumset; + case O_MSGRCV: + value = (double)(do_msgrcv(arglast) >= 0); + goto donumset; + case O_SEMOP: + value = (double)(do_semop(arglast) >= 0); + goto donumset; + case O_SHMREAD: + case O_SHMWRITE: + value = (double)(do_shmio(optype, arglast) >= 0); + goto donumset; +#else /* not SYSVIPC */ + case O_MSGGET: + case O_MSGCTL: + case O_MSGSND: + case O_MSGRCV: + case O_SEMGET: + case O_SEMCTL: + case O_SEMOP: + case O_SHMGET: + case O_SHMCTL: + case O_SHMREAD: + case O_SHMWRITE: + fatal("System V IPC is not implemented on this machine"); +#endif /* not SYSVIPC */ + case O_RENAME: + tmps = str_get(st[1]); + tmps2 = str_get(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in rename"); +#endif +#ifdef HAS_RENAME + value = (double)(rename(tmps,tmps2) >= 0); +#else + if (same_dirent(tmps2, tmps)) /* can always rename to same name */ + anum = 1; + else { + if (euid || stat(tmps2,&statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) + (void)UNLINK(tmps2); + if (!(anum = link(tmps,tmps2))) + anum = UNLINK(tmps); + } + value = (double)(anum >= 0); +#endif + goto donumset; + case O_LINK: +#ifdef HAS_LINK + tmps = str_get(st[1]); + tmps2 = str_get(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in link"); +#endif + value = (double)(link(tmps,tmps2) >= 0); + goto donumset; +#else + fatal("Unsupported function link"); + break; +#endif + case O_MKDIR: + tmps = str_get(st[1]); + anum = (int)str_gnum(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in mkdir"); +#endif +#ifdef HAS_MKDIR + value = (double)(mkdir(tmps,anum) >= 0); + goto donumset; +#else + (void)strcpy(buf,"mkdir "); +#endif +#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) + one_liner: + for (tmps2 = buf+6; *tmps; ) { + *tmps2++ = '\\'; + *tmps2++ = *tmps++; + } + (void)strcpy(tmps2," 2>&1"); + rsfp = mypopen(buf,"r"); + if (rsfp) { + *buf = '\0'; + tmps2 = fgets(buf,sizeof buf,rsfp); + (void)mypclose(rsfp); + if (tmps2 != Nullch) { + for (errno = 1; errno < sys_nerr; errno++) { + if (instr(buf,sys_errlist[errno])) /* you don't see this */ + goto say_zero; + } + errno = 0; +#ifndef EACCES +#define EACCES EPERM +#endif + if (instr(buf,"cannot make")) + errno = EEXIST; + else if (instr(buf,"existing file")) + errno = EEXIST; + else if (instr(buf,"ile exists")) + errno = EEXIST; + else if (instr(buf,"non-exist")) + errno = ENOENT; + else if (instr(buf,"does not exist")) + errno = ENOENT; + else if (instr(buf,"not empty")) + errno = EBUSY; + else if (instr(buf,"cannot access")) + errno = EACCES; + else + errno = EPERM; + goto say_zero; + } + else { /* some mkdirs return no failure indication */ + tmps = str_get(st[1]); + anum = (stat(tmps,&statbuf) >= 0); + if (optype == O_RMDIR) + anum = !anum; + if (anum) + errno = 0; + else + errno = EACCES; /* a guess */ + value = (double)anum; + } + goto donumset; + } + else + goto say_zero; +#endif + case O_RMDIR: + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); +#ifdef TAINT + taintproper("Insecure dependency in rmdir"); +#endif +#ifdef HAS_RMDIR + value = (double)(rmdir(tmps) >= 0); + goto donumset; +#else + (void)strcpy(buf,"rmdir "); + goto one_liner; /* see above in HAS_MKDIR */ +#endif + case O_GETPPID: +#ifdef HAS_GETPPID + value = (double)getppid(); + goto donumset; +#else + fatal("Unsupported function getppid"); + break; +#endif + case O_GETPGRP: +#ifdef HAS_GETPGRP + if (maxarg < 1) + anum = 0; + else + anum = (int)str_gnum(st[1]); +#ifdef _POSIX_SOURCE + if (anum != 0) + fatal("POSIX getpgrp can't take an argument"); + value = (double)getpgrp(); +#else + value = (double)getpgrp(anum); +#endif + goto donumset; +#else + fatal("The getpgrp() function is unimplemented on this machine"); + break; +#endif + case O_SETPGRP: +#ifdef HAS_SETPGRP + argtype = (int)str_gnum(st[1]); + anum = (int)str_gnum(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in setpgrp"); +#endif + value = (double)(setpgrp(argtype,anum) >= 0); + goto donumset; +#else + fatal("The setpgrp() function is unimplemented on this machine"); + break; +#endif + case O_GETPRIORITY: +#ifdef HAS_GETPRIORITY + argtype = (int)str_gnum(st[1]); + anum = (int)str_gnum(st[2]); + value = (double)getpriority(argtype,anum); + goto donumset; +#else + fatal("The getpriority() function is unimplemented on this machine"); + break; +#endif + case O_SETPRIORITY: +#ifdef HAS_SETPRIORITY + argtype = (int)str_gnum(st[1]); + anum = (int)str_gnum(st[2]); + optype = (int)str_gnum(st[3]); +#ifdef TAINT + taintproper("Insecure dependency in setpriority"); +#endif + value = (double)(setpriority(argtype,anum,optype) >= 0); + goto donumset; +#else + fatal("The setpriority() function is unimplemented on this machine"); + break; +#endif + case O_CHROOT: +#ifdef HAS_CHROOT + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); +#ifdef TAINT + taintproper("Insecure dependency in chroot"); +#endif + value = (double)(chroot(tmps) >= 0); + goto donumset; +#else + fatal("Unsupported function chroot"); + break; +#endif + case O_FCNTL: + case O_IOCTL: + if (maxarg <= 0) + stab = last_in_stab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + argtype = U_I(str_gnum(st[2])); +#ifdef TAINT + taintproper("Insecure dependency in ioctl"); +#endif + anum = do_ctl(optype,stab,argtype,st[3]); + if (anum == -1) + goto say_undef; + if (anum != 0) { + value = (double)anum; + goto donumset; + } + str_set(str,"0 but true"); + STABSET(str); + break; + case O_FLOCK: +#ifdef HAS_FLOCK + if (maxarg <= 0) + stab = last_in_stab; + else if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (stab && stab_io(stab)) + fp = stab_io(stab)->ifp; + else + fp = Nullfp; + if (fp) { + argtype = (int)str_gnum(st[2]); + value = (double)(flock(fileno(fp),argtype) >= 0); + } + else + value = 0; + goto donumset; +#else + fatal("The flock() function is unimplemented on this machine"); + break; +#endif + case O_UNSHIFT: + ary = stab_array(arg[1].arg_ptr.arg_stab); + if (arglast[2] - arglast[1] != 1) + do_unshift(ary,arglast); + else { + STR *tmpstr = Str_new(52,0); /* must copy the STR */ + str_sset(tmpstr,st[2]); + aunshift(ary,1); + (void)astore(ary,0,tmpstr); + } + value = (double)(ary->ary_fill + 1); + goto donumset; + + case O_TRY: + sp = do_try(arg[1].arg_ptr.arg_cmd, + gimme,arglast); + goto array_return; + + case O_EVALONCE: + sp = do_eval(st[1], O_EVAL, curcmd->c_stash, TRUE, + gimme,arglast); + if (eval_root) { + str_free(arg[1].arg_ptr.arg_str); + arg[1].arg_ptr.arg_cmd = eval_root; + arg[1].arg_type = (A_CMD|A_DONT); + arg[0].arg_type = O_TRY; + } + goto array_return; + + case O_REQUIRE: + case O_DOFILE: + case O_EVAL: + if (maxarg < 1) + tmpstr = stab_val(defstab); + else + tmpstr = + (arg[1].arg_type & A_MASK) != A_NULL ? st[1] : stab_val(defstab); +#ifdef TAINT + tainted |= tmpstr->str_tainted; + taintproper("Insecure dependency in eval"); +#endif + sp = do_eval(tmpstr, optype, curcmd->c_stash, FALSE, + gimme,arglast); + goto array_return; + + case O_FTRREAD: + argtype = 0; + anum = S_IRUSR; + goto check_perm; + case O_FTRWRITE: + argtype = 0; + anum = S_IWUSR; + goto check_perm; + case O_FTREXEC: + argtype = 0; + anum = S_IXUSR; + goto check_perm; + case O_FTEREAD: + argtype = 1; + anum = S_IRUSR; + goto check_perm; + case O_FTEWRITE: + argtype = 1; + anum = S_IWUSR; + goto check_perm; + case O_FTEEXEC: + argtype = 1; + anum = S_IXUSR; + check_perm: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (cando(anum,argtype,&statcache)) + goto say_yes; + goto say_no; + + case O_FTIS: + if (mystat(arg,st[1]) < 0) + goto say_undef; + goto say_yes; + case O_FTEOWNED: + case O_FTROWNED: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (statcache.st_uid == (optype == O_FTEOWNED ? euid : uid) ) + goto say_yes; + goto say_no; + case O_FTZERO: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (!statcache.st_size) + goto say_yes; + goto say_no; + case O_FTSIZE: + if (mystat(arg,st[1]) < 0) + goto say_undef; + value = (double)statcache.st_size; + goto donumset; + + case O_FTMTIME: + if (mystat(arg,st[1]) < 0) + goto say_undef; + value = (double)(basetime - statcache.st_mtime) / 86400.0; + goto donumset; + case O_FTATIME: + if (mystat(arg,st[1]) < 0) + goto say_undef; + value = (double)(basetime - statcache.st_atime) / 86400.0; + goto donumset; + case O_FTCTIME: + if (mystat(arg,st[1]) < 0) + goto say_undef; + value = (double)(basetime - statcache.st_ctime) / 86400.0; + goto donumset; + + case O_FTSOCK: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISSOCK(statcache.st_mode)) + goto say_yes; + goto say_no; + case O_FTCHR: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISCHR(statcache.st_mode)) + goto say_yes; + goto say_no; + case O_FTBLK: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISBLK(statcache.st_mode)) + goto say_yes; + goto say_no; + case O_FTFILE: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISREG(statcache.st_mode)) + goto say_yes; + goto say_no; + case O_FTDIR: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISDIR(statcache.st_mode)) + goto say_yes; + goto say_no; + case O_FTPIPE: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISFIFO(statcache.st_mode)) + goto say_yes; + goto say_no; + case O_FTLINK: + if (mylstat(arg,st[1]) < 0) + goto say_undef; + if (S_ISLNK(statcache.st_mode)) + goto say_yes; + goto say_no; + case O_SYMLINK: +#ifdef HAS_SYMLINK + tmps = str_get(st[1]); + tmps2 = str_get(st[2]); +#ifdef TAINT + taintproper("Insecure dependency in symlink"); +#endif + value = (double)(symlink(tmps,tmps2) >= 0); + goto donumset; +#else + fatal("Unsupported function symlink"); +#endif + case O_READLINK: +#ifdef HAS_SYMLINK + if (maxarg < 1) + tmps = str_get(stab_val(defstab)); + else + tmps = str_get(st[1]); + anum = readlink(tmps,buf,sizeof buf); + if (anum < 0) + goto say_undef; + str_nset(str,buf,anum); + break; +#else + goto say_undef; /* just pretend it's a normal file */ +#endif + case O_FTSUID: +#ifdef S_ISUID + anum = S_ISUID; + goto check_xid; +#else + goto say_no; +#endif + case O_FTSGID: +#ifdef S_ISGID + anum = S_ISGID; + goto check_xid; +#else + goto say_no; +#endif + case O_FTSVTX: +#ifdef S_ISVTX + anum = S_ISVTX; +#else + goto say_no; +#endif + check_xid: + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (statcache.st_mode & anum) + goto say_yes; + goto say_no; + case O_FTTTY: + if (arg[1].arg_type & A_DONT) { + stab = arg[1].arg_ptr.arg_stab; + tmps = ""; + } + else + stab = stabent(tmps = str_get(st[1]),FALSE); + if (stab && stab_io(stab) && stab_io(stab)->ifp) + anum = fileno(stab_io(stab)->ifp); + else if (isDIGIT(*tmps)) + anum = atoi(tmps); + else + goto say_undef; + if (isatty(anum)) + goto say_yes; + goto say_no; + case O_FTTEXT: + case O_FTBINARY: + str = do_fttext(arg,st[1]); + break; +#ifdef HAS_SOCKET + case O_SOCKET: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_socket(stab,arglast); +#else + (void)do_socket(stab,arglast); +#endif + goto donumset; + case O_BIND: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_bind(stab,arglast); +#else + (void)do_bind(stab,arglast); +#endif + goto donumset; + case O_CONNECT: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_connect(stab,arglast); +#else + (void)do_connect(stab,arglast); +#endif + goto donumset; + case O_LISTEN: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_listen(stab,arglast); +#else + (void)do_listen(stab,arglast); +#endif + goto donumset; + case O_ACCEPT: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if ((arg[2].arg_type & A_MASK) == A_WORD) + stab2 = arg[2].arg_ptr.arg_stab; + else + stab2 = stabent(str_get(st[2]),TRUE); + do_accept(str,stab,stab2); + STABSET(str); + break; + case O_GHBYNAME: + if (maxarg < 1) + goto say_undef; + case O_GHBYADDR: + case O_GHOSTENT: + sp = do_ghent(optype, + gimme,arglast); + goto array_return; + case O_GNBYNAME: + if (maxarg < 1) + goto say_undef; + case O_GNBYADDR: + case O_GNETENT: + sp = do_gnent(optype, + gimme,arglast); + goto array_return; + case O_GPBYNAME: + if (maxarg < 1) + goto say_undef; + case O_GPBYNUMBER: + case O_GPROTOENT: + sp = do_gpent(optype, + gimme,arglast); + goto array_return; + case O_GSBYNAME: + if (maxarg < 1) + goto say_undef; + case O_GSBYPORT: + case O_GSERVENT: + sp = do_gsent(optype, + gimme,arglast); + goto array_return; + case O_SHOSTENT: + value = (double) sethostent((int)str_gnum(st[1])); + goto donumset; + case O_SNETENT: + value = (double) setnetent((int)str_gnum(st[1])); + goto donumset; + case O_SPROTOENT: + value = (double) setprotoent((int)str_gnum(st[1])); + goto donumset; + case O_SSERVENT: + value = (double) setservent((int)str_gnum(st[1])); + goto donumset; + case O_EHOSTENT: + value = (double) endhostent(); + goto donumset; + case O_ENETENT: + value = (double) endnetent(); + goto donumset; + case O_EPROTOENT: + value = (double) endprotoent(); + goto donumset; + case O_ESERVENT: + value = (double) endservent(); + goto donumset; + case O_SOCKPAIR: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if ((arg[2].arg_type & A_MASK) == A_WORD) + stab2 = arg[2].arg_ptr.arg_stab; + else + stab2 = stabent(str_get(st[2]),TRUE); +#ifndef lint + value = (double)do_spair(stab,stab2,arglast); +#else + (void)do_spair(stab,stab2,arglast); +#endif + goto donumset; + case O_SHUTDOWN: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); +#ifndef lint + value = (double)do_shutdown(stab,arglast); +#else + (void)do_shutdown(stab,arglast); +#endif + goto donumset; + case O_GSOCKOPT: + case O_SSOCKOPT: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + sp = do_sopt(optype,stab,arglast); + goto array_return; + case O_GETSOCKNAME: + case O_GETPEERNAME: + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab) + goto say_undef; + sp = do_getsockname(optype,stab,arglast); + goto array_return; + +#else /* HAS_SOCKET not defined */ + case O_SOCKET: + case O_BIND: + case O_CONNECT: + case O_LISTEN: + case O_ACCEPT: + case O_SOCKPAIR: + case O_GHBYNAME: + case O_GHBYADDR: + case O_GHOSTENT: + case O_GNBYNAME: + case O_GNBYADDR: + case O_GNETENT: + case O_GPBYNAME: + case O_GPBYNUMBER: + case O_GPROTOENT: + case O_GSBYNAME: + case O_GSBYPORT: + case O_GSERVENT: + case O_SHOSTENT: + case O_SNETENT: + case O_SPROTOENT: + case O_SSERVENT: + case O_EHOSTENT: + case O_ENETENT: + case O_EPROTOENT: + case O_ESERVENT: + case O_SHUTDOWN: + case O_GSOCKOPT: + case O_SSOCKOPT: + case O_GETSOCKNAME: + case O_GETPEERNAME: + badsock: + fatal("Unsupported socket function"); +#endif /* HAS_SOCKET */ + case O_SSELECT: +#ifdef HAS_SELECT + sp = do_select(gimme,arglast); + goto array_return; +#else + fatal("select not implemented"); +#endif + case O_FILENO: + if (maxarg < 1) + goto say_undef; + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp)) + goto say_undef; + value = fileno(fp); + goto donumset; + case O_BINMODE: + if (maxarg < 1) + goto say_undef; + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp)) + goto say_undef; +#ifdef DOSISH +#ifdef atarist + if(fflush(fp)) + str_set(str, No); + else + { + fp->_flag |= _IOBIN; + str_set(str, Yes); + } +#else + str_set(str, (setmode(fileno(fp), O_BINARY) != -1) ? Yes : No); +#endif +#else + str_set(str, Yes); +#endif + STABSET(str); + break; + case O_VEC: + sp = do_vec(str == st[1], arg->arg_ptr.arg_str, arglast); + goto array_return; + case O_GPWNAM: + case O_GPWUID: + case O_GPWENT: +#ifdef HAS_PASSWD + sp = do_gpwent(optype, + gimme,arglast); + goto array_return; + case O_SPWENT: + value = (double) setpwent(); + goto donumset; + case O_EPWENT: + value = (double) endpwent(); + goto donumset; +#else + case O_EPWENT: + case O_SPWENT: + fatal("Unsupported password function"); + break; +#endif + case O_GGRNAM: + case O_GGRGID: + case O_GGRENT: +#ifdef HAS_GROUP + sp = do_ggrent(optype, + gimme,arglast); + goto array_return; + case O_SGRENT: + value = (double) setgrent(); + goto donumset; + case O_EGRENT: + value = (double) endgrent(); + goto donumset; +#else + case O_EGRENT: + case O_SGRENT: + fatal("Unsupported group function"); + break; +#endif + case O_GETLOGIN: +#ifdef HAS_GETLOGIN + if (!(tmps = getlogin())) + goto say_undef; + str_set(str,tmps); +#else + fatal("Unsupported function getlogin"); +#endif + break; + case O_OPEN_DIR: + case O_READDIR: + case O_TELLDIR: + case O_SEEKDIR: + case O_REWINDDIR: + case O_CLOSEDIR: + if (maxarg < 1) + goto say_undef; + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if (!stab) + goto say_undef; + sp = do_dirop(optype,stab,gimme,arglast); + goto array_return; + case O_SYSCALL: + value = (double)do_syscall(arglast); + goto donumset; + case O_PIPE_OP: +#ifdef HAS_PIPE + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else + stab = stabent(str_get(st[1]),TRUE); + if ((arg[2].arg_type & A_MASK) == A_WORD) + stab2 = arg[2].arg_ptr.arg_stab; + else + stab2 = stabent(str_get(st[2]),TRUE); + do_pipe(str,stab,stab2); + STABSET(str); +#else + fatal("Unsupported function pipe"); +#endif + break; + } + + normal_return: + st[1] = str; +#ifdef DEBUGGING + if (debug) { + dlevel--; + if (debug & 8) + deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str)); + } +#endif + return arglast[0] + 1; +} diff --git a/gnu/usr.bin/perl/perl/form.c b/gnu/usr.bin/perl/perl/form.c new file mode 100644 index 0000000..57fc5de --- /dev/null +++ b/gnu/usr.bin/perl/perl/form.c @@ -0,0 +1,419 @@ +/* $RCSfile: form.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:36 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: form.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:36 nate + * PERL! + * + * Revision 4.0.1.4 1993/02/05 19:34:32 lwall + * patch36: formats now ignore literal text for ~~ loop determination + * + * Revision 4.0.1.3 92/06/08 13:21:42 lwall + * patch20: removed implicit int declarations on funcions + * patch20: form feed for formats is now specifiable via $^L + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * + * Revision 4.0.1.2 91/11/05 17:18:43 lwall + * patch11: formats didn't fill their fields as well as they could + * patch11: ^ fields chopped hyphens on line break + * patch11: # fields could write outside allocated memory + * + * Revision 4.0.1.1 91/06/07 11:07:59 lwall + * patch4: new copyright notice + * patch4: default top-of-form format is now FILEHANDLE_TOP + * + * Revision 4.0 91/03/20 01:19:23 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +/* Forms stuff */ + +static int countlines(); + +void +form_parseargs(fcmd) +register FCMD *fcmd; +{ + register int i; + register ARG *arg; + register int items; + STR *str; + ARG *parselist(); + line_t oldline = curcmd->c_line; + int oldsave = savestack->ary_fill; + + str = fcmd->f_unparsed; + curcmd->c_line = fcmd->f_line; + fcmd->f_unparsed = Nullstr; + (void)savehptr(&curstash); + curstash = str->str_u.str_hash; + arg = parselist(str); + restorelist(oldsave); + + items = arg->arg_len - 1; /* ignore $$ on end */ + for (i = 1; i <= items; i++) { + if (!fcmd || fcmd->f_type == F_NULL) + fatal("Too many field values"); + dehoist(arg,i); + fcmd->f_expr = make_op(O_ITEM,1, + arg[i].arg_ptr.arg_arg,Nullarg,Nullarg); + if (fcmd->f_flags & FC_CHOP) { + if ((fcmd->f_expr[1].arg_type & A_MASK) == A_STAB) + fcmd->f_expr[1].arg_type = A_LVAL; + else if ((fcmd->f_expr[1].arg_type & A_MASK) == A_EXPR) + fcmd->f_expr[1].arg_type = A_LEXPR; + else + fatal("^ field requires scalar lvalue"); + } + fcmd = fcmd->f_next; + } + if (fcmd && fcmd->f_type) + fatal("Not enough field values"); + curcmd->c_line = oldline; + Safefree(arg); + str_free(str); +} + +int newsize; + +#define CHKLEN(allow) \ +newsize = (d - orec->o_str) + (allow); \ +if (newsize >= curlen) { \ + curlen = d - orec->o_str; \ + GROWSTR(&orec->o_str,&orec->o_len,orec->o_len + (allow)); \ + d = orec->o_str + curlen; /* in case it moves */ \ + curlen = orec->o_len - 2; \ +} + +void +format(orec,fcmd,sp) +register struct outrec *orec; +register FCMD *fcmd; +int sp; +{ + register char *d = orec->o_str; + register char *s; + register int curlen = orec->o_len - 2; + register int size; + FCMD *nextfcmd; + FCMD *linebeg = fcmd; + char tmpchar; + char *t; + CMD mycmd; + STR *str; + char *chophere; + int blank = TRUE; + + mycmd.c_type = C_NULL; + orec->o_lines = 0; + for (; fcmd; fcmd = nextfcmd) { + nextfcmd = fcmd->f_next; + CHKLEN(fcmd->f_presize); + /*SUPPRESS 560*/ + if (s = fcmd->f_pre) { + while (*s) { + if (*s == '\n') { + t = orec->o_str; + if (blank && (fcmd->f_flags & FC_REPEAT)) { + while (d > t && (d[-1] != '\n')) + d--; + } + else { + while (d > t && (d[-1] == ' ' || d[-1] == '\t')) + d--; + } + if (fcmd->f_flags & FC_NOBLANK) { + if (blank || d == orec->o_str || d[-1] == '\n') { + orec->o_lines--; /* don't print blank line */ + linebeg = fcmd->f_next; + break; + } + else if (fcmd->f_flags & FC_REPEAT) + nextfcmd = linebeg; + else + linebeg = fcmd->f_next; + } + else + linebeg = fcmd->f_next; + blank = TRUE; + } + *d++ = *s++; + } + } + if (fcmd->f_unparsed) + form_parseargs(fcmd); + switch (fcmd->f_type) { + case F_NULL: + orec->o_lines++; + break; + case F_LEFT: + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + s = str_get(str); + size = fcmd->f_size; + CHKLEN(size); + chophere = Nullch; + while (size && *s && *s != '\n') { + if (*s == '\t') + *s = ' '; + else if (*s != ' ') + blank = FALSE; + size--; + if (*s && index(chopset,(*d++ = *s++))) + chophere = s; + if (*s == '\n' && (fcmd->f_flags & FC_CHOP)) + *s = ' '; + } + if (size || !*s) + chophere = s; + else if (chophere && chophere < s && *s && index(chopset,*s)) + chophere = s; + if (fcmd->f_flags & FC_CHOP) { + if (!chophere) + chophere = s; + size += (s - chophere); + d -= (s - chophere); + if (fcmd->f_flags & FC_MORE && + *chophere && strNE(chophere,"\n")) { + while (size < 3) { + d--; + size++; + } + while (d[-1] == ' ' && size < fcmd->f_size) { + d--; + size++; + } + *d++ = '.'; + *d++ = '.'; + *d++ = '.'; + size -= 3; + } + while (*chophere && index(chopset,*chophere) + && isSPACE(*chophere)) + chophere++; + str_chop(str,chophere); + } + if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n') + size = 0; /* no spaces before newline */ + while (size) { + size--; + *d++ = ' '; + } + break; + case F_RIGHT: + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + t = s = str_get(str); + size = fcmd->f_size; + CHKLEN(size); + chophere = Nullch; + while (size && *s && *s != '\n') { + if (*s == '\t') + *s = ' '; + else if (*s != ' ') + blank = FALSE; + size--; + if (*s && index(chopset,*s++)) + chophere = s; + if (*s == '\n' && (fcmd->f_flags & FC_CHOP)) + *s = ' '; + } + if (size || !*s) + chophere = s; + else if (chophere && chophere < s && *s && index(chopset,*s)) + chophere = s; + if (fcmd->f_flags & FC_CHOP) { + if (!chophere) + chophere = s; + size += (s - chophere); + s = chophere; + while (*chophere && index(chopset,*chophere) + && isSPACE(*chophere)) + chophere++; + } + tmpchar = *s; + *s = '\0'; + while (size) { + size--; + *d++ = ' '; + } + size = s - t; + Copy(t,d,size,char); + d += size; + *s = tmpchar; + if (fcmd->f_flags & FC_CHOP) + str_chop(str,chophere); + break; + case F_CENTER: { + int halfsize; + + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + t = s = str_get(str); + size = fcmd->f_size; + CHKLEN(size); + chophere = Nullch; + while (size && *s && *s != '\n') { + if (*s == '\t') + *s = ' '; + else if (*s != ' ') + blank = FALSE; + size--; + if (*s && index(chopset,*s++)) + chophere = s; + if (*s == '\n' && (fcmd->f_flags & FC_CHOP)) + *s = ' '; + } + if (size || !*s) + chophere = s; + else if (chophere && chophere < s && *s && index(chopset,*s)) + chophere = s; + if (fcmd->f_flags & FC_CHOP) { + if (!chophere) + chophere = s; + size += (s - chophere); + s = chophere; + while (*chophere && index(chopset,*chophere) + && isSPACE(*chophere)) + chophere++; + } + tmpchar = *s; + *s = '\0'; + halfsize = size / 2; + while (size > halfsize) { + size--; + *d++ = ' '; + } + size = s - t; + Copy(t,d,size,char); + d += size; + *s = tmpchar; + if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n') + size = 0; /* no spaces before newline */ + else + size = halfsize; + while (size) { + size--; + *d++ = ' '; + } + if (fcmd->f_flags & FC_CHOP) + str_chop(str,chophere); + break; + } + case F_LINES: + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + s = str_get(str); + size = str_len(str); + CHKLEN(size+1); + orec->o_lines += countlines(s,size) - 1; + Copy(s,d,size,char); + d += size; + if (size && s[size-1] != '\n') { + *d++ = '\n'; + orec->o_lines++; + } + linebeg = fcmd->f_next; + break; + case F_DECIMAL: { + double value; + + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + size = fcmd->f_size; + CHKLEN(size+1); + /* If the field is marked with ^ and the value is undefined, + blank it out. */ + if ((fcmd->f_flags & FC_CHOP) && !str->str_pok && !str->str_nok) { + while (size) { + size--; + *d++ = ' '; + } + break; + } + blank = FALSE; + value = str_gnum(str); + if (fcmd->f_flags & FC_DP) { + sprintf(d, "%#*.*f", size, fcmd->f_decimals, value); + } else { + sprintf(d, "%*.0f", size, value); + } + d += size; + break; + } + } + } + CHKLEN(1); + *d++ = '\0'; +} + +static int +countlines(s,size) +register char *s; +register int size; +{ + register int count = 0; + + while (size--) { + if (*s++ == '\n') + count++; + } + return count; +} + +void +do_write(orec,stab,sp) +struct outrec *orec; +STAB *stab; +int sp; +{ + register STIO *stio = stab_io(stab); + FILE *ofp = stio->ofp; + +#ifdef DEBUGGING + if (debug & 256) + fprintf(stderr,"left=%ld, todo=%ld\n", + (long)stio->lines_left, (long)orec->o_lines); +#endif + if (stio->lines_left < orec->o_lines) { + if (!stio->top_stab) { + STAB *topstab; + char tmpbuf[256]; + + if (!stio->top_name) { + if (!stio->fmt_name) + stio->fmt_name = savestr(stab_name(stab)); + sprintf(tmpbuf, "%s_TOP", stio->fmt_name); + topstab = stabent(tmpbuf,FALSE); + if (topstab && stab_form(topstab)) + stio->top_name = savestr(tmpbuf); + else + stio->top_name = savestr("top"); + } + topstab = stabent(stio->top_name,FALSE); + if (!topstab || !stab_form(topstab)) { + stio->lines_left = 100000000; + goto forget_top; + } + stio->top_stab = topstab; + } + if (stio->lines_left >= 0 && stio->page > 0) + fwrite(formfeed->str_ptr, formfeed->str_cur, 1, ofp); + stio->lines_left = stio->page_len; + stio->page++; + format(&toprec,stab_form(stio->top_stab),sp); + fputs(toprec.o_str,ofp); + stio->lines_left -= toprec.o_lines; + } + forget_top: + fputs(orec->o_str,ofp); + stio->lines_left -= orec->o_lines; +} diff --git a/gnu/usr.bin/perl/perl/form.h b/gnu/usr.bin/perl/perl/form.h new file mode 100644 index 0000000..1e3e6f4 --- /dev/null +++ b/gnu/usr.bin/perl/perl/form.h @@ -0,0 +1,48 @@ +/* $RCSfile: form.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:36 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: form.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:36 nate + * PERL! + * + * Revision 4.0.1.1 91/06/07 11:08:20 lwall + * patch4: new copyright notice + * + * Revision 4.0 91/03/20 01:19:37 lwall + * 4.0 baseline. + * + */ + +#define F_NULL 0 +#define F_LEFT 1 +#define F_RIGHT 2 +#define F_CENTER 3 +#define F_LINES 4 +#define F_DECIMAL 5 + +struct formcmd { + struct formcmd *f_next; + ARG *f_expr; + STR *f_unparsed; + line_t f_line; + char *f_pre; + short f_presize; + short f_size; + short f_decimals; + char f_type; + char f_flags; +}; + +#define FC_CHOP 1 +#define FC_NOBLANK 2 +#define FC_MORE 4 +#define FC_REPEAT 8 +#define FC_DP 16 + +#define Nullfcmd Null(FCMD*) + +EXT char *chopset INIT(" \n-"); diff --git a/gnu/usr.bin/perl/perl/handy.h b/gnu/usr.bin/perl/perl/handy.h new file mode 100644 index 0000000..46231ae --- /dev/null +++ b/gnu/usr.bin/perl/perl/handy.h @@ -0,0 +1,150 @@ +/* $RCSfile: handy.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:36 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: handy.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:36 nate + * PERL! + * + * Revision 4.0.1.4 92/06/08 13:23:17 lwall + * patch20: isascii() may now be supplied by a library routine + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * + * Revision 4.0.1.3 91/11/05 22:54:26 lwall + * patch11: erratum + * + * Revision 4.0.1.2 91/11/05 17:23:38 lwall + * patch11: prepared for ctype implementations that don't define isascii() + * + * Revision 4.0.1.1 91/06/07 11:09:56 lwall + * patch4: new copyright notice + * + * Revision 4.0 91/03/20 01:22:15 lwall + * 4.0 baseline. + * + */ + +#ifdef NULL +#undef NULL +#endif +#ifndef I286 +# define NULL 0 +#else +# define NULL 0L +#endif +#define Null(type) ((type)NULL) +#define Nullch Null(char*) +#define Nullfp Null(FILE*) + +#ifdef UTS +#define bool int +#else +#define bool char +#endif + +#ifdef TRUE +#undef TRUE +#endif +#ifdef FALSE +#undef FALSE +#endif +#define TRUE (1) +#define FALSE (0) + +#define Ctl(ch) (ch & 037) + +#define strNE(s1,s2) (strcmp(s1,s2)) +#define strEQ(s1,s2) (!strcmp(s1,s2)) +#define strLT(s1,s2) (strcmp(s1,s2) < 0) +#define strLE(s1,s2) (strcmp(s1,s2) <= 0) +#define strGT(s1,s2) (strcmp(s1,s2) > 0) +#define strGE(s1,s2) (strcmp(s1,s2) >= 0) +#define strnNE(s1,s2,l) (strncmp(s1,s2,l)) +#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l)) + +#if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII)) +#define isALNUM(c) (isalpha(c) || isdigit(c) || c == '_') +#define isALPHA(c) isalpha(c) +#define isSPACE(c) isspace(c) +#define isDIGIT(c) isdigit(c) +#define isUPPER(c) isupper(c) +#define isLOWER(c) islower(c) +#else +#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_')) +#define isALPHA(c) (isascii(c) && isalpha(c)) +#define isSPACE(c) (isascii(c) && isspace(c)) +#define isDIGIT(c) (isascii(c) && isdigit(c)) +#define isUPPER(c) (isascii(c) && isupper(c)) +#define isLOWER(c) (isascii(c) && islower(c)) +#endif + +/* Line numbers are unsigned, 16 bits. */ +typedef unsigned short line_t; +#ifdef lint +#define NOLINE ((line_t)0) +#else +#define NOLINE ((line_t) 65535) +#endif + +#ifndef lint +#ifndef LEAKTEST +#ifndef safemalloc +char *safemalloc(); +char *saferealloc(); +void safefree(); +#endif +#ifndef MSDOS +#define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) +#define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t)))) +#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \ + memzero((char*)(v), (n) * sizeof(t)) +#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) +#else +#define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))) +#define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t)))) +#define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \ + memzero((char*)(v), (n) * sizeof(t)) +#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t)))) +#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t)))) +#endif /* MSDOS */ +#define Safefree(d) safefree((char*)d) +#define Str_new(x,len) str_new(len) +#else /* LEAKTEST */ +char *safexmalloc(); +char *safexrealloc(); +void safexfree(); +#define New(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) +#define Newc(x,v,n,t,c) (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))) +#define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \ + memzero((char*)(v), (n) * sizeof(t)) +#define Renew(v,n,t) (v = (t*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t)))) +#define Safefree(d) safexfree((char*)d) +#define Str_new(x,len) str_new(x,len) +#define MAXXCOUNT 1200 +long xcount[MAXXCOUNT]; +long lastxcount[MAXXCOUNT]; +#endif /* LEAKTEST */ +#define Move(s,d,n,t) (void)memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#define Zero(d,n,t) (void)memzero((char*)(d), (n) * sizeof(t)) +#else /* lint */ +#define New(x,v,n,s) (v = Null(s *)) +#define Newc(x,v,n,s,c) (v = Null(s *)) +#define Newz(x,v,n,s) (v = Null(s *)) +#define Renew(v,n,s) (v = Null(s *)) +#define Move(s,d,n,t) +#define Copy(s,d,n,t) +#define Zero(d,n,t) +#define Safefree(d) d = d +#endif /* lint */ + +#ifdef STRUCTCOPY +#define StructCopy(s,d,t) *((t*)(d)) = *((t*)(s)) +#else +#define StructCopy(s,d,t) Copy(s,d,1,t) +#endif diff --git a/gnu/usr.bin/perl/perl/hash.c b/gnu/usr.bin/perl/perl/hash.c new file mode 100644 index 0000000..15cc116 --- /dev/null +++ b/gnu/usr.bin/perl/perl/hash.c @@ -0,0 +1,715 @@ +/* $RCSfile: hash.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:37 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: hash.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:37 nate + * PERL! + * + * Revision 4.0.1.3 92/06/08 13:26:29 lwall + * patch20: removed implicit int declarations on functions + * patch20: delete could cause %array to give too low a count of buckets filled + * patch20: hash tables now split only if the memory is available to do so + * + * Revision 4.0.1.2 91/11/05 17:24:13 lwall + * patch11: saberized perl + * + * Revision 4.0.1.1 91/06/07 11:10:11 lwall + * patch4: new copyright notice + * + * Revision 4.0 91/03/20 01:22:26 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +static void hsplit(); + +static char coeff[] = { + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, + 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1}; + +static void hfreeentries(); + +STR * +hfetch(tb,key,klen,lval) +register HASH *tb; +char *key; +unsigned int klen; +int lval; +{ + register char *s; + register int i; + register int hash; + register HENT *entry; + register int maxi; + STR *str; +#ifdef SOME_DBM + datum dkey,dcontent; +#endif + + if (!tb) + return &str_undef; + if (!tb->tbl_array) { + if (lval) + Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*); + else + return &str_undef; + } + + /* The hash function we use on symbols has to be equal to the first + * character when taken modulo 128, so that str_reset() can be implemented + * efficiently. We throw in the second character and the last character + * (times 128) so that long chains of identifiers starting with the + * same letter don't have to be strEQ'ed within hfetch(), since it + * compares hash values before trying strEQ(). + */ + if (!tb->tbl_coeffsize) + hash = *key + 128 * key[1] + 128 * key[klen-1]; /* assuming klen > 0 */ + else { /* use normal coefficients */ + if (klen < tb->tbl_coeffsize) + maxi = klen; + else + maxi = tb->tbl_coeffsize; + for (s=key, i=0, hash = 0; + i < maxi; /*SUPPRESS 8*/ + s++, i++, hash *= 5) { + hash += *s * coeff[i]; + } + } + + entry = tb->tbl_array[hash & tb->tbl_max]; + for (; entry; entry = entry->hent_next) { + if (entry->hent_hash != hash) /* strings can't be equal */ + continue; + if (entry->hent_klen != klen) + continue; + if (bcmp(entry->hent_key,key,klen)) /* is this it? */ + continue; + return entry->hent_val; + } +#ifdef SOME_DBM + if (tb->tbl_dbm) { + dkey.dptr = key; + dkey.dsize = klen; +#ifdef HAS_GDBM + dcontent = gdbm_fetch(tb->tbl_dbm,dkey); +#else + dcontent = dbm_fetch(tb->tbl_dbm,dkey); +#endif + if (dcontent.dptr) { /* found one */ + str = Str_new(60,dcontent.dsize); + str_nset(str,dcontent.dptr,dcontent.dsize); + hstore(tb,key,klen,str,hash); /* cache it */ + return str; + } + } +#endif + if (lval) { /* gonna assign to this, so it better be there */ + str = Str_new(61,0); + hstore(tb,key,klen,str,hash); + return str; + } + return &str_undef; +} + +bool +hstore(tb,key,klen,val,hash) +register HASH *tb; +char *key; +unsigned int klen; +STR *val; +register int hash; +{ + register char *s; + register int i; + register HENT *entry; + register HENT **oentry; + register int maxi; + + if (!tb) + return FALSE; + + if (hash) + /*SUPPRESS 530*/ + ; + else if (!tb->tbl_coeffsize) + hash = *key + 128 * key[1] + 128 * key[klen-1]; + else { /* use normal coefficients */ + if (klen < tb->tbl_coeffsize) + maxi = klen; + else + maxi = tb->tbl_coeffsize; + for (s=key, i=0, hash = 0; + i < maxi; /*SUPPRESS 8*/ + s++, i++, hash *= 5) { + hash += *s * coeff[i]; + } + } + + if (!tb->tbl_array) + Newz(505,tb->tbl_array, tb->tbl_max + 1, HENT*); + + oentry = &(tb->tbl_array[hash & tb->tbl_max]); + i = 1; + + for (entry = *oentry; entry; i=0, entry = entry->hent_next) { + if (entry->hent_hash != hash) /* strings can't be equal */ + continue; + if (entry->hent_klen != klen) + continue; + if (bcmp(entry->hent_key,key,klen)) /* is this it? */ + continue; + Safefree(entry->hent_val); + entry->hent_val = val; + return TRUE; + } + New(501,entry, 1, HENT); + + entry->hent_klen = klen; + entry->hent_key = nsavestr(key,klen); + entry->hent_val = val; + entry->hent_hash = hash; + entry->hent_next = *oentry; + *oentry = entry; + + /* hdbmstore not necessary here because it's called from stabset() */ + + if (i) { /* initial entry? */ + tb->tbl_fill++; +#ifdef SOME_DBM + if (tb->tbl_dbm && tb->tbl_max >= DBM_CACHE_MAX) + return FALSE; +#endif + if (tb->tbl_fill > tb->tbl_dosplit) + hsplit(tb); + } +#ifdef SOME_DBM + else if (tb->tbl_dbm) { /* is this just a cache for dbm file? */ + void hentdelayfree(); + + entry = tb->tbl_array[hash & tb->tbl_max]; + oentry = &entry->hent_next; + entry = *oentry; + while (entry) { /* trim chain down to 1 entry */ + *oentry = entry->hent_next; + hentdelayfree(entry); /* no doubt they'll want this next. */ + entry = *oentry; + } + } +#endif + + return FALSE; +} + +STR * +hdelete(tb,key,klen) +register HASH *tb; +char *key; +unsigned int klen; +{ + register char *s; + register int i; + register int hash; + register HENT *entry; + register HENT **oentry; + STR *str; + int maxi; +#ifdef SOME_DBM + datum dkey; +#endif + + if (!tb || !tb->tbl_array) + return Nullstr; + if (!tb->tbl_coeffsize) + hash = *key + 128 * key[1] + 128 * key[klen-1]; + else { /* use normal coefficients */ + if (klen < tb->tbl_coeffsize) + maxi = klen; + else + maxi = tb->tbl_coeffsize; + for (s=key, i=0, hash = 0; + i < maxi; /*SUPPRESS 8*/ + s++, i++, hash *= 5) { + hash += *s * coeff[i]; + } + } + + oentry = &(tb->tbl_array[hash & tb->tbl_max]); + entry = *oentry; + i = 1; + for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) { + if (entry->hent_hash != hash) /* strings can't be equal */ + continue; + if (entry->hent_klen != klen) + continue; + if (bcmp(entry->hent_key,key,klen)) /* is this it? */ + continue; + *oentry = entry->hent_next; + if (i && !*oentry) + tb->tbl_fill--; + str = str_mortal(entry->hent_val); + hentfree(entry); +#ifdef SOME_DBM + do_dbm_delete: + if (tb->tbl_dbm) { + dkey.dptr = key; + dkey.dsize = klen; +#ifdef HAS_GDBM + gdbm_delete(tb->tbl_dbm,dkey); +#else + dbm_delete(tb->tbl_dbm,dkey); +#endif + } +#endif + return str; + } +#ifdef SOME_DBM + str = Nullstr; + goto do_dbm_delete; +#else + return Nullstr; +#endif +} + +static void +hsplit(tb) +HASH *tb; +{ + int oldsize = tb->tbl_max + 1; + register int newsize = oldsize * 2; + register int i; + register HENT **a; + register HENT **b; + register HENT *entry; + register HENT **oentry; + + a = tb->tbl_array; + nomemok = TRUE; + Renew(a, newsize, HENT*); + nomemok = FALSE; + if (!a) { + tb->tbl_dosplit = tb->tbl_max + 1; /* never split again */ + return; + } + Zero(&a[oldsize], oldsize, HENT*); /* zero 2nd half*/ + tb->tbl_max = --newsize; + tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100; + tb->tbl_array = a; + + for (i=0; ihent_hash & newsize) != i) { + *oentry = entry->hent_next; + entry->hent_next = *b; + if (!*b) + tb->tbl_fill++; + *b = entry; + continue; + } + else + oentry = &entry->hent_next; + } + if (!*a) /* everything moved */ + tb->tbl_fill--; + } +} + +HASH * +hnew(lookat) +unsigned int lookat; +{ + register HASH *tb; + + Newz(502,tb, 1, HASH); + if (lookat) { + tb->tbl_coeffsize = lookat; + tb->tbl_max = 7; /* it's a normal associative array */ + tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100; + } + else { + tb->tbl_max = 127; /* it's a symbol table */ + tb->tbl_dosplit = 128; /* so never split */ + } + tb->tbl_fill = 0; +#ifdef SOME_DBM + tb->tbl_dbm = 0; +#endif + (void)hiterinit(tb); /* so each() will start off right */ + return tb; +} + +void +hentfree(hent) +register HENT *hent; +{ + if (!hent) + return; + str_free(hent->hent_val); + Safefree(hent->hent_key); + Safefree(hent); +} + +void +hentdelayfree(hent) +register HENT *hent; +{ + if (!hent) + return; + str_2mortal(hent->hent_val); /* free between statements */ + Safefree(hent->hent_key); + Safefree(hent); +} + +void +hclear(tb,dodbm) +register HASH *tb; +int dodbm; +{ + if (!tb) + return; + hfreeentries(tb,dodbm); + tb->tbl_fill = 0; +#ifndef lint + if (tb->tbl_array) + (void)memzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*)); +#endif +} + +static void +hfreeentries(tb,dodbm) +register HASH *tb; +int dodbm; +{ + register HENT *hent; + register HENT *ohent = Null(HENT*); +#ifdef SOME_DBM + datum dkey; + datum nextdkey; +#ifdef HAS_GDBM + GDBM_FILE old_dbm; +#else +#ifdef HAS_NDBM + DBM *old_dbm; +#else + int old_dbm; +#endif +#endif +#endif + + if (!tb || !tb->tbl_array) + return; +#ifdef SOME_DBM + if ((old_dbm = tb->tbl_dbm) && dodbm) { +#ifdef HAS_GDBM + while (dkey = gdbm_firstkey(tb->tbl_dbm), dkey.dptr) { +#else + while (dkey = dbm_firstkey(tb->tbl_dbm), dkey.dptr) { +#endif + do { +#ifdef HAS_GDBM + nextdkey = gdbm_nextkey(tb->tbl_dbm, dkey); +#else +#ifdef HAS_NDBM +#ifdef _CX_UX + nextdkey = dbm_nextkey(tb->tbl_dbm, dkey); +#else + nextdkey = dbm_nextkey(tb->tbl_dbm); +#endif +#else + nextdkey = nextkey(dkey); +#endif +#endif +#ifdef HAS_GDBM + gdbm_delete(tb->tbl_dbm,dkey); +#else + dbm_delete(tb->tbl_dbm,dkey); +#endif + dkey = nextdkey; + } while (dkey.dptr); /* one way or another, this works */ + } + } + tb->tbl_dbm = 0; /* now clear just cache */ +#endif + (void)hiterinit(tb); + /*SUPPRESS 560*/ + while (hent = hiternext(tb)) { /* concise but not very efficient */ + hentfree(ohent); + ohent = hent; + } + hentfree(ohent); +#ifdef SOME_DBM + tb->tbl_dbm = old_dbm; +#endif +} + +void +hfree(tb,dodbm) +register HASH *tb; +int dodbm; +{ + if (!tb) + return; + hfreeentries(tb,dodbm); + Safefree(tb->tbl_array); + Safefree(tb); +} + +int +hiterinit(tb) +register HASH *tb; +{ + tb->tbl_riter = -1; + tb->tbl_eiter = Null(HENT*); + return tb->tbl_fill; +} + +HENT * +hiternext(tb) +register HASH *tb; +{ + register HENT *entry; +#ifdef SOME_DBM + datum key; +#endif + + entry = tb->tbl_eiter; +#ifdef SOME_DBM + if (tb->tbl_dbm) { + if (entry) { +#ifdef HAS_GDBM + key.dptr = entry->hent_key; + key.dsize = entry->hent_klen; + key = gdbm_nextkey(tb->tbl_dbm, key); +#else +#ifdef HAS_NDBM +#ifdef _CX_UX + key.dptr = entry->hent_key; + key.dsize = entry->hent_klen; + key = dbm_nextkey(tb->tbl_dbm, key); +#else + key = dbm_nextkey(tb->tbl_dbm); +#endif /* _CX_UX */ +#else + key.dptr = entry->hent_key; + key.dsize = entry->hent_klen; + key = nextkey(key); +#endif +#endif + } + else { + Newz(504,entry, 1, HENT); + tb->tbl_eiter = entry; +#ifdef HAS_GDBM + key = gdbm_firstkey(tb->tbl_dbm); +#else + key = dbm_firstkey(tb->tbl_dbm); +#endif + } + entry->hent_key = key.dptr; + entry->hent_klen = key.dsize; + if (!key.dptr) { + if (entry->hent_val) + str_free(entry->hent_val); + Safefree(entry); + tb->tbl_eiter = Null(HENT*); + return Null(HENT*); + } + return entry; + } +#endif + if (!tb->tbl_array) + Newz(506,tb->tbl_array, tb->tbl_max + 1, HENT*); + do { + if (entry) + entry = entry->hent_next; + if (!entry) { + tb->tbl_riter++; + if (tb->tbl_riter > tb->tbl_max) { + tb->tbl_riter = -1; + break; + } + entry = tb->tbl_array[tb->tbl_riter]; + } + } while (!entry); + + tb->tbl_eiter = entry; + return entry; +} + +char * +hiterkey(entry,retlen) +register HENT *entry; +int *retlen; +{ + *retlen = entry->hent_klen; + return entry->hent_key; +} + +STR * +hiterval(tb,entry) +register HASH *tb; +register HENT *entry; +{ +#ifdef SOME_DBM + datum key, content; + + if (tb->tbl_dbm) { + key.dptr = entry->hent_key; + key.dsize = entry->hent_klen; +#ifdef HAS_GDBM + content = gdbm_fetch(tb->tbl_dbm,key); +#else + content = dbm_fetch(tb->tbl_dbm,key); +#endif + if (!entry->hent_val) + entry->hent_val = Str_new(62,0); + str_nset(entry->hent_val,content.dptr,content.dsize); + } +#endif + return entry->hent_val; +} + +#ifdef SOME_DBM + +#ifndef O_CREAT +# ifdef I_FCNTL +# include +# endif +# ifdef I_SYS_FILE +# include +# endif +#endif + +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif +#ifndef O_RDWR +#define O_RDWR 2 +#endif +#ifndef O_CREAT +#define O_CREAT 01000 +#endif + +#ifdef HAS_ODBM +static int dbmrefcnt = 0; +#endif + +bool +hdbmopen(tb,fname,mode) +register HASH *tb; +char *fname; +int mode; +{ + if (!tb) + return FALSE; +#ifdef HAS_ODBM + if (tb->tbl_dbm) /* never really closed it */ + return TRUE; +#endif + if (tb->tbl_dbm) { + hdbmclose(tb); + tb->tbl_dbm = 0; + } + hclear(tb, FALSE); /* clear cache */ +#ifdef HAS_GDBM + if (mode >= 0) + tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRCREAT,mode, (void *) NULL); + if (!tb->tbl_dbm) + tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRITER, mode, (void *) NULL); + if (!tb->tbl_dbm) + tb->tbl_dbm = gdbm_open(fname, 0, GDBM_READER, mode, (void *) NULL); +#else +#ifdef HAS_NDBM + if (mode >= 0) + tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode); + if (!tb->tbl_dbm) + tb->tbl_dbm = dbm_open(fname, O_RDWR, mode); + if (!tb->tbl_dbm) + tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode); +#else + if (dbmrefcnt++) + fatal("Old dbm can only open one database"); + sprintf(buf,"%s.dir",fname); + if (stat(buf, &statbuf) < 0) { + if (mode < 0 || close(creat(buf,mode)) < 0) + return FALSE; + sprintf(buf,"%s.pag",fname); + if (close(creat(buf,mode)) < 0) + return FALSE; + } + tb->tbl_dbm = dbminit(fname) >= 0; +#endif +#endif + if (!tb->tbl_array && tb->tbl_dbm != 0) + Newz(507,tb->tbl_array, tb->tbl_max + 1, HENT*); + return tb->tbl_dbm != 0; +} + +void +hdbmclose(tb) +register HASH *tb; +{ + if (tb && tb->tbl_dbm) { +#ifdef HAS_GDBM + gdbm_close(tb->tbl_dbm); + tb->tbl_dbm = 0; +#else +#ifdef HAS_NDBM + dbm_close(tb->tbl_dbm); + tb->tbl_dbm = 0; +#else + /* dbmrefcnt--; */ /* doesn't work, rats */ +#endif +#endif + } + else if (dowarn) + warn("Close on unopened dbm file"); +} + +bool +hdbmstore(tb,key,klen,str) +register HASH *tb; +char *key; +unsigned int klen; +register STR *str; +{ + datum dkey, dcontent; + int error; + + if (!tb || !tb->tbl_dbm) + return FALSE; + dkey.dptr = key; + dkey.dsize = klen; + dcontent.dptr = str_get(str); + dcontent.dsize = str->str_cur; +#ifdef HAS_GDBM + error = gdbm_store(tb->tbl_dbm, dkey, dcontent, GDBM_REPLACE); +#else + error = dbm_store(tb->tbl_dbm, dkey, dcontent, DBM_REPLACE); +#endif + if (error) { + if (errno == EPERM) + fatal("No write permission to dbm file"); + warn("dbm store returned %d, errno %d, key \"%s\"",error,errno,key); +#ifdef HAS_NDBM + dbm_clearerr(tb->tbl_dbm); +#endif + } + return !error; +} +#endif /* SOME_DBM */ diff --git a/gnu/usr.bin/perl/perl/hash.h b/gnu/usr.bin/perl/perl/hash.h new file mode 100644 index 0000000..858721f --- /dev/null +++ b/gnu/usr.bin/perl/perl/hash.h @@ -0,0 +1,75 @@ +/* $RCSfile: hash.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:37 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: hash.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:37 nate + * PERL! + * + * Revision 4.0.1.2 91/11/05 17:24:31 lwall + * patch11: random cleanup + * + * Revision 4.0.1.1 91/06/07 11:10:33 lwall + * patch4: new copyright notice + * + * Revision 4.0 91/03/20 01:22:38 lwall + * 4.0 baseline. + * + */ + +#define FILLPCT 80 /* don't make greater than 99 */ +#define DBM_CACHE_MAX 63 /* cache 64 entries for dbm file */ + /* (resident array acts as a write-thru cache)*/ + +#define COEFFSIZE (16 * 8) /* size of coeff array */ + +typedef struct hentry HENT; + +struct hentry { + HENT *hent_next; + char *hent_key; + STR *hent_val; + int hent_hash; + int hent_klen; +}; + +struct htbl { + HENT **tbl_array; + int tbl_max; /* subscript of last element of tbl_array */ + int tbl_dosplit; /* how full to get before splitting */ + int tbl_fill; /* how full tbl_array currently is */ + int tbl_riter; /* current root of iterator */ + HENT *tbl_eiter; /* current entry of iterator */ + SPAT *tbl_spatroot; /* list of spats for this package */ + char *tbl_name; /* name, if a symbol table */ +#ifdef SOME_DBM +#ifdef HAS_GDBM + GDBM_FILE tbl_dbm; +#else +#ifdef HAS_NDBM + DBM *tbl_dbm; +#else + int tbl_dbm; +#endif +#endif +#endif + unsigned char tbl_coeffsize; /* is 0 for symbol tables */ +}; + +STR *hfetch(); +bool hstore(); +STR *hdelete(); +HASH *hnew(); +void hclear(); +void hentfree(); +void hfree(); +int hiterinit(); +HENT *hiternext(); +char *hiterkey(); +STR *hiterval(); +bool hdbmopen(); +void hdbmclose(); +bool hdbmstore(); diff --git a/gnu/usr.bin/perl/perl/malloc.c b/gnu/usr.bin/perl/perl/malloc.c new file mode 100644 index 0000000..8bfee40 --- /dev/null +++ b/gnu/usr.bin/perl/perl/malloc.c @@ -0,0 +1,510 @@ +/* $RCSfile: malloc.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:37 $ + * + * $Log: malloc.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:37 nate + * PERL! + * + * Revision 4.0.1.4 92/06/08 14:28:38 lwall + * patch20: removed implicit int declarations on functions + * patch20: hash tables now split only if the memory is available to do so + * patch20: realloc(0, size) now does malloc in case library routines call it + * + * Revision 4.0.1.3 91/11/05 17:57:40 lwall + * patch11: safe malloc code now integrated into Perl's malloc when possible + * + * Revision 4.0.1.2 91/06/07 11:20:45 lwall + * patch4: many, many itty-bitty portability fixes + * + * Revision 4.0.1.1 91/04/11 17:48:31 lwall + * patch1: Configure now figures out malloc ptr type + * + * Revision 4.0 91/03/20 01:28:52 lwall + * 4.0 baseline. + * + */ + +#ifndef lint +/*SUPPRESS 592*/ +static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; + +#ifdef DEBUGGING +#define RCHECK +#endif +/* + * malloc.c (Caltech) 2/21/82 + * Chris Kingsley, kingsley@cit-20. + * + * This is a very fast storage allocator. It allocates blocks of a small + * number of different sizes, and keeps free lists of each size. Blocks that + * don't exactly fit are passed up to the next larger size. In this + * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long. + * This is designed for use in a program that uses vast quantities of memory, + * but bombs when it runs out. + */ + +#include "EXTERN.h" +#include "perl.h" + +static findbucket(), morecore(); + +/* I don't much care whether these are defined in sys/types.h--LAW */ + +#define u_char unsigned char +#define u_int unsigned int +#define u_short unsigned short + +/* + * The overhead on a block is at least 4 bytes. When free, this space + * contains a pointer to the next free block, and the bottom two bits must + * be zero. When in use, the first byte is set to MAGIC, and the second + * byte is the size index. The remaining bytes are for alignment. + * If range checking is enabled and the size of the block fits + * in two bytes, then the top two bytes hold the size of the requested block + * plus the range checking words, and the header word MINUS ONE. + */ +union overhead { + union overhead *ov_next; /* when free */ +#if ALIGN_BYTES > 4 + double strut; /* alignment problems */ +#endif + struct { + u_char ovu_magic; /* magic number */ + u_char ovu_index; /* bucket # */ +#ifdef RCHECK + u_short ovu_size; /* actual block size */ + u_int ovu_rmagic; /* range magic number */ +#endif + } ovu; +#define ov_magic ovu.ovu_magic +#define ov_index ovu.ovu_index +#define ov_size ovu.ovu_size +#define ov_rmagic ovu.ovu_rmagic +}; + +#define MAGIC 0xff /* magic # on accounting info */ +#define OLDMAGIC 0x7f /* same after a free() */ +#define RMAGIC 0x55555555 /* magic # on range info */ +#ifdef RCHECK +#define RSLOP sizeof (u_int) +#else +#define RSLOP 0 +#endif + +/* + * nextf[i] is the pointer to the next free block of size 2^(i+3). The + * smallest allocatable block is 8 bytes. The overhead information + * precedes the data area returned to the user. + */ +#define NBUCKETS 30 +static union overhead *nextf[NBUCKETS]; +extern char *sbrk(); + +#ifdef MSTATS +/* + * nmalloc[i] is the difference between the number of mallocs and frees + * for a given block size. + */ +static u_int nmalloc[NBUCKETS]; +#include +#endif + +#ifdef debug +#define ASSERT(p) if (!(p)) botch("p"); else +static void +botch(s) + char *s; +{ + + printf("assertion botched: %s\n", s); + abort(); +} +#else +#define ASSERT(p) +#endif + +#ifdef safemalloc +static int an = 0; +#endif + +MALLOCPTRTYPE * +malloc(nbytes) + register MEM_SIZE nbytes; +{ + register union overhead *p; + register int bucket = 0; + register MEM_SIZE shiftr; + +#ifdef safemalloc +#ifdef DEBUGGING + MEM_SIZE size = nbytes; +#endif + +#ifdef MSDOS + if (nbytes > 0xffff) { + fprintf(stderr, "Allocation too large: %lx\n", (long)nbytes); + exit(1); + } +#endif /* MSDOS */ +#ifdef DEBUGGING + if ((long)nbytes < 0) + fatal("panic: malloc"); +#endif +#endif /* safemalloc */ + + /* + * Convert amount of memory requested into + * closest block size stored in hash buckets + * which satisfies request. Account for + * space used per block for accounting. + */ + nbytes += sizeof (union overhead) + RSLOP; + nbytes = (nbytes + 3) &~ 3; + shiftr = (nbytes - 1) >> 2; + /* apart from this loop, this is O(1) */ + while (shiftr >>= 1) + bucket++; + /* + * If nothing in hash bucket right now, + * request more memory from the system. + */ + if (nextf[bucket] == NULL) + morecore(bucket); + if ((p = (union overhead *)nextf[bucket]) == NULL) { +#ifdef safemalloc + if (!nomemok) { + fputs("Out of memory!\n", stderr); + exit(1); + } +#else + return (NULL); +#endif + } + +#ifdef safemalloc +#ifdef DEBUGGING +# if !(defined(I286) || defined(atarist)) + if (debug & 128) + fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",p+1,an++,(long)size); +# else + if (debug & 128) + fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",p+1,an++,(long)size); +# endif +#endif +#endif /* safemalloc */ + + /* remove from linked list */ +#ifdef RCHECK + if (*((int*)p) & (sizeof(union overhead) - 1)) +#if !(defined(I286) || defined(atarist)) + fprintf(stderr,"Corrupt malloc ptr 0x%x at 0x%x\n",*((int*)p),p); +#else + fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",*((int*)p),p); +#endif +#endif + nextf[bucket] = p->ov_next; + p->ov_magic = MAGIC; + p->ov_index= bucket; +#ifdef MSTATS + nmalloc[bucket]++; +#endif +#ifdef RCHECK + /* + * Record allocated size of block and + * bound space with magic numbers. + */ + if (nbytes <= 0x10000) + p->ov_size = nbytes - 1; + p->ov_rmagic = RMAGIC; + *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC; +#endif + return ((MALLOCPTRTYPE *)(p + 1)); +} + +/* + * Allocate more memory to the indicated bucket. + */ +static +morecore(bucket) + register int bucket; +{ + register union overhead *op; + register int rnu; /* 2^rnu bytes will be requested */ + register int nblks; /* become nblks blocks of the desired size */ + register MEM_SIZE siz; + + if (nextf[bucket]) + return; + /* + * Insure memory is allocated + * on a page boundary. Should + * make getpageize call? + */ +#ifndef atarist /* on the atari we dont have to worry about this */ + op = (union overhead *)sbrk(0); +#ifndef I286 + if ((int)op & 0x3ff) + (void)sbrk(1024 - ((int)op & 0x3ff)); +#else + /* The sbrk(0) call on the I286 always returns the next segment */ +#endif +#endif /* atarist */ + +#if !(defined(I286) || defined(atarist)) + /* take 2k unless the block is bigger than that */ + rnu = (bucket <= 8) ? 11 : bucket + 3; +#else + /* take 16k unless the block is bigger than that + (80286s like large segments!), probably good on the atari too */ + rnu = (bucket <= 11) ? 14 : bucket + 3; +#endif + nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */ + if (rnu < bucket) + rnu = bucket; + op = (union overhead *)sbrk(1L << rnu); + /* no more room! */ + if ((int)op == -1) + return; + /* + * Round up to minimum allocation size boundary + * and deduct from block count to reflect. + */ +#ifndef I286 + if ((int)op & 7) { + op = (union overhead *)(((MEM_SIZE)op + 8) &~ 7); + nblks--; + } +#else + /* Again, this should always be ok on an 80286 */ +#endif + /* + * Add new memory allocated to that on + * free list for this hash bucket. + */ + nextf[bucket] = op; + siz = 1 << (bucket + 3); + while (--nblks > 0) { + op->ov_next = (union overhead *)((caddr_t)op + siz); + op = (union overhead *)((caddr_t)op + siz); + } +} + +void +free(mp) + MALLOCPTRTYPE *mp; +{ + register MEM_SIZE size; + register union overhead *op; + char *cp = (char*)mp; + +#ifdef safemalloc +#ifdef DEBUGGING +# if !(defined(I286) || defined(atarist)) + if (debug & 128) + fprintf(stderr,"0x%x: (%05d) free\n",cp,an++); +# else + if (debug & 128) + fprintf(stderr,"0x%lx: (%05d) free\n",cp,an++); +# endif +#endif +#endif /* safemalloc */ + + if (cp == NULL) + return; + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); +#ifdef debug + ASSERT(op->ov_magic == MAGIC); /* make sure it was in use */ +#else + if (op->ov_magic != MAGIC) { + warn("%s free() ignored", + op->ov_magic == OLDMAGIC ? "Duplicate" : "Bad"); + return; /* sanity */ + } + op->ov_magic = OLDMAGIC; +#endif +#ifdef RCHECK + ASSERT(op->ov_rmagic == RMAGIC); + if (op->ov_index <= 13) + ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC); +#endif + ASSERT(op->ov_index < NBUCKETS); + size = op->ov_index; + op->ov_next = nextf[size]; + nextf[size] = op; +#ifdef MSTATS + nmalloc[size]--; +#endif +} + +/* + * When a program attempts "storage compaction" as mentioned in the + * old malloc man page, it realloc's an already freed block. Usually + * this is the last block it freed; occasionally it might be farther + * back. We have to search all the free lists for the block in order + * to determine its bucket: 1st we make one pass thru the lists + * checking only the first block in each; if that fails we search + * ``reall_srchlen'' blocks in each list for a match (the variable + * is extern so the caller can modify it). If that fails we just copy + * however many bytes was given to realloc() and hope it's not huge. + */ +int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */ + +MALLOCPTRTYPE * +realloc(mp, nbytes) + MALLOCPTRTYPE *mp; + MEM_SIZE nbytes; +{ + register MEM_SIZE onb; + union overhead *op; + char *res; + register int i; + int was_alloced = 0; + char *cp = (char*)mp; + +#ifdef safemalloc +#ifdef DEBUGGING + MEM_SIZE size = nbytes; +#endif + +#ifdef MSDOS + if (nbytes > 0xffff) { + fprintf(stderr, "Reallocation too large: %lx\n", size); + exit(1); + } +#endif /* MSDOS */ + if (!cp) + return malloc(nbytes); +#ifdef DEBUGGING + if ((long)nbytes < 0) + fatal("panic: realloc"); +#endif +#endif /* safemalloc */ + + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); + if (op->ov_magic == MAGIC) { + was_alloced++; + i = op->ov_index; + } else { + /* + * Already free, doing "compaction". + * + * Search for the old block of memory on the + * free list. First, check the most common + * case (last element free'd), then (this failing) + * the last ``reall_srchlen'' items free'd. + * If all lookups fail, then assume the size of + * the memory block being realloc'd is the + * smallest possible. + */ + if ((i = findbucket(op, 1)) < 0 && + (i = findbucket(op, reall_srchlen)) < 0) + i = 0; + } + onb = (1L << (i + 3)) - sizeof (*op) - RSLOP; + /* avoid the copy if same size block */ + if (was_alloced && + nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) { +#ifdef RCHECK + /* + * Record new allocated size of block and + * bound space with magic numbers. + */ + if (op->ov_index <= 13) { + /* + * Convert amount of memory requested into + * closest block size stored in hash buckets + * which satisfies request. Account for + * space used per block for accounting. + */ + nbytes += sizeof (union overhead) + RSLOP; + nbytes = (nbytes + 3) &~ 3; + op->ov_size = nbytes - 1; + *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC; + } +#endif + res = cp; + } + else { + if ((res = (char*)malloc(nbytes)) == NULL) + return (NULL); + if (cp != res) /* common optimization */ + Copy(cp, res, (MEM_SIZE)(nbytesov_next) { + if (p == freep) + return (i); + j++; + } + } + return (-1); +} + +#ifdef MSTATS +/* + * mstats - print out statistics about malloc + * + * Prints two lines of numbers, one showing the length of the free list + * for each size category, the second showing the number of mallocs - + * frees for each size category. + */ +void +mstats(s) + char *s; +{ + register int i, j; + register union overhead *p; + int totfree = 0, + totused = 0; + + fprintf(stderr, "Memory allocation statistics %s\nfree:\t", s); + for (i = 0; i < NBUCKETS; i++) { + for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) + ; + fprintf(stderr, " %d", j); + totfree += j * (1 << (i + 3)); + } + fprintf(stderr, "\nused:\t"); + for (i = 0; i < NBUCKETS; i++) { + fprintf(stderr, " %d", nmalloc[i]); + totused += nmalloc[i] * (1 << (i + 3)); + } + fprintf(stderr, "\n\tTotal in use: %d, total free: %d\n", + totused, totfree); +} +#endif +#endif /* lint */ diff --git a/gnu/usr.bin/perl/perl/patchlevel.h b/gnu/usr.bin/perl/perl/patchlevel.h new file mode 100644 index 0000000..d248b35 --- /dev/null +++ b/gnu/usr.bin/perl/perl/patchlevel.h @@ -0,0 +1 @@ +#define PATCHLEVEL 36 diff --git a/gnu/usr.bin/perl/perl/perl.1 b/gnu/usr.bin/perl/perl/perl.1 new file mode 100644 index 0000000..d074e74 --- /dev/null +++ b/gnu/usr.bin/perl/perl/perl.1 @@ -0,0 +1,6010 @@ +.rn '' }` +''' $RCSfile: perl.man,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:37 $ +''' +''' $Log: perl.man,v $ +.\" Revision 1.1.1.1 1993/08/23 21:29:37 nate +.\" PERL! +.\" +''' Revision 4.0.1.6 92/06/08 15:07:29 lwall +''' patch20: documented that numbers may contain underline +''' patch20: clarified that DATA may only be read from main script +''' patch20: relaxed requirement for semicolon at the end of a block +''' patch20: added ... as variant on .. +''' patch20: documented need for 1; at the end of a required file +''' patch20: extended bracket-style quotes to two-arg operators: s()() and tr()() +''' patch20: paragraph mode now skips extra newlines automatically +''' patch20: documented PERLLIB and PERLDB +''' patch20: documented limit on size of regexp +''' +''' Revision 4.0.1.5 91/11/11 16:42:00 lwall +''' patch19: added little-endian pack/unpack options +''' +''' Revision 4.0.1.4 91/11/05 18:11:05 lwall +''' patch11: added sort {} LIST +''' patch11: added eval {} +''' patch11: documented meaning of scalar(%foo) +''' patch11: sprintf() now supports any length of s field +''' +''' Revision 4.0.1.3 91/06/10 01:26:02 lwall +''' patch10: documented some newer features in addenda +''' +''' Revision 4.0.1.2 91/06/07 11:41:23 lwall +''' patch4: added global modifier for pattern matches +''' patch4: default top-of-form format is now FILEHANDLE_TOP +''' patch4: added $^P variable to control calling of perldb routines +''' patch4: added $^F variable to specify maximum system fd, default 2 +''' patch4: changed old $^P to $^X +''' +''' Revision 4.0.1.1 91/04/11 17:50:44 lwall +''' patch1: fixed some typos +''' +''' Revision 4.0 91/03/20 01:38:08 lwall +''' 4.0 baseline. +''' +''' +.de Sh +.br +.ne 5 +.PP +\fB\\$1\fR +.PP +.. +.de Sp +.if t .sp .5v +.if n .sp +.. +.de Ip +.br +.ie \\n(.$>=3 .ne \\$3 +.el .ne 3 +.IP "\\$1" \\$2 +.. +''' +''' Set up \*(-- to give an unbreakable dash; +''' string Tr holds user defined translation string. +''' Bell System Logo is used as a dummy character. +''' +.tr \(*W-|\(bv\*(Tr +.ie n \{\ +.ds -- \(*W- +.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch +.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch +.ds L" "" +.ds R" "" +.ds L' ' +.ds R' ' +'br\} +.el\{\ +.ds -- \(em\| +.tr \*(Tr +.ds L" `` +.ds R" '' +.ds L' ` +.ds R' ' +'br\} +.TH PERL 1 "\*(RP" +.UC +.SH NAME +perl \- Practical Extraction and Report Language +.SH SYNOPSIS +.B perl +[options] filename args +.SH DESCRIPTION +.I Perl +is an interpreted language optimized for scanning arbitrary text files, +extracting information from those text files, and printing reports based +on that information. +It's also a good language for many system management tasks. +The language is intended to be practical (easy to use, efficient, complete) +rather than beautiful (tiny, elegant, minimal). +It combines (in the author's opinion, anyway) some of the best features of C, +\fIsed\fR, \fIawk\fR, and \fIsh\fR, +so people familiar with those languages should have little difficulty with it. +(Language historians will also note some vestiges of \fIcsh\fR, Pascal, and +even BASIC-PLUS.) +Expression syntax corresponds quite closely to C expression syntax. +Unlike most Unix utilities, +.I perl +does not arbitrarily limit the size of your data\*(--if you've got +the memory, +.I perl +can slurp in your whole file as a single string. +Recursion is of unlimited depth. +And the hash tables used by associative arrays grow as necessary to prevent +degraded performance. +.I Perl +uses sophisticated pattern matching techniques to scan large amounts of +data very quickly. +Although optimized for scanning text, +.I perl +can also deal with binary data, and can make dbm files look like associative +arrays (where dbm is available). +Setuid +.I perl +scripts are safer than C programs +through a dataflow tracing mechanism which prevents many stupid security holes. +If you have a problem that would ordinarily use \fIsed\fR +or \fIawk\fR or \fIsh\fR, but it +exceeds their capabilities or must run a little faster, +and you don't want to write the silly thing in C, then +.I perl +may be for you. +There are also translators to turn your +.I sed +and +.I awk +scripts into +.I perl +scripts. +OK, enough hype. +.PP +Upon startup, +.I perl +looks for your script in one of the following places: +.Ip 1. 4 2 +Specified line by line via +.B \-e +switches on the command line. +.Ip 2. 4 2 +Contained in the file specified by the first filename on the command line. +(Note that systems supporting the #! notation invoke interpreters this way.) +.Ip 3. 4 2 +Passed in implicitly via standard input. +This only works if there are no filename arguments\*(--to pass +arguments to a +.I stdin +script you must explicitly specify a \- for the script name. +.PP +After locating your script, +.I perl +compiles it to an internal form. +If the script is syntactically correct, it is executed. +.Sh "Options" +Note: on first reading this section may not make much sense to you. It's here +at the front for easy reference. +.PP +A single-character option may be combined with the following option, if any. +This is particularly useful when invoking a script using the #! construct which +only allows one argument. Example: +.nf + +.ne 2 + #!/usr/bin/perl \-spi.bak # same as \-s \-p \-i.bak + .\|.\|. + +.fi +Options include: +.TP 5 +.BI \-0 digits +specifies the record separator ($/) as an octal number. +If there are no digits, the null character is the separator. +Other switches may precede or follow the digits. +For example, if you have a version of +.I find +which can print filenames terminated by the null character, you can say this: +.nf + + find . \-name '*.bak' \-print0 | perl \-n0e unlink + +.fi +The special value 00 will cause Perl to slurp files in paragraph mode. +The value 0777 will cause Perl to slurp files whole since there is no +legal character with that value. +.TP 5 +.B \-a +turns on autosplit mode when used with a +.B \-n +or +.BR \-p . +An implicit split command to the @F array +is done as the first thing inside the implicit while loop produced by +the +.B \-n +or +.BR \-p . +.nf + + perl \-ane \'print pop(@F), "\en";\' + +is equivalent to + + while (<>) { + @F = split(\' \'); + print pop(@F), "\en"; + } + +.fi +.TP 5 +.B \-c +causes +.I perl +to check the syntax of the script and then exit without executing it. +.TP 5 +.BI \-d +runs the script under the perl debugger. +See the section on Debugging. +.TP 5 +.BI \-D number +sets debugging flags. +To watch how it executes your script, use +.BR \-D14 . +(This only works if debugging is compiled into your +.IR perl .) +Another nice value is \-D1024, which lists your compiled syntax tree. +And \-D512 displays compiled regular expressions. +.TP 5 +.BI \-e " commandline" +may be used to enter one line of script. +Multiple +.B \-e +commands may be given to build up a multi-line script. +If +.B \-e +is given, +.I perl +will not look for a script filename in the argument list. +.TP 5 +.BI \-i extension +specifies that files processed by the <> construct are to be edited +in-place. +It does this by renaming the input file, opening the output file by the +same name, and selecting that output file as the default for print statements. +The extension, if supplied, is added to the name of the +old file to make a backup copy. +If no extension is supplied, no backup is made. +Saying \*(L"perl \-p \-i.bak \-e "s/foo/bar/;" .\|.\|. \*(R" is the same as using +the script: +.nf + +.ne 2 + #!/usr/bin/perl \-pi.bak + s/foo/bar/; + +which is equivalent to + +.ne 14 + #!/usr/bin/perl + while (<>) { + if ($ARGV ne $oldargv) { + rename($ARGV, $ARGV . \'.bak\'); + open(ARGVOUT, ">$ARGV"); + select(ARGVOUT); + $oldargv = $ARGV; + } + s/foo/bar/; + } + continue { + print; # this prints to original filename + } + select(STDOUT); + +.fi +except that the +.B \-i +form doesn't need to compare $ARGV to $oldargv to know when +the filename has changed. +It does, however, use ARGVOUT for the selected filehandle. +Note that +.I STDOUT +is restored as the default output filehandle after the loop. +.Sp +You can use eof to locate the end of each input file, in case you want +to append to each file, or reset line numbering (see example under eof). +.TP 5 +.BI \-I directory +may be used in conjunction with +.B \-P +to tell the C preprocessor where to look for include files. +By default /usr/include and /usr/lib/perl are searched. +.TP 5 +.BI \-l octnum +enables automatic line-ending processing. It has two effects: +first, it automatically chops the line terminator when used with +.B \-n +or +.B \-p , +and second, it assigns $\e to have the value of +.I octnum +so that any print statements will have that line terminator added back on. If +.I octnum +is omitted, sets $\e to the current value of $/. +For instance, to trim lines to 80 columns: +.nf + + perl -lpe \'substr($_, 80) = ""\' + +.fi +Note that the assignment $\e = $/ is done when the switch is processed, +so the input record separator can be different than the output record +separator if the +.B \-l +switch is followed by a +.B \-0 +switch: +.nf + + gnufind / -print0 | perl -ln0e 'print "found $_" if -p' + +.fi +This sets $\e to newline and then sets $/ to the null character. +.TP 5 +.B \-n +causes +.I perl +to assume the following loop around your script, which makes it iterate +over filename arguments somewhat like \*(L"sed \-n\*(R" or \fIawk\fR: +.nf + +.ne 3 + while (<>) { + .\|.\|. # your script goes here + } + +.fi +Note that the lines are not printed by default. +See +.B \-p +to have lines printed. +Here is an efficient way to delete all files older than a week: +.nf + + find . \-mtime +7 \-print | perl \-nle \'unlink;\' + +.fi +This is faster than using the \-exec switch of find because you don't have to +start a process on every filename found. +.TP 5 +.B \-p +causes +.I perl +to assume the following loop around your script, which makes it iterate +over filename arguments somewhat like \fIsed\fR: +.nf + +.ne 5 + while (<>) { + .\|.\|. # your script goes here + } continue { + print; + } + +.fi +Note that the lines are printed automatically. +To suppress printing use the +.B \-n +switch. +A +.B \-p +overrides a +.B \-n +switch. +.TP 5 +.B \-P +causes your script to be run through the C preprocessor before +compilation by +.IR perl . +(Since both comments and cpp directives begin with the # character, +you should avoid starting comments with any words recognized +by the C preprocessor such as \*(L"if\*(R", \*(L"else\*(R" or \*(L"define\*(R".) +.TP 5 +.B \-s +enables some rudimentary switch parsing for switches on the command line +after the script name but before any filename arguments (or before a \-\|\-). +Any switch found there is removed from @ARGV and sets the corresponding variable in the +.I perl +script. +The following script prints \*(L"true\*(R" if and only if the script is +invoked with a \-xyz switch. +.nf + +.ne 2 + #!/usr/bin/perl \-s + if ($xyz) { print "true\en"; } + +.fi +.TP 5 +.B \-S +makes +.I perl +use the PATH environment variable to search for the script +(unless the name of the script starts with a slash). +Typically this is used to emulate #! startup on machines that don't +support #!, in the following manner: +.nf + + #!/usr/bin/perl + eval "exec /usr/bin/perl \-S $0 $*" + if $running_under_some_shell; + +.fi +The system ignores the first line and feeds the script to /bin/sh, +which proceeds to try to execute the +.I perl +script as a shell script. +The shell executes the second line as a normal shell command, and thus +starts up the +.I perl +interpreter. +On some systems $0 doesn't always contain the full pathname, +so the +.B \-S +tells +.I perl +to search for the script if necessary. +After +.I perl +locates the script, it parses the lines and ignores them because +the variable $running_under_some_shell is never true. +A better construct than $* would be ${1+"$@"}, which handles embedded spaces +and such in the filenames, but doesn't work if the script is being interpreted +by csh. +In order to start up sh rather than csh, some systems may have to replace the +#! line with a line containing just +a colon, which will be politely ignored by perl. +Other systems can't control that, and need a totally devious construct that +will work under any of csh, sh or perl, such as the following: +.nf + +.ne 3 + eval '(exit $?0)' && eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + & eval 'exec /usr/bin/perl -S $0 $argv:q' + if 0; + +.fi +.TP 5 +.B \-u +causes +.I perl +to dump core after compiling your script. +You can then take this core dump and turn it into an executable file +by using the undump program (not supplied). +This speeds startup at the expense of some disk space (which you can +minimize by stripping the executable). +(Still, a "hello world" executable comes out to about 200K on my machine.) +If you are going to run your executable as a set-id program then you +should probably compile it using taintperl rather than normal perl. +If you want to execute a portion of your script before dumping, use the +dump operator instead. +Note: availability of undump is platform specific and may not be available +for a specific port of perl. +.TP 5 +.B \-U +allows +.I perl +to do unsafe operations. +Currently the only \*(L"unsafe\*(R" operations are the unlinking of directories while +running as superuser, and running setuid programs with fatal taint checks +turned into warnings. +.TP 5 +.B \-v +prints the version and patchlevel of your +.I perl +executable. +.TP 5 +.B \-w +prints warnings about identifiers that are mentioned only once, and scalar +variables that are used before being set. +Also warns about redefined subroutines, and references to undefined +filehandles or filehandles opened readonly that you are attempting to +write on. +Also warns you if you use == on values that don't look like numbers, and if +your subroutines recurse more than 100 deep. +.TP 5 +.BI \-x directory +tells +.I perl +that the script is embedded in a message. +Leading garbage will be discarded until the first line that starts +with #! and contains the string "perl". +Any meaningful switches on that line will be applied (but only one +group of switches, as with normal #! processing). +If a directory name is specified, Perl will switch to that directory +before running the script. +The +.B \-x +switch only controls the the disposal of leading garbage. +The script must be terminated with _\|_END_\|_ if there is trailing garbage +to be ignored (the script can process any or all of the trailing garbage +via the DATA filehandle if desired). +.Sh "Data Types and Objects" +.PP +.I Perl +has three data types: scalars, arrays of scalars, and +associative arrays of scalars. +Normal arrays are indexed by number, and associative arrays by string. +.PP +The interpretation of operations and values in perl sometimes +depends on the requirements +of the context around the operation or value. +There are three major contexts: string, numeric and array. +Certain operations return array values +in contexts wanting an array, and scalar values otherwise. +(If this is true of an operation it will be mentioned in the documentation +for that operation.) +Operations which return scalars don't care whether the context is looking +for a string or a number, but +scalar variables and values are interpreted as strings or numbers +as appropriate to the context. +A scalar is interpreted as TRUE in the boolean sense if it is not the null +string or 0. +Booleans returned by operators are 1 for true and 0 or \'\' (the null +string) for false. +.PP +There are actually two varieties of null string: defined and undefined. +Undefined null strings are returned when there is no real value for something, +such as when there was an error, or at end of file, or when you refer +to an uninitialized variable or element of an array. +An undefined null string may become defined the first time you access it, but +prior to that you can use the defined() operator to determine whether the +value is defined or not. +.PP +References to scalar variables always begin with \*(L'$\*(R', even when referring +to a scalar that is part of an array. +Thus: +.nf + +.ne 3 + $days \h'|2i'# a simple scalar variable + $days[28] \h'|2i'# 29th element of array @days + $days{\'Feb\'}\h'|2i'# one value from an associative array + $#days \h'|2i'# last index of array @days + +but entire arrays or array slices are denoted by \*(L'@\*(R': + + @days \h'|2i'# ($days[0], $days[1],\|.\|.\|. $days[n]) + @days[3,4,5]\h'|2i'# same as @days[3.\|.5] + @days{'a','c'}\h'|2i'# same as ($days{'a'},$days{'c'}) + +and entire associative arrays are denoted by \*(L'%\*(R': + + %days \h'|2i'# (key1, val1, key2, val2 .\|.\|.) +.fi +.PP +Any of these eight constructs may serve as an lvalue, +that is, may be assigned to. +(It also turns out that an assignment is itself an lvalue in +certain contexts\*(--see examples under s, tr and chop.) +Assignment to a scalar evaluates the righthand side in a scalar context, +while assignment to an array or array slice evaluates the righthand side +in an array context. +.PP +You may find the length of array @days by evaluating +\*(L"$#days\*(R", as in +.IR csh . +(Actually, it's not the length of the array, it's the subscript of the last element, since there is (ordinarily) a 0th element.) +Assigning to $#days changes the length of the array. +Shortening an array by this method does not actually destroy any values. +Lengthening an array that was previously shortened recovers the values that +were in those elements. +You can also gain some measure of efficiency by preextending an array that +is going to get big. +(You can also extend an array by assigning to an element that is off the +end of the array. +This differs from assigning to $#whatever in that intervening values +are set to null rather than recovered.) +You can truncate an array down to nothing by assigning the null list () to +it. +The following are exactly equivalent +.nf + + @whatever = (); + $#whatever = $[ \- 1; + +.fi +.PP +If you evaluate an array in a scalar context, it returns the length of +the array. +The following is always true: +.nf + + scalar(@whatever) == $#whatever \- $[ + 1; + +.fi +If you evaluate an associative array in a scalar context, it returns +a value which is true if and only if the array contains any elements. +(If there are any elements, the value returned is a string consisting +of the number of used buckets and the number of allocated buckets, separated +by a slash.) +.PP +Multi-dimensional arrays are not directly supported, but see the discussion +of the $; variable later for a means of emulating multiple subscripts with +an associative array. +You could also write a subroutine to turn multiple subscripts into a single +subscript. +.PP +Every data type has its own namespace. +You can, without fear of conflict, use the same name for a scalar variable, +an array, an associative array, a filehandle, a subroutine name, and/or +a label. +Since variable and array references always start with \*(L'$\*(R', \*(L'@\*(R', +or \*(L'%\*(R', the \*(L"reserved\*(R" words aren't in fact reserved +with respect to variable names. +(They ARE reserved with respect to labels and filehandles, however, which +don't have an initial special character. +Hint: you could say open(LOG,\'logfile\') rather than open(log,\'logfile\'). +Using uppercase filehandles also improves readability and protects you +from conflict with future reserved words.) +Case IS significant\*(--\*(L"FOO\*(R", \*(L"Foo\*(R" and \*(L"foo\*(R" are all +different names. +Names which start with a letter may also contain digits and underscores. +Names which do not start with a letter are limited to one character, +e.g. \*(L"$%\*(R" or \*(L"$$\*(R". +(Most of the one character names have a predefined significance to +.IR perl . +More later.) +.PP +Numeric literals are specified in any of the usual floating point or +integer formats: +.nf + +.ne 6 + 12345 + 12345.67 + .23E-10 + 0xffff # hex + 0377 # octal + 4_294_967_296 + +.fi +String literals are delimited by either single or double quotes. +They work much like shell quotes: +double-quoted string literals are subject to backslash and variable +substitution; single-quoted strings are not (except for \e\' and \e\e). +The usual backslash rules apply for making characters such as newline, tab, +etc., as well as some more exotic forms: +.nf + + \et tab + \en newline + \er return + \ef form feed + \eb backspace + \ea alarm (bell) + \ee escape + \e033 octal char + \ex1b hex char + \ec[ control char + \el lowercase next char + \eu uppercase next char + \eL lowercase till \eE + \eU uppercase till \eE + \eE end case modification + +.fi +You can also embed newlines directly in your strings, i.e. they can end on +a different line than they begin. +This is nice, but if you forget your trailing quote, the error will not be +reported until +.I perl +finds another line containing the quote character, which +may be much further on in the script. +Variable substitution inside strings is limited to scalar variables, normal +array values, and array slices. +(In other words, identifiers beginning with $ or @, followed by an optional +bracketed expression as a subscript.) +The following code segment prints out \*(L"The price is $100.\*(R" +.nf + +.ne 2 + $Price = \'$100\';\h'|3.5i'# not interpreted + print "The price is $Price.\e\|n";\h'|3.5i'# interpreted + +.fi +Note that you can put curly brackets around the identifier to delimit it +from following alphanumerics. +Also note that a single quoted string must be separated from a preceding +word by a space, since single quote is a valid character in an identifier +(see Packages). +.PP +Two special literals are _\|_LINE_\|_ and _\|_FILE_\|_, which represent the current +line number and filename at that point in your program. +They may only be used as separate tokens; they will not be interpolated +into strings. +In addition, the token _\|_END_\|_ may be used to indicate the logical end of the +script before the actual end of file. +Any following text is ignored, but may be read via the DATA filehandle. +(The DATA filehandle may read data only from the main script, but not from +any required file or evaluated string.) +The two control characters ^D and ^Z are synonyms for _\|_END_\|_. +.PP +A word that doesn't have any other interpretation in the grammar will be +treated as if it had single quotes around it. +For this purpose, a word consists only of alphanumeric characters and underline, +and must start with an alphabetic character. +As with filehandles and labels, a bare word that consists entirely of +lowercase letters risks conflict with future reserved words, and if you +use the +.B \-w +switch, Perl will warn you about any such words. +.PP +Array values are interpolated into double-quoted strings by joining all the +elements of the array with the delimiter specified in the $" variable, +space by default. +(Since in versions of perl prior to 3.0 the @ character was not a metacharacter +in double-quoted strings, the interpolation of @array, $array[EXPR], +@array[LIST], $array{EXPR}, or @array{LIST} only happens if array is +referenced elsewhere in the program or is predefined.) +The following are equivalent: +.nf + +.ne 4 + $temp = join($",@ARGV); + system "echo $temp"; + + system "echo @ARGV"; + +.fi +Within search patterns (which also undergo double-quotish substitution) +there is a bad ambiguity: Is /$foo[bar]/ to be +interpreted as /${foo}[bar]/ (where [bar] is a character class for the +regular expression) or as /${foo[bar]}/ (where [bar] is the subscript to +array @foo)? +If @foo doesn't otherwise exist, then it's obviously a character class. +If @foo exists, perl takes a good guess about [bar], and is almost always right. +If it does guess wrong, or if you're just plain paranoid, +you can force the correct interpretation with curly brackets as above. +.PP +A line-oriented form of quoting is based on the shell here-is syntax. +Following a << you specify a string to terminate the quoted material, and all lines +following the current line down to the terminating string are the value +of the item. +The terminating string may be either an identifier (a word), or some +quoted text. +If quoted, the type of quotes you use determines the treatment of the text, +just as in regular quoting. +An unquoted identifier works like double quotes. +There must be no space between the << and the identifier. +(If you put a space it will be treated as a null identifier, which is +valid, and matches the first blank line\*(--see Merry Christmas example below.) +The terminating string must appear by itself (unquoted and with no surrounding +whitespace) on the terminating line. +.nf + + print <) { print; } + while () { print; } + for (\|;\|;\|) { print; } + print while $_ = ; + print while ; + +.fi +The filehandles +.IR STDIN , +.I STDOUT +and +.I STDERR +are predefined. +(The filehandles +.IR stdin , +.I stdout +and +.I stderr +will also work except in packages, where they would be interpreted as +local identifiers rather than global.) +Additional filehandles may be created with the +.I open +function. +.PP +If a is used in a context that is looking for an array, an array +consisting of all the input lines is returned, one line per array element. +It's easy to make a LARGE data space this way, so use with care. +.PP +The null filehandle <> is special and can be used to emulate the behavior of +\fIsed\fR and \fIawk\fR. +Input from <> comes either from standard input, or from each file listed on +the command line. +Here's how it works: the first time <> is evaluated, the ARGV array is checked, +and if it is null, $ARGV[0] is set to \'-\', which when opened gives you standard +input. +The ARGV array is then processed as a list of filenames. +The loop +.nf + +.ne 3 + while (<>) { + .\|.\|. # code for each line + } + +.ne 10 +is equivalent to the following Perl-like pseudo code: + + unshift(@ARGV, \'\-\') \|if \|$#ARGV < $[; + while ($ARGV = shift) { + open(ARGV, $ARGV); + while () { + .\|.\|. # code for each line + } + } + +.fi +except that it isn't as cumbersome to say, and will actually work. +It really does shift array ARGV and put the current filename into +variable ARGV. +It also uses filehandle ARGV internally\*(--<> is just a synonym for +, which is magical. +(The pseudo code above doesn't work because it treats as non-magical.) +.PP +You can modify @ARGV before the first <> as long as the array ends up +containing the list of filenames you really want. +Line numbers ($.) continue as if the input was one big happy file. +(But see example under eof for how to reset line numbers on each file.) +.PP +.ne 5 +If you want to set @ARGV to your own list of files, go right ahead. +If you want to pass switches into your script, you can +put a loop on the front like this: +.nf + +.ne 10 + while ($_ = $ARGV[0], /\|^\-/\|) { + shift; + last if /\|^\-\|\-$\|/\|; + /\|^\-D\|(.*\|)/ \|&& \|($debug = $1); + /\|^\-v\|/ \|&& \|$verbose++; + .\|.\|. # other switches + } + while (<>) { + .\|.\|. # code for each line + } + +.fi +The <> symbol will return FALSE only once. +If you call it again after this it will assume you are processing another +@ARGV list, and if you haven't set @ARGV, will input from +.IR STDIN . +.PP +If the string inside the angle brackets is a reference to a scalar variable +(e.g. <$foo>), +then that variable contains the name of the filehandle to input from. +.PP +If the string inside angle brackets is not a filehandle, it is interpreted +as a filename pattern to be globbed, and either an array of filenames or the +next filename in the list is returned, depending on context. +One level of $ interpretation is done first, but you can't say <$foo> +because that's an indirect filehandle as explained in the previous +paragraph. +You could insert curly brackets to force interpretation as a +filename glob: <${foo}>. +Example: +.nf + +.ne 3 + while (<*.c>) { + chmod 0644, $_; + } + +is equivalent to + +.ne 5 + open(foo, "echo *.c | tr \-s \' \et\er\ef\' \'\e\e012\e\e012\e\e012\e\e012\'|"); + while () { + chop; + chmod 0644, $_; + } + +.fi +In fact, it's currently implemented that way. +(Which means it will not work on filenames with spaces in them unless +you have /bin/csh on your machine.) +Of course, the shortest way to do the above is: +.nf + + chmod 0644, <*.c>; + +.fi +.Sh "Syntax" +.PP +A +.I perl +script consists of a sequence of declarations and commands. +The only things that need to be declared in +.I perl +are report formats and subroutines. +See the sections below for more information on those declarations. +All uninitialized user-created objects are assumed to +start with a null or 0 value until they +are defined by some explicit operation such as assignment. +The sequence of commands is executed just once, unlike in +.I sed +and +.I awk +scripts, where the sequence of commands is executed for each input line. +While this means that you must explicitly loop over the lines of your input file +(or files), it also means you have much more control over which files and which +lines you look at. +(Actually, I'm lying\*(--it is possible to do an implicit loop with either the +.B \-n +or +.B \-p +switch.) +.PP +A declaration can be put anywhere a command can, but has no effect on the +execution of the primary sequence of commands\*(--declarations all take effect +at compile time. +Typically all the declarations are put at the beginning or the end of the script. +.PP +.I Perl +is, for the most part, a free-form language. +(The only exception to this is format declarations, for fairly obvious reasons.) +Comments are indicated by the # character, and extend to the end of the line. +If you attempt to use /* */ C comments, it will be interpreted either as +division or pattern matching, depending on the context. +So don't do that. +.Sh "Compound statements" +In +.IR perl , +a sequence of commands may be treated as one command by enclosing it +in curly brackets. +We will call this a BLOCK. +.PP +The following compound commands may be used to control flow: +.nf + +.ne 4 + if (EXPR) BLOCK + if (EXPR) BLOCK else BLOCK + if (EXPR) BLOCK elsif (EXPR) BLOCK .\|.\|. else BLOCK + LABEL while (EXPR) BLOCK + LABEL while (EXPR) BLOCK continue BLOCK + LABEL for (EXPR; EXPR; EXPR) BLOCK + LABEL foreach VAR (ARRAY) BLOCK + LABEL BLOCK continue BLOCK + +.fi +Note that, unlike C and Pascal, these are defined in terms of BLOCKs, not +statements. +This means that the curly brackets are \fIrequired\fR\*(--no dangling statements allowed. +If you want to write conditionals without curly brackets there are several +other ways to do it. +The following all do the same thing: +.nf + +.ne 5 + if (!open(foo)) { die "Can't open $foo: $!"; } + die "Can't open $foo: $!" unless open(foo); + open(foo) || die "Can't open $foo: $!"; # foo or bust! + open(foo) ? \'hi mom\' : die "Can't open $foo: $!"; + # a bit exotic, that last one + +.fi +.PP +The +.I if +statement is straightforward. +Since BLOCKs are always bounded by curly brackets, there is never any +ambiguity about which +.I if +an +.I else +goes with. +If you use +.I unless +in place of +.IR if , +the sense of the test is reversed. +.PP +The +.I while +statement executes the block as long as the expression is true +(does not evaluate to the null string or 0). +The LABEL is optional, and if present, consists of an identifier followed by +a colon. +The LABEL identifies the loop for the loop control statements +.IR next , +.IR last , +and +.I redo +(see below). +If there is a +.I continue +BLOCK, it is always executed just before +the conditional is about to be evaluated again, similarly to the third part +of a +.I for +loop in C. +Thus it can be used to increment a loop variable, even when the loop has +been continued via the +.I next +statement (similar to the C \*(L"continue\*(R" statement). +.PP +If the word +.I while +is replaced by the word +.IR until , +the sense of the test is reversed, but the conditional is still tested before +the first iteration. +.PP +In either the +.I if +or the +.I while +statement, you may replace \*(L"(EXPR)\*(R" with a BLOCK, and the conditional +is true if the value of the last command in that block is true. +.PP +The +.I for +loop works exactly like the corresponding +.I while +loop: +.nf + +.ne 12 + for ($i = 1; $i < 10; $i++) { + .\|.\|. + } + +is the same as + + $i = 1; + while ($i < 10) { + .\|.\|. + } continue { + $i++; + } +.fi +.PP +The foreach loop iterates over a normal array value and sets the variable +VAR to be each element of the array in turn. +The variable is implicitly local to the loop, and regains its former value +upon exiting the loop. +The \*(L"foreach\*(R" keyword is actually identical to the \*(L"for\*(R" keyword, +so you can use \*(L"foreach\*(R" for readability or \*(L"for\*(R" for brevity. +If VAR is omitted, $_ is set to each value. +If ARRAY is an actual array (as opposed to an expression returning an array +value), you can modify each element of the array +by modifying VAR inside the loop. +Examples: +.nf + +.ne 5 + for (@ary) { s/foo/bar/; } + + foreach $elem (@elements) { + $elem *= 2; + } + +.ne 3 + for ((10,9,8,7,6,5,4,3,2,1,\'BOOM\')) { + print $_, "\en"; sleep(1); + } + + for (1..15) { print "Merry Christmas\en"; } + +.ne 3 + foreach $item (split(/:[\e\e\en:]*/, $ENV{\'TERMCAP\'})) { + print "Item: $item\en"; + } + +.fi +.PP +The BLOCK by itself (labeled or not) is equivalent to a loop that executes +once. +Thus you can use any of the loop control statements in it to leave or +restart the block. +The +.I continue +block is optional. +This construct is particularly nice for doing case structures. +.nf + +.ne 6 + foo: { + if (/^abc/) { $abc = 1; last foo; } + if (/^def/) { $def = 1; last foo; } + if (/^xyz/) { $xyz = 1; last foo; } + $nothing = 1; + } + +.fi +There is no official switch statement in perl, because there +are already several ways to write the equivalent. +In addition to the above, you could write +.nf + +.ne 6 + foo: { + $abc = 1, last foo if /^abc/; + $def = 1, last foo if /^def/; + $xyz = 1, last foo if /^xyz/; + $nothing = 1; + } + +or + +.ne 6 + foo: { + /^abc/ && do { $abc = 1; last foo; }; + /^def/ && do { $def = 1; last foo; }; + /^xyz/ && do { $xyz = 1; last foo; }; + $nothing = 1; + } + +or + +.ne 6 + foo: { + /^abc/ && ($abc = 1, last foo); + /^def/ && ($def = 1, last foo); + /^xyz/ && ($xyz = 1, last foo); + $nothing = 1; + } + +or even + +.ne 8 + if (/^abc/) + { $abc = 1; } + elsif (/^def/) + { $def = 1; } + elsif (/^xyz/) + { $xyz = 1; } + else + {$nothing = 1;} + +.fi +As it happens, these are all optimized internally to a switch structure, +so perl jumps directly to the desired statement, and you needn't worry +about perl executing a lot of unnecessary statements when you have a string +of 50 elsifs, as long as you are testing the same simple scalar variable +using ==, eq, or pattern matching as above. +(If you're curious as to whether the optimizer has done this for a particular +case statement, you can use the \-D1024 switch to list the syntax tree +before execution.) +.Sh "Simple statements" +The only kind of simple statement is an expression evaluated for its side +effects. +Every simple statement must be terminated with a semicolon, unless it is the +final statement in a block, in which case the semicolon is optional. +(Semicolon is still encouraged there if the block takes up more than one line). +.PP +Any simple statement may optionally be followed by a +single modifier, just before the terminating semicolon. +The possible modifiers are: +.nf + +.ne 4 + if EXPR + unless EXPR + while EXPR + until EXPR + +.fi +The +.I if +and +.I unless +modifiers have the expected semantics. +The +.I while +and +.I until +modifiers also have the expected semantics (conditional evaluated first), +except when applied to a do-BLOCK or a do-SUBROUTINE command, +in which case the block executes once before the conditional is evaluated. +This is so that you can write loops like: +.nf + +.ne 4 + do { + $_ = ; + .\|.\|. + } until $_ \|eq \|".\|\e\|n"; + +.fi +(See the +.I do +operator below. Note also that the loop control commands described later will +NOT work in this construct, since modifiers don't take loop labels. +Sorry.) +.Sh "Expressions" +Since +.I perl +expressions work almost exactly like C expressions, only the differences +will be mentioned here. +.PP +Here's what +.I perl +has that C doesn't: +.Ip ** 8 2 +The exponentiation operator. +.Ip **= 8 +The exponentiation assignment operator. +.Ip (\|) 8 3 +The null list, used to initialize an array to null. +.Ip . 8 +Concatenation of two strings. +.Ip .= 8 +The concatenation assignment operator. +.Ip eq 8 +String equality (== is numeric equality). +For a mnemonic just think of \*(L"eq\*(R" as a string. +(If you are used to the +.I awk +behavior of using == for either string or numeric equality +based on the current form of the comparands, beware! +You must be explicit here.) +.Ip ne 8 +String inequality (!= is numeric inequality). +.Ip lt 8 +String less than. +.Ip gt 8 +String greater than. +.Ip le 8 +String less than or equal. +.Ip ge 8 +String greater than or equal. +.Ip cmp 8 +String comparison, returning -1, 0, or 1. +.Ip <=> 8 +Numeric comparison, returning -1, 0, or 1. +.Ip =~ 8 2 +Certain operations search or modify the string \*(L"$_\*(R" by default. +This operator makes that kind of operation work on some other string. +The right argument is a search pattern, substitution, or translation. +The left argument is what is supposed to be searched, substituted, or +translated instead of the default \*(L"$_\*(R". +The return value indicates the success of the operation. +(If the right argument is an expression other than a search pattern, +substitution, or translation, it is interpreted as a search pattern +at run time. +This is less efficient than an explicit search, since the pattern must +be compiled every time the expression is evaluated.) +The precedence of this operator is lower than unary minus and autoincrement/decrement, but higher than everything else. +.Ip !~ 8 +Just like =~ except the return value is negated. +.Ip x 8 +The repetition operator. +Returns a string consisting of the left operand repeated the +number of times specified by the right operand. +In an array context, if the left operand is a list in parens, it repeats +the list. +.nf + + print \'\-\' x 80; # print row of dashes + print \'\-\' x80; # illegal, x80 is identifier + + print "\et" x ($tab/8), \' \' x ($tab%8); # tab over + + @ones = (1) x 80; # an array of 80 1's + @ones = (5) x @ones; # set all elements to 5 + +.fi +.Ip x= 8 +The repetition assignment operator. +Only works on scalars. +.Ip .\|. 8 +The range operator, which is really two different operators depending +on the context. +In an array context, returns an array of values counting (by ones) +from the left value to the right value. +This is useful for writing \*(L"for (1..10)\*(R" loops and for doing +slice operations on arrays. +.Sp +In a scalar context, .\|. returns a boolean value. +The operator is bistable, like a flip-flop, and +emulates the line-range (comma) operator of sed, awk, and various editors. +Each .\|. operator maintains its own boolean state. +It is false as long as its left operand is false. +Once the left operand is true, the range operator stays true +until the right operand is true, +AFTER which the range operator becomes false again. +(It doesn't become false till the next time the range operator is evaluated. +It can test the right operand and become false on the +same evaluation it became true (as in awk), but it still returns true once. +If you don't want it to test the right operand till the next +evaluation (as in sed), use three dots (.\|.\|.) instead of two.) +The right operand is not evaluated while the operator is in the \*(L"false\*(R" state, +and the left operand is not evaluated while the operator is in the \*(L"true\*(R" state. +The precedence is a little lower than || and &&. +The value returned is either the null string for false, or a sequence number +(beginning with 1) for true. +The sequence number is reset for each range encountered. +The final sequence number in a range has the string \'E0\' appended to it, which +doesn't affect its numeric value, but gives you something to search for if you +want to exclude the endpoint. +You can exclude the beginning point by waiting for the sequence number to be +greater than 1. +If either operand of scalar .\|. is static, that operand is implicitly compared +to the $. variable, the current line number. +Examples: +.nf + +.ne 6 +As a scalar operator: + if (101 .\|. 200) { print; } # print 2nd hundred lines + + next line if (1 .\|. /^$/); # skip header lines + + s/^/> / if (/^$/ .\|. eof()); # quote body + +.ne 4 +As an array operator: + for (101 .\|. 200) { print; } # print $_ 100 times + + @foo = @foo[$[ .\|. $#foo]; # an expensive no-op + @foo = @foo[$#foo-4 .\|. $#foo]; # slice last 5 items + +.fi +.Ip \-x 8 +A file test. +This unary operator takes one argument, either a filename or a filehandle, +and tests the associated file to see if something is true about it. +If the argument is omitted, tests $_, except for \-t, which tests +.IR STDIN . +It returns 1 for true and \'\' for false, or the undefined value if the +file doesn't exist. +Precedence is higher than logical and relational operators, but lower than +arithmetic operators. +The operator may be any of: +.nf + \-r File is readable by effective uid/gid. + \-w File is writable by effective uid/gid. + \-x File is executable by effective uid/gid. + \-o File is owned by effective uid. + \-R File is readable by real uid/gid. + \-W File is writable by real uid/gid. + \-X File is executable by real uid/gid. + \-O File is owned by real uid. + \-e File exists. + \-z File has zero size. + \-s File has non-zero size (returns size). + \-f File is a plain file. + \-d File is a directory. + \-l File is a symbolic link. + \-p File is a named pipe (FIFO). + \-S File is a socket. + \-b File is a block special file. + \-c File is a character special file. + \-u File has setuid bit set. + \-g File has setgid bit set. + \-k File has sticky bit set. + \-t Filehandle is opened to a tty. + \-T File is a text file. + \-B File is a binary file (opposite of \-T). + \-M Age of file in days when script started. + \-A Same for access time. + \-C Same for inode change time. + +.fi +The interpretation of the file permission operators \-r, \-R, \-w, \-W, \-x and \-X +is based solely on the mode of the file and the uids and gids of the user. +There may be other reasons you can't actually read, write or execute the file. +Also note that, for the superuser, \-r, \-R, \-w and \-W always return 1, and +\-x and \-X return 1 if any execute bit is set in the mode. +Scripts run by the superuser may thus need to do a stat() in order to determine +the actual mode of the file, or temporarily set the uid to something else. +.Sp +Example: +.nf +.ne 7 + + while (<>) { + chop; + next unless \-f $_; # ignore specials + .\|.\|. + } + +.fi +Note that \-s/a/b/ does not do a negated substitution. +Saying \-exp($foo) still works as expected, however\*(--only single letters +following a minus are interpreted as file tests. +.Sp +The \-T and \-B switches work as follows. +The first block or so of the file is examined for odd characters such as +strange control codes or metacharacters. +If too many odd characters (>10%) are found, it's a \-B file, otherwise it's a \-T file. +Also, any file containing null in the first block is considered a binary file. +If \-T or \-B is used on a filehandle, the current stdio buffer is examined +rather than the first block. +Both \-T and \-B return TRUE on a null file, or a file at EOF when testing +a filehandle. +.PP +If any of the file tests (or either stat operator) are given the special +filehandle consisting of a solitary underline, then the stat structure +of the previous file test (or stat operator) is used, saving a system +call. +(This doesn't work with \-t, and you need to remember that lstat and -l +will leave values in the stat structure for the symbolic link, not the +real file.) +Example: +.nf + + print "Can do.\en" if -r $a || -w _ || -x _; + +.ne 9 + stat($filename); + print "Readable\en" if -r _; + print "Writable\en" if -w _; + print "Executable\en" if -x _; + print "Setuid\en" if -u _; + print "Setgid\en" if -g _; + print "Sticky\en" if -k _; + print "Text\en" if -T _; + print "Binary\en" if -B _; + +.fi +.PP +Here is what C has that +.I perl +doesn't: +.Ip "unary &" 12 +Address-of operator. +.Ip "unary *" 12 +Dereference-address operator. +.Ip "(TYPE)" 12 +Type casting operator. +.PP +Like C, +.I perl +does a certain amount of expression evaluation at compile time, whenever +it determines that all of the arguments to an operator are static and have +no side effects. +In particular, string concatenation happens at compile time between literals that don't do variable substitution. +Backslash interpretation also happens at compile time. +You can say +.nf + +.ne 2 + \'Now is the time for all\' . "\|\e\|n" . + \'good men to come to.\' + +.fi +and this all reduces to one string internally. +.PP +The autoincrement operator has a little extra built-in magic to it. +If you increment a variable that is numeric, or that has ever been used in +a numeric context, you get a normal increment. +If, however, the variable has only been used in string contexts since it +was set, and has a value that is not null and matches the +pattern /^[a\-zA\-Z]*[0\-9]*$/, the increment is done +as a string, preserving each character within its range, with carry: +.nf + + print ++($foo = \'99\'); # prints \*(L'100\*(R' + print ++($foo = \'a0\'); # prints \*(L'a1\*(R' + print ++($foo = \'Az\'); # prints \*(L'Ba\*(R' + print ++($foo = \'zz\'); # prints \*(L'aaa\*(R' + +.fi +The autodecrement is not magical. +.PP +The range operator (in an array context) makes use of the magical +autoincrement algorithm if the minimum and maximum are strings. +You can say + + @alphabet = (\'A\' .. \'Z\'); + +to get all the letters of the alphabet, or + + $hexdigit = (0 .. 9, \'a\' .. \'f\')[$num & 15]; + +to get a hexadecimal digit, or + + @z2 = (\'01\' .. \'31\'); print @z2[$mday]; + +to get dates with leading zeros. +(If the final value specified is not in the sequence that the magical increment +would produce, the sequence goes until the next value would be longer than +the final value specified.) +.PP +The || and && operators differ from C's in that, rather than returning 0 or 1, +they return the last value evaluated. +Thus, a portable way to find out the home directory might be: +.nf + + $home = $ENV{'HOME'} || $ENV{'LOGDIR'} || + (getpwuid($<))[7] || die "You're homeless!\en"; + +.fi +.PP +Along with the literals and variables mentioned earlier, +the operations in the following section can serve as terms in an expression. +Some of these operations take a LIST as an argument. +Such a list can consist of any combination of scalar arguments or array values; +the array values will be included in the list as if each individual element were +interpolated at that point in the list, forming a longer single-dimensional +array value. +Elements of the LIST should be separated by commas. +If an operation is listed both with and without parentheses around its +arguments, it means you can either use it as a unary operator or +as a function call. +To use it as a function call, the next token on the same line must +be a left parenthesis. +(There may be intervening white space.) +Such a function then has highest precedence, as you would expect from +a function. +If any token other than a left parenthesis follows, then it is a +unary operator, with a precedence depending only on whether it is a LIST +operator or not. +LIST operators have lowest precedence. +All other unary operators have a precedence greater than relational operators +but less than arithmetic operators. +See the section on Precedence. +.PP +For operators that can be used in either a scalar or array context, +failure is generally indicated in a scalar context by returning +the undefined value, and in an array context by returning the null list. +Remember though that +THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR. +Each operator decides which sort of scalar it would be most +appropriate to return. +Some operators return the length of the list +that would have been returned in an array context. +Some operators return the first value in the list. +Some operators return the last value in the list. +Some operators return a count of successful operations. +In general, they do what you want, unless you want consistency. +.Ip "/PATTERN/" 8 4 +See m/PATTERN/. +.Ip "?PATTERN?" 8 4 +This is just like the /pattern/ search, except that it matches only once between +calls to the +.I reset +operator. +This is a useful optimization when you only want to see the first occurrence of +something in each file of a set of files, for instance. +Only ?? patterns local to the current package are reset. +.Ip "accept(NEWSOCKET,GENERICSOCKET)" 8 2 +Does the same thing that the accept system call does. +Returns true if it succeeded, false otherwise. +See example in section on Interprocess Communication. +.Ip "alarm(SECONDS)" 8 4 +.Ip "alarm SECONDS" 8 +Arranges to have a SIGALRM delivered to this process after the specified number +of seconds (minus 1, actually) have elapsed. Thus, alarm(15) will cause +a SIGALRM at some point more than 14 seconds in the future. +Only one timer may be counting at once. Each call disables the previous +timer, and an argument of 0 may be supplied to cancel the previous timer +without starting a new one. +The returned value is the amount of time remaining on the previous timer. +.Ip "atan2(Y,X)" 8 2 +Returns the arctangent of Y/X in the range +.if t \-\(*p to \(*p. +.if n \-PI to PI. +.Ip "bind(SOCKET,NAME)" 8 2 +Does the same thing that the bind system call does. +Returns true if it succeeded, false otherwise. +NAME should be a packed address of the proper type for the socket. +See example in section on Interprocess Communication. +.Ip "binmode(FILEHANDLE)" 8 4 +.Ip "binmode FILEHANDLE" 8 4 +Arranges for the file to be read in \*(L"binary\*(R" mode in operating systems +that distinguish between binary and text files. +Files that are not read in binary mode have CR LF sequences translated +to LF on input and LF translated to CR LF on output. +Binmode has no effect under Unix. +If FILEHANDLE is an expression, the value is taken as the name of +the filehandle. +.Ip "caller(EXPR)" +.Ip "caller" +Returns the context of the current subroutine call: +.nf + + ($package,$filename,$line) = caller; + +.fi +With EXPR, returns some extra information that the debugger uses to print +a stack trace. The value of EXPR indicates how many call frames to go +back before the current one. +.Ip "chdir(EXPR)" 8 2 +.Ip "chdir EXPR" 8 2 +Changes the working directory to EXPR, if possible. +If EXPR is omitted, changes to home directory. +Returns 1 upon success, 0 otherwise. +See example under +.IR die . +.Ip "chmod(LIST)" 8 2 +.Ip "chmod LIST" 8 2 +Changes the permissions of a list of files. +The first element of the list must be the numerical mode. +Returns the number of files successfully changed. +.nf + +.ne 2 + $cnt = chmod 0755, \'foo\', \'bar\'; + chmod 0755, @executables; + +.fi +.Ip "chop(LIST)" 8 7 +.Ip "chop(VARIABLE)" 8 +.Ip "chop VARIABLE" 8 +.Ip "chop" 8 +Chops off the last character of a string and returns the character chopped. +It's used primarily to remove the newline from the end of an input record, +but is much more efficient than s/\en// because it neither scans nor copies +the string. +If VARIABLE is omitted, chops $_. +Example: +.nf + +.ne 5 + while (<>) { + chop; # avoid \en on last field + @array = split(/:/); + .\|.\|. + } + +.fi +You can actually chop anything that's an lvalue, including an assignment: +.nf + + chop($cwd = \`pwd\`); + chop($answer = ); + +.fi +If you chop a list, each element is chopped. +Only the value of the last chop is returned. +.Ip "chown(LIST)" 8 2 +.Ip "chown LIST" 8 2 +Changes the owner (and group) of a list of files. +The first two elements of the list must be the NUMERICAL uid and gid, +in that order. +Returns the number of files successfully changed. +.nf + +.ne 2 + $cnt = chown $uid, $gid, \'foo\', \'bar\'; + chown $uid, $gid, @filenames; + +.fi +.ne 23 +Here's an example that looks up non-numeric uids in the passwd file: +.nf + + print "User: "; + $user = ; + chop($user); + print "Files: " + $pattern = ; + chop($pattern); +.ie t \{\ + open(pass, \'/etc/passwd\') || die "Can't open passwd: $!\en"; +'br\} +.el \{\ + open(pass, \'/etc/passwd\') + || die "Can't open passwd: $!\en"; +'br\} + while () { + ($login,$pass,$uid,$gid) = split(/:/); + $uid{$login} = $uid; + $gid{$login} = $gid; + } + @ary = <${pattern}>; # get filenames + if ($uid{$user} eq \'\') { + die "$user not in passwd file"; + } + else { + chown $uid{$user}, $gid{$user}, @ary; + } + +.fi +.Ip "chroot(FILENAME)" 8 5 +.Ip "chroot FILENAME" 8 +Does the same as the system call of that name. +If you don't know what it does, don't worry about it. +If FILENAME is omitted, does chroot to $_. +.Ip "close(FILEHANDLE)" 8 5 +.Ip "close FILEHANDLE" 8 +Closes the file or pipe associated with the file handle. +You don't have to close FILEHANDLE if you are immediately going to +do another open on it, since open will close it for you. +(See +.IR open .) +However, an explicit close on an input file resets the line counter ($.), while +the implicit close done by +.I open +does not. +Also, closing a pipe will wait for the process executing on the pipe to complete, +in case you want to look at the output of the pipe afterwards. +Closing a pipe explicitly also puts the status value of the command into $?. +Example: +.nf + +.ne 4 + open(OUTPUT, \'|sort >foo\'); # pipe to sort + .\|.\|. # print stuff to output + close OUTPUT; # wait for sort to finish + open(INPUT, \'foo\'); # get sort's results + +.fi +FILEHANDLE may be an expression whose value gives the real filehandle name. +.Ip "closedir(DIRHANDLE)" 8 5 +.Ip "closedir DIRHANDLE" 8 +Closes a directory opened by opendir(). +.Ip "connect(SOCKET,NAME)" 8 2 +Does the same thing that the connect system call does. +Returns true if it succeeded, false otherwise. +NAME should be a package address of the proper type for the socket. +See example in section on Interprocess Communication. +.Ip "cos(EXPR)" 8 6 +.Ip "cos EXPR" 8 6 +Returns the cosine of EXPR (expressed in radians). +If EXPR is omitted takes cosine of $_. +.Ip "crypt(PLAINTEXT,SALT)" 8 6 +Encrypts a string exactly like the crypt() function in the C library. +Useful for checking the password file for lousy passwords. +Only the guys wearing white hats should do this. +.Ip "dbmclose(ASSOC_ARRAY)" 8 6 +.Ip "dbmclose ASSOC_ARRAY" 8 +Breaks the binding between a dbm file and an associative array. +The values remaining in the associative array are meaningless unless +you happen to want to know what was in the cache for the dbm file. +This function is only useful if you have ndbm. +.Ip "dbmopen(ASSOC,DBNAME,MODE)" 8 6 +This binds a dbm or ndbm file to an associative array. +ASSOC is the name of the associative array. +(Unlike normal open, the first argument is NOT a filehandle, even though +it looks like one). +DBNAME is the name of the database (without the .dir or .pag extension). +If the database does not exist, it is created with protection specified +by MODE (as modified by the umask). +If your system only supports the older dbm functions, you may perform only one +dbmopen in your program. +If your system has neither dbm nor ndbm, calling dbmopen produces a fatal +error. +.Sp +Values assigned to the associative array prior to the dbmopen are lost. +A certain number of values from the dbm file are cached in memory. +By default this number is 64, but you can increase it by preallocating +that number of garbage entries in the associative array before the dbmopen. +You can flush the cache if necessary with the reset command. +.Sp +If you don't have write access to the dbm file, you can only read +associative array variables, not set them. +If you want to test whether you can write, either use file tests or +try setting a dummy array entry inside an eval, which will trap the error. +.Sp +Note that functions such as keys() and values() may return huge array values +when used on large dbm files. +You may prefer to use the each() function to iterate over large dbm files. +Example: +.nf + +.ne 6 + # print out history file offsets + dbmopen(HIST,'/usr/lib/news/history',0666); + while (($key,$val) = each %HIST) { + print $key, ' = ', unpack('L',$val), "\en"; + } + dbmclose(HIST); + +.fi +.Ip "defined(EXPR)" 8 6 +.Ip "defined EXPR" 8 +Returns a boolean value saying whether the lvalue EXPR has a real value +or not. +Many operations return the undefined value under exceptional conditions, +such as end of file, uninitialized variable, system error and such. +This function allows you to distinguish between an undefined null string +and a defined null string with operations that might return a real null +string, in particular referencing elements of an array. +You may also check to see if arrays or subroutines exist. +Use on predefined variables is not guaranteed to produce intuitive results. +Examples: +.nf + +.ne 7 + print if defined $switch{'D'}; + print "$val\en" while defined($val = pop(@ary)); + die "Can't readlink $sym: $!" + unless defined($value = readlink $sym); + eval '@foo = ()' if defined(@foo); + die "No XYZ package defined" unless defined %_XYZ; + sub foo { defined &$bar ? &$bar(@_) : die "No bar"; } + +.fi +See also undef. +.Ip "delete $ASSOC{KEY}" 8 6 +Deletes the specified value from the specified associative array. +Returns the deleted value, or the undefined value if nothing was deleted. +Deleting from $ENV{} modifies the environment. +Deleting from an array bound to a dbm file deletes the entry from the dbm +file. +.Sp +The following deletes all the values of an associative array: +.nf + +.ne 3 + foreach $key (keys %ARRAY) { + delete $ARRAY{$key}; + } + +.fi +(But it would be faster to use the +.I reset +command. +Saying undef %ARRAY is faster yet.) +.Ip "die(LIST)" 8 +.Ip "die LIST" 8 +Outside of an eval, prints the value of LIST to +.I STDERR +and exits with the current value of $! +(errno). +If $! is 0, exits with the value of ($? >> 8) (\`command\` status). +If ($? >> 8) is 0, exits with 255. +Inside an eval, the error message is stuffed into $@ and the eval is terminated +with the undefined value. +.Sp +Equivalent examples: +.nf + +.ne 3 +.ie t \{\ + die "Can't cd to spool: $!\en" unless chdir \'/usr/spool/news\'; +'br\} +.el \{\ + die "Can't cd to spool: $!\en" + unless chdir \'/usr/spool/news\'; +'br\} + + chdir \'/usr/spool/news\' || die "Can't cd to spool: $!\en" + +.fi +.Sp +If the value of EXPR does not end in a newline, the current script line +number and input line number (if any) are also printed, and a newline is +supplied. +Hint: sometimes appending \*(L", stopped\*(R" to your message will cause it to make +better sense when the string \*(L"at foo line 123\*(R" is appended. +Suppose you are running script \*(L"canasta\*(R". +.nf + +.ne 7 + die "/etc/games is no good"; + die "/etc/games is no good, stopped"; + +produce, respectively + + /etc/games is no good at canasta line 123. + /etc/games is no good, stopped at canasta line 123. + +.fi +See also +.IR exit . +.Ip "do BLOCK" 8 4 +Returns the value of the last command in the sequence of commands indicated +by BLOCK. +When modified by a loop modifier, executes the BLOCK once before testing the +loop condition. +(On other statements the loop modifiers test the conditional first.) +.Ip "do SUBROUTINE (LIST)" 8 3 +Executes a SUBROUTINE declared by a +.I sub +declaration, and returns the value +of the last expression evaluated in SUBROUTINE. +If there is no subroutine by that name, produces a fatal error. +(You may use the \*(L"defined\*(R" operator to determine if a subroutine +exists.) +If you pass arrays as part of LIST you may wish to pass the length +of the array in front of each array. +(See the section on subroutines later on.) +The parentheses are required to avoid confusion with the \*(L"do EXPR\*(R" +form. +.Sp +SUBROUTINE may also be a single scalar variable, in which case +the name of the subroutine to execute is taken from the variable. +.Sp +As an alternate (and preferred) form, +you may call a subroutine by prefixing the name with +an ampersand: &foo(@args). +If you aren't passing any arguments, you don't have to use parentheses. +If you omit the parentheses, no @_ array is passed to the subroutine. +The & form is also used to specify subroutines to the defined and undef +operators: +.nf + + if (defined &$var) { &$var($parm); undef &$var; } + +.fi +.Ip "do EXPR" 8 3 +Uses the value of EXPR as a filename and executes the contents of the file +as a +.I perl +script. +Its primary use is to include subroutines from a +.I perl +subroutine library. +.nf + + do \'stat.pl\'; + +is just like + + eval \`cat stat.pl\`; + +.fi +except that it's more efficient, more concise, keeps track of the current +filename for error messages, and searches all the +.B \-I +libraries if the file +isn't in the current directory (see also the @INC array in Predefined Names). +It's the same, however, in that it does reparse the file every time you +call it, so if you are going to use the file inside a loop you might prefer +to use \-P and #include, at the expense of a little more startup time. +(The main problem with #include is that cpp doesn't grok # comments\*(--a +workaround is to use \*(L";#\*(R" for standalone comments.) +Note that the following are NOT equivalent: +.nf + +.ne 2 + do $foo; # eval a file + do $foo(); # call a subroutine + +.fi +Note that inclusion of library routines is better done with +the \*(L"require\*(R" operator. +.Ip "dump LABEL" 8 6 +This causes an immediate core dump. +Primarily this is so that you can use the undump program to turn your +core dump into an executable binary after having initialized all your +variables at the beginning of the program. +When the new binary is executed it will begin by executing a "goto LABEL" +(with all the restrictions that goto suffers). +Think of it as a goto with an intervening core dump and reincarnation. +If LABEL is omitted, restarts the program from the top. +WARNING: any files opened at the time of the dump will NOT be open any more +when the program is reincarnated, with possible resulting confusion on the part +of perl. +See also \-u. +.Sp +Example: +.nf + +.ne 16 + #!/usr/bin/perl + require 'getopt.pl'; + require 'stat.pl'; + %days = ( + 'Sun',1, + 'Mon',2, + 'Tue',3, + 'Wed',4, + 'Thu',5, + 'Fri',6, + 'Sat',7); + + dump QUICKSTART if $ARGV[0] eq '-d'; + + QUICKSTART: + do Getopt('f'); + +.fi +.Ip "each(ASSOC_ARRAY)" 8 6 +.Ip "each ASSOC_ARRAY" 8 +Returns a 2 element array consisting of the key and value for the next +value of an associative array, so that you can iterate over it. +Entries are returned in an apparently random order. +When the array is entirely read, a null array is returned (which when +assigned produces a FALSE (0) value). +The next call to each() after that will start iterating again. +The iterator can be reset only by reading all the elements from the array. +You must not modify the array while iterating over it. +There is a single iterator for each associative array, shared by all +each(), keys() and values() function calls in the program. +The following prints out your environment like the printenv program, only +in a different order: +.nf + +.ne 3 + while (($key,$value) = each %ENV) { + print "$key=$value\en"; + } + +.fi +See also keys() and values(). +.Ip "eof(FILEHANDLE)" 8 8 +.Ip "eof()" 8 +.Ip "eof" 8 +Returns 1 if the next read on FILEHANDLE will return end of file, or if +FILEHANDLE is not open. +FILEHANDLE may be an expression whose value gives the real filehandle name. +(Note that this function actually reads a character and then ungetc's it, +so it is not very useful in an interactive context.) +An eof without an argument returns the eof status for the last file read. +Empty parentheses () may be used to indicate the pseudo file formed of the +files listed on the command line, i.e. eof() is reasonable to use inside +a while (<>) loop to detect the end of only the last file. +Use eof(ARGV) or eof without the parentheses to test EACH file in a while (<>) loop. +Examples: +.nf + +.ne 7 + # insert dashes just before last line of last file + while (<>) { + if (eof()) { + print "\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\|\-\en"; + } + print; + } + +.ne 7 + # reset line numbering on each input file + while (<>) { + print "$.\et$_"; + if (eof) { # Not eof(). + close(ARGV); + } + } + +.fi +.Ip "eval(EXPR)" 8 6 +.Ip "eval EXPR" 8 6 +.Ip "eval BLOCK" 8 6 +EXPR is parsed and executed as if it were a little +.I perl +program. +It is executed in the context of the current +.I perl +program, so that +any variable settings, subroutine or format definitions remain afterwards. +The value returned is the value of the last expression evaluated, just +as with subroutines. +If there is a syntax error or runtime error, or a die statement is +executed, an undefined value is returned by +eval, and $@ is set to the error message. +If there was no error, $@ is guaranteed to be a null string. +If EXPR is omitted, evaluates $_. +The final semicolon, if any, may be omitted from the expression. +.Sp +Note that, since eval traps otherwise-fatal errors, it is useful for +determining whether a particular feature +(such as dbmopen or symlink) is implemented. +It is also Perl's exception trapping mechanism, where the die operator is +used to raise exceptions. +.Sp +If the code to be executed doesn't vary, you may use +the eval-BLOCK form to trap run-time errors without incurring +the penalty of recompiling each time. +The error, if any, is still returned in $@. +Evaluating a single-quoted string (as EXPR) has the same effect, except that +the eval-EXPR form reports syntax errors at run time via $@, whereas the +eval-BLOCK form reports syntax errors at compile time. The eval-EXPR form +is optimized to eval-BLOCK the first time it succeeds. (Since the replacement +side of a substitution is considered a single-quoted string when you +use the e modifier, the same optimization occurs there.) Examples: +.nf + +.ne 11 + # make divide-by-zero non-fatal + eval { $answer = $a / $b; }; warn $@ if $@; + + # optimized to same thing after first use + eval '$answer = $a / $b'; warn $@ if $@; + + # a compile-time error + eval { $answer = }; + + # a run-time error + eval '$answer ='; # sets $@ + +.fi +.Ip "exec(LIST)" 8 8 +.Ip "exec LIST" 8 6 +If there is more than one argument in LIST, or if LIST is an array with +more than one value, +calls execvp() with the arguments in LIST. +If there is only one scalar argument, the argument is checked for shell metacharacters. +If there are any, the entire argument is passed to \*(L"/bin/sh \-c\*(R" for parsing. +If there are none, the argument is split into words and passed directly to +execvp(), which is more efficient. +Note: exec (and system) do not flush your output buffer, so you may need to +set $| to avoid lost output. +Examples: +.nf + + exec \'/bin/echo\', \'Your arguments are: \', @ARGV; + exec "sort $outfile | uniq"; + +.fi +.Sp +If you don't really want to execute the first argument, but want to lie +to the program you are executing about its own name, you can specify +the program you actually want to run by assigning that to a variable and +putting the name of the variable in front of the LIST without a comma. +(This always forces interpretation of the LIST as a multi-valued list, even +if there is only a single scalar in the list.) +Example: +.nf + +.ne 2 + $shell = '/bin/csh'; + exec $shell '-sh'; # pretend it's a login shell + +.fi +.Ip "exit(EXPR)" 8 6 +.Ip "exit EXPR" 8 +Evaluates EXPR and exits immediately with that value. +Example: +.nf + +.ne 2 + $ans = ; + exit 0 \|if \|$ans \|=~ \|/\|^[Xx]\|/\|; + +.fi +See also +.IR die . +If EXPR is omitted, exits with 0 status. +.Ip "exp(EXPR)" 8 3 +.Ip "exp EXPR" 8 +Returns +.I e +to the power of EXPR. +If EXPR is omitted, gives exp($_). +.Ip "fcntl(FILEHANDLE,FUNCTION,SCALAR)" 8 4 +Implements the fcntl(2) function. +You'll probably have to say +.nf + + require "fcntl.ph"; # probably /usr/local/lib/perl/fcntl.ph + +.fi +first to get the correct function definitions. +If fcntl.ph doesn't exist or doesn't have the correct definitions +you'll have to roll +your own, based on your C header files such as . +(There is a perl script called h2ph that comes with the perl kit +which may help you in this.) +Argument processing and value return works just like ioctl below. +Note that fcntl will produce a fatal error if used on a machine that doesn't implement +fcntl(2). +.Ip "fileno(FILEHANDLE)" 8 4 +.Ip "fileno FILEHANDLE" 8 4 +Returns the file descriptor for a filehandle. +Useful for constructing bitmaps for select(). +If FILEHANDLE is an expression, the value is taken as the name of +the filehandle. +.Ip "flock(FILEHANDLE,OPERATION)" 8 4 +Calls flock(2) on FILEHANDLE. +See manual page for flock(2) for definition of OPERATION. +Returns true for success, false on failure. +Will produce a fatal error if used on a machine that doesn't implement +flock(2). +Here's a mailbox appender for BSD systems. +.nf + +.ne 20 + $LOCK_SH = 1; + $LOCK_EX = 2; + $LOCK_NB = 4; + $LOCK_UN = 8; + + sub lock { + flock(MBOX,$LOCK_EX); + # and, in case someone appended + # while we were waiting... + seek(MBOX, 0, 2); + } + + sub unlock { + flock(MBOX,$LOCK_UN); + } + + open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}") + || die "Can't open mailbox: $!"; + + do lock(); + print MBOX $msg,"\en\en"; + do unlock(); + +.fi +.Ip "fork" 8 4 +Does a fork() call. +Returns the child pid to the parent process and 0 to the child process. +Note: unflushed buffers remain unflushed in both processes, which means +you may need to set $| to avoid duplicate output. +.Ip "getc(FILEHANDLE)" 8 4 +.Ip "getc FILEHANDLE" 8 +.Ip "getc" 8 +Returns the next character from the input file attached to FILEHANDLE, or +a null string at EOF. +If FILEHANDLE is omitted, reads from STDIN. +.Ip "getlogin" 8 3 +Returns the current login from /etc/utmp, if any. +If null, use getpwuid. + + $login = getlogin || (getpwuid($<))[0] || "Somebody"; + +.Ip "getpeername(SOCKET)" 8 3 +Returns the packed sockaddr address of other end of the SOCKET connection. +.nf + +.ne 4 + # An internet sockaddr + $sockaddr = 'S n a4 x8'; + $hersockaddr = getpeername(S); +.ie t \{\ + ($family, $port, $heraddr) = unpack($sockaddr,$hersockaddr); +'br\} +.el \{\ + ($family, $port, $heraddr) = + unpack($sockaddr,$hersockaddr); +'br\} + +.fi +.Ip "getpgrp(PID)" 8 4 +.Ip "getpgrp PID" 8 +Returns the current process group for the specified PID, 0 for the current +process. +Will produce a fatal error if used on a machine that doesn't implement +getpgrp(2). +If EXPR is omitted, returns process group of current process. +.Ip "getppid" 8 4 +Returns the process id of the parent process. +.Ip "getpriority(WHICH,WHO)" 8 4 +Returns the current priority for a process, a process group, or a user. +(See getpriority(2).) +Will produce a fatal error if used on a machine that doesn't implement +getpriority(2). +.Ip "getpwnam(NAME)" 8 +.Ip "getgrnam(NAME)" 8 +.Ip "gethostbyname(NAME)" 8 +.Ip "getnetbyname(NAME)" 8 +.Ip "getprotobyname(NAME)" 8 +.Ip "getpwuid(UID)" 8 +.Ip "getgrgid(GID)" 8 +.Ip "getservbyname(NAME,PROTO)" 8 +.Ip "gethostbyaddr(ADDR,ADDRTYPE)" 8 +.Ip "getnetbyaddr(ADDR,ADDRTYPE)" 8 +.Ip "getprotobynumber(NUMBER)" 8 +.Ip "getservbyport(PORT,PROTO)" 8 +.Ip "getpwent" 8 +.Ip "getgrent" 8 +.Ip "gethostent" 8 +.Ip "getnetent" 8 +.Ip "getprotoent" 8 +.Ip "getservent" 8 +.Ip "setpwent" 8 +.Ip "setgrent" 8 +.Ip "sethostent(STAYOPEN)" 8 +.Ip "setnetent(STAYOPEN)" 8 +.Ip "setprotoent(STAYOPEN)" 8 +.Ip "setservent(STAYOPEN)" 8 +.Ip "endpwent" 8 +.Ip "endgrent" 8 +.Ip "endhostent" 8 +.Ip "endnetent" 8 +.Ip "endprotoent" 8 +.Ip "endservent" 8 +These routines perform the same functions as their counterparts in the +system library. +Within an array context, +the return values from the various get routines are as follows: +.nf + + ($name,$passwd,$uid,$gid, + $quota,$comment,$gcos,$dir,$shell) = getpw.\|.\|. + ($name,$passwd,$gid,$members) = getgr.\|.\|. + ($name,$aliases,$addrtype,$length,@addrs) = gethost.\|.\|. + ($name,$aliases,$addrtype,$net) = getnet.\|.\|. + ($name,$aliases,$proto) = getproto.\|.\|. + ($name,$aliases,$port,$proto) = getserv.\|.\|. + +.fi +(If the entry doesn't exist you get a null list.) +.Sp +Within a scalar context, you get the name, unless the function was a +lookup by name, in which case you get the other thing, whatever it is. +(If the entry doesn't exist you get the undefined value.) +For example: +.nf + + $uid = getpwnam + $name = getpwuid + $name = getpwent + $gid = getgrnam + $name = getgrgid + $name = getgrent + etc. + +.fi +The $members value returned by getgr.\|.\|. is a space separated list +of the login names of the members of the group. +.Sp +For the gethost.\|.\|. functions, if the h_errno variable is supported in C, +it will be returned to you via $? if the function call fails. +The @addrs value returned by a successful call is a list of the +raw addresses returned by the corresponding system library call. +In the Internet domain, each address is four bytes long and you can unpack +it by saying something like: +.nf + + ($a,$b,$c,$d) = unpack('C4',$addr[0]); + +.fi +.Ip "getsockname(SOCKET)" 8 3 +Returns the packed sockaddr address of this end of the SOCKET connection. +.nf + +.ne 4 + # An internet sockaddr + $sockaddr = 'S n a4 x8'; + $mysockaddr = getsockname(S); +.ie t \{\ + ($family, $port, $myaddr) = unpack($sockaddr,$mysockaddr); +'br\} +.el \{\ + ($family, $port, $myaddr) = + unpack($sockaddr,$mysockaddr); +'br\} + +.fi +.Ip "getsockopt(SOCKET,LEVEL,OPTNAME)" 8 3 +Returns the socket option requested, or undefined if there is an error. +.Ip "gmtime(EXPR)" 8 4 +.Ip "gmtime EXPR" 8 +Converts a time as returned by the time function to a 9-element array with +the time analyzed for the Greenwich timezone. +Typically used as follows: +.nf + +.ne 3 +.ie t \{\ + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); +'br\} +.el \{\ + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = + gmtime(time); +'br\} + +.fi +All array elements are numeric, and come straight out of a struct tm. +In particular this means that $mon has the range 0.\|.11 and $wday has the +range 0.\|.6. +If EXPR is omitted, does gmtime(time). +.Ip "goto LABEL" 8 6 +Finds the statement labeled with LABEL and resumes execution there. +Currently you may only go to statements in the main body of the program +that are not nested inside a do {} construct. +This statement is not implemented very efficiently, and is here only to make +the +.IR sed -to- perl +translator easier. +I may change its semantics at any time, consistent with support for translated +.I sed +scripts. +Use it at your own risk. +Better yet, don't use it at all. +.Ip "grep(EXPR,LIST)" 8 4 +Evaluates EXPR for each element of LIST (locally setting $_ to each element) +and returns the array value consisting of those elements for which the +expression evaluated to true. +In a scalar context, returns the number of times the expression was true. +.nf + + @foo = grep(!/^#/, @bar); # weed out comments + +.fi +Note that, since $_ is a reference into the array value, it can be +used to modify the elements of the array. +While this is useful and supported, it can cause bizarre results if +the LIST is not a named array. +.Ip "hex(EXPR)" 8 4 +.Ip "hex EXPR" 8 +Returns the decimal value of EXPR interpreted as an hex string. +(To interpret strings that might start with 0 or 0x see oct().) +If EXPR is omitted, uses $_. +.Ip "index(STR,SUBSTR,POSITION)" 8 4 +.Ip "index(STR,SUBSTR)" 8 4 +Returns the position of the first occurrence of SUBSTR in STR at or after +POSITION. +If POSITION is omitted, starts searching from the beginning of the string. +The return value is based at 0, or whatever you've +set the $[ variable to. +If the substring is not found, returns one less than the base, ordinarily \-1. +.Ip "int(EXPR)" 8 4 +.Ip "int EXPR" 8 +Returns the integer portion of EXPR. +If EXPR is omitted, uses $_. +.Ip "ioctl(FILEHANDLE,FUNCTION,SCALAR)" 8 4 +Implements the ioctl(2) function. +You'll probably have to say +.nf + + require "ioctl.ph"; # probably /usr/local/lib/perl/ioctl.ph + +.fi +first to get the correct function definitions. +If ioctl.ph doesn't exist or doesn't have the correct definitions +you'll have to roll +your own, based on your C header files such as . +(There is a perl script called h2ph that comes with the perl kit +which may help you in this.) +SCALAR will be read and/or written depending on the FUNCTION\*(--a pointer +to the string value of SCALAR will be passed as the third argument of +the actual ioctl call. +(If SCALAR has no string value but does have a numeric value, that value +will be passed rather than a pointer to the string value. +To guarantee this to be true, add a 0 to the scalar before using it.) +The pack() and unpack() functions are useful for manipulating the values +of structures used by ioctl(). +The following example sets the erase character to DEL. +.nf + +.ne 9 + require 'ioctl.ph'; + $sgttyb_t = "ccccs"; # 4 chars and a short + if (ioctl(STDIN,$TIOCGETP,$sgttyb)) { + @ary = unpack($sgttyb_t,$sgttyb); + $ary[2] = 127; + $sgttyb = pack($sgttyb_t,@ary); + ioctl(STDIN,$TIOCSETP,$sgttyb) + || die "Can't ioctl: $!"; + } + +.fi +The return value of ioctl (and fcntl) is as follows: +.nf + +.ne 4 + if OS returns:\h'|3i'perl returns: + -1\h'|3i' undefined value + 0\h'|3i' string "0 but true" + anything else\h'|3i' that number + +.fi +Thus perl returns true on success and false on failure, yet you can still +easily determine the actual value returned by the operating system: +.nf + + ($retval = ioctl(...)) || ($retval = -1); + printf "System returned %d\en", $retval; +.fi +.Ip "join(EXPR,LIST)" 8 8 +.Ip "join(EXPR,ARRAY)" 8 +Joins the separate strings of LIST or ARRAY into a single string with fields +separated by the value of EXPR, and returns the string. +Example: +.nf + +.ie t \{\ + $_ = join(\|\':\', $login,$passwd,$uid,$gid,$gcos,$home,$shell); +'br\} +.el \{\ + $_ = join(\|\':\', + $login,$passwd,$uid,$gid,$gcos,$home,$shell); +'br\} + +.fi +See +.IR split . +.Ip "keys(ASSOC_ARRAY)" 8 6 +.Ip "keys ASSOC_ARRAY" 8 +Returns a normal array consisting of all the keys of the named associative +array. +The keys are returned in an apparently random order, but it is the same order +as either the values() or each() function produces (given that the associative array +has not been modified). +Here is yet another way to print your environment: +.nf + +.ne 5 + @keys = keys %ENV; + @values = values %ENV; + while ($#keys >= 0) { + print pop(@keys), \'=\', pop(@values), "\en"; + } + +or how about sorted by key: + +.ne 3 + foreach $key (sort(keys %ENV)) { + print $key, \'=\', $ENV{$key}, "\en"; + } + +.fi +.Ip "kill(LIST)" 8 8 +.Ip "kill LIST" 8 2 +Sends a signal to a list of processes. +The first element of the list must be the signal to send. +Returns the number of processes successfully signaled. +.nf + + $cnt = kill 1, $child1, $child2; + kill 9, @goners; + +.fi +If the signal is negative, kills process groups instead of processes. +(On System V, a negative \fIprocess\fR number will also kill process groups, +but that's not portable.) +You may use a signal name in quotes. +.Ip "last LABEL" 8 8 +.Ip "last" 8 +The +.I last +command is like the +.I break +statement in C (as used in loops); it immediately exits the loop in question. +If the LABEL is omitted, the command refers to the innermost enclosing loop. +The +.I continue +block, if any, is not executed: +.nf + +.ne 4 + line: while () { + last line if /\|^$/; # exit when done with header + .\|.\|. + } + +.fi +.Ip "length(EXPR)" 8 4 +.Ip "length EXPR" 8 +Returns the length in characters of the value of EXPR. +If EXPR is omitted, returns length of $_. +.Ip "link(OLDFILE,NEWFILE)" 8 2 +Creates a new filename linked to the old filename. +Returns 1 for success, 0 otherwise. +.Ip "listen(SOCKET,QUEUESIZE)" 8 2 +Does the same thing that the listen system call does. +Returns true if it succeeded, false otherwise. +See example in section on Interprocess Communication. +.Ip "local(LIST)" 8 4 +Declares the listed variables to be local to the enclosing block, +subroutine, eval or \*(L"do\*(R". +All the listed elements must be legal lvalues. +This operator works by saving the current values of those variables in LIST +on a hidden stack and restoring them upon exiting the block, subroutine or eval. +This means that called subroutines can also reference the local variable, +but not the global one. +The LIST may be assigned to if desired, which allows you to initialize +your local variables. +(If no initializer is given for a particular variable, it is created with +an undefined value.) +Commonly this is used to name the parameters to a subroutine. +Examples: +.nf + +.ne 13 + sub RANGEVAL { + local($min, $max, $thunk) = @_; + local($result) = \'\'; + local($i); + + # Presumably $thunk makes reference to $i + + for ($i = $min; $i < $max; $i++) { + $result .= eval $thunk; + } + + $result; + } + +.ne 6 + if ($sw eq \'-v\') { + # init local array with global array + local(@ARGV) = @ARGV; + unshift(@ARGV,\'echo\'); + system @ARGV; + } + # @ARGV restored + +.ne 6 + # temporarily add to digits associative array + if ($base12) { + # (NOTE: not claiming this is efficient!) + local(%digits) = (%digits,'t',10,'e',11); + do parse_num(); + } + +.fi +Note that local() is a run-time command, and so gets executed every time +through a loop, using up more stack storage each time until it's all +released at once when the loop is exited. +.Ip "localtime(EXPR)" 8 4 +.Ip "localtime EXPR" 8 +Converts a time as returned by the time function to a 9-element array with +the time analyzed for the local timezone. +Typically used as follows: +.nf + +.ne 3 +.ie t \{\ + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); +'br\} +.el \{\ + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = + localtime(time); +'br\} + +.fi +All array elements are numeric, and come straight out of a struct tm. +In particular this means that $mon has the range 0.\|.11 and $wday has the +range 0.\|.6. +If EXPR is omitted, does localtime(time). +.Ip "log(EXPR)" 8 4 +.Ip "log EXPR" 8 +Returns logarithm (base +.IR e ) +of EXPR. +If EXPR is omitted, returns log of $_. +.Ip "lstat(FILEHANDLE)" 8 6 +.Ip "lstat FILEHANDLE" 8 +.Ip "lstat(EXPR)" 8 +.Ip "lstat SCALARVARIABLE" 8 +Does the same thing as the stat() function, but stats a symbolic link +instead of the file the symbolic link points to. +If symbolic links are unimplemented on your system, a normal stat is done. +.Ip "m/PATTERN/gio" 8 4 +.Ip "/PATTERN/gio" 8 +Searches a string for a pattern match, and returns true (1) or false (\'\'). +If no string is specified via the =~ or !~ operator, +the $_ string is searched. +(The string specified with =~ need not be an lvalue\*(--it may be the result of an expression evaluation, but remember the =~ binds rather tightly.) +See also the section on regular expressions. +.Sp +If / is the delimiter then the initial \*(L'm\*(R' is optional. +With the \*(L'm\*(R' you can use any pair of non-alphanumeric characters +as delimiters. +This is particularly useful for matching Unix path names that contain \*(L'/\*(R'. +If the final delimiter is followed by the optional letter \*(L'i\*(R', the matching is +done in a case-insensitive manner. +PATTERN may contain references to scalar variables, which will be interpolated +(and the pattern recompiled) every time the pattern search is evaluated. +(Note that $) and $| may not be interpolated because they look like end-of-string tests.) +If you want such a pattern to be compiled only once, add an \*(L"o\*(R" after +the trailing delimiter. +This avoids expensive run-time recompilations, and +is useful when the value you are interpolating won't change over the +life of the script. +If the PATTERN evaluates to a null string, the most recent successful +regular expression is used instead. +.Sp +If used in a context that requires an array value, a pattern match returns an +array consisting of the subexpressions matched by the parentheses in the +pattern, +i.e. ($1, $2, $3.\|.\|.). +It does NOT actually set $1, $2, etc. in this case, nor does it set $+, $`, $& +or $'. +If the match fails, a null array is returned. +If the match succeeds, but there were no parentheses, an array value of (1) +is returned. +.Sp +Examples: +.nf + +.ne 4 + open(tty, \'/dev/tty\'); + \|=~ \|/\|^y\|/i \|&& \|do foo(\|); # do foo if desired + + if (/Version: \|*\|([0\-9.]*\|)\|/\|) { $version = $1; } + + next if m#^/usr/spool/uucp#; + +.ne 5 + # poor man's grep + $arg = shift; + while (<>) { + print if /$arg/o; # compile only once + } + + if (($F1, $F2, $Etc) = ($foo =~ /^(\eS+)\es+(\eS+)\es*(.*)/)) + +.fi +This last example splits $foo into the first two words and the remainder +of the line, and assigns those three fields to $F1, $F2 and $Etc. +The conditional is true if any variables were assigned, i.e. if the pattern +matched. +.Sp +The \*(L"g\*(R" modifier specifies global pattern matching\*(--that is, +matching as many times as possible within the string. How it behaves +depends on the context. In an array context, it returns a list of +all the substrings matched by all the parentheses in the regular expression. +If there are no parentheses, it returns a list of all the matched strings, +as if there were parentheses around the whole pattern. In a scalar context, +it iterates through the string, returning TRUE each time it matches, and +FALSE when it eventually runs out of matches. (In other words, it remembers +where it left off last time and restarts the search at that point.) It +presumes that you have not modified the string since the last match. +Modifying the string between matches may result in undefined behavior. +(You can actually get away with in-place modifications via substr() +that do not change the length of the entire string. In general, however, +you should be using s///g for such modifications.) Examples: +.nf + + # array context + ($one,$five,$fifteen) = (\`uptime\` =~ /(\ed+\e.\ed+)/g); + + # scalar context + $/ = ""; $* = 1; + while ($paragraph = <>) { + while ($paragraph =~ /[a-z][\'")]*[.!?]+[\'")]*\es/g) { + $sentences++; + } + } + print "$sentences\en"; + +.fi +.Ip "mkdir(FILENAME,MODE)" 8 3 +Creates the directory specified by FILENAME, with permissions specified by +MODE (as modified by umask). +If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). +.Ip "msgctl(ID,CMD,ARG)" 8 4 +Calls the System V IPC function msgctl. If CMD is &IPC_STAT, then ARG +must be a variable which will hold the returned msqid_ds structure. +Returns like ioctl: the undefined value for error, "0 but true" for +zero, or the actual return value otherwise. +.Ip "msgget(KEY,FLAGS)" 8 4 +Calls the System V IPC function msgget. Returns the message queue id, +or the undefined value if there is an error. +.Ip "msgsnd(ID,MSG,FLAGS)" 8 4 +Calls the System V IPC function msgsnd to send the message MSG to the +message queue ID. MSG must begin with the long integer message type, +which may be created with pack("L", $type). Returns true if +successful, or false if there is an error. +.Ip "msgrcv(ID,VAR,SIZE,TYPE,FLAGS)" 8 4 +Calls the System V IPC function msgrcv to receive a message from +message queue ID into variable VAR with a maximum message size of +SIZE. Note that if a message is received, the message type will be +the first thing in VAR, and the maximum length of VAR is SIZE plus the +size of the message type. Returns true if successful, or false if +there is an error. +.Ip "next LABEL" 8 8 +.Ip "next" 8 +The +.I next +command is like the +.I continue +statement in C; it starts the next iteration of the loop: +.nf + +.ne 4 + line: while () { + next line if /\|^#/; # discard comments + .\|.\|. + } + +.fi +Note that if there were a +.I continue +block on the above, it would get executed even on discarded lines. +If the LABEL is omitted, the command refers to the innermost enclosing loop. +.Ip "oct(EXPR)" 8 4 +.Ip "oct EXPR" 8 +Returns the decimal value of EXPR interpreted as an octal string. +(If EXPR happens to start off with 0x, interprets it as a hex string instead.) +The following will handle decimal, octal and hex in the standard notation: +.nf + + $val = oct($val) if $val =~ /^0/; + +.fi +If EXPR is omitted, uses $_. +.Ip "open(FILEHANDLE,EXPR)" 8 8 +.Ip "open(FILEHANDLE)" 8 +.Ip "open FILEHANDLE" 8 +Opens the file whose filename is given by EXPR, and associates it with +FILEHANDLE. +If FILEHANDLE is an expression, its value is used as the name of the +real filehandle wanted. +If EXPR is omitted, the scalar variable of the same name as the FILEHANDLE +contains the filename. +If the filename begins with \*(L"<\*(R" or nothing, the file is opened for +input. +If the filename begins with \*(L">\*(R", the file is opened for output. +If the filename begins with \*(L">>\*(R", the file is opened for appending. +(You can put a \'+\' in front of the \'>\' or \'<\' to indicate that you +want both read and write access to the file.) +If the filename begins with \*(L"|\*(R", the filename is interpreted +as a command to which output is to be piped, and if the filename ends +with a \*(L"|\*(R", the filename is interpreted as command which pipes +input to us. +(You may not have a command that pipes both in and out.) +Opening \'\-\' opens +.I STDIN +and opening \'>\-\' opens +.IR STDOUT . +Open returns non-zero upon success, the undefined value otherwise. +If the open involved a pipe, the return value happens to be the pid +of the subprocess. +Examples: +.nf + +.ne 3 + $article = 100; + open article || die "Can't find article $article: $!\en"; + while (
) {\|.\|.\|. + +.ie t \{\ + open(LOG, \'>>/usr/spool/news/twitlog\'\|); # (log is reserved) +'br\} +.el \{\ + open(LOG, \'>>/usr/spool/news/twitlog\'\|); + # (log is reserved) +'br\} + +.ie t \{\ + open(article, "caesar <$article |"\|); # decrypt article +'br\} +.el \{\ + open(article, "caesar <$article |"\|); + # decrypt article +'br\} + +.ie t \{\ + open(extract, "|sort >/tmp/Tmp$$"\|); # $$ is our process# +'br\} +.el \{\ + open(extract, "|sort >/tmp/Tmp$$"\|); + # $$ is our process# +'br\} + +.ne 7 + # process argument list of files along with any includes + + foreach $file (@ARGV) { + do process($file, \'fh00\'); # no pun intended + } + + sub process { + local($filename, $input) = @_; + $input++; # this is a string increment + unless (open($input, $filename)) { + print STDERR "Can't open $filename: $!\en"; + return; + } +.ie t \{\ + while (<$input>) { # note the use of indirection +'br\} +.el \{\ + while (<$input>) { # note use of indirection +'br\} + if (/^#include "(.*)"/) { + do process($1, $input); + next; + } + .\|.\|. # whatever + } + } + +.fi +You may also, in the Bourne shell tradition, specify an EXPR beginning +with \*(L">&\*(R", in which case the rest of the string +is interpreted as the name of a filehandle +(or file descriptor, if numeric) which is to be duped and opened. +You may use & after >, >>, <, +>, +>> and +<. +The mode you specify should match the mode of the original filehandle. +Here is a script that saves, redirects, and restores +.I STDOUT +and +.IR STDERR : +.nf + +.ne 21 + #!/usr/bin/perl + open(SAVEOUT, ">&STDOUT"); + open(SAVEERR, ">&STDERR"); + + open(STDOUT, ">foo.out") || die "Can't redirect stdout"; + open(STDERR, ">&STDOUT") || die "Can't dup stdout"; + + select(STDERR); $| = 1; # make unbuffered + select(STDOUT); $| = 1; # make unbuffered + + print STDOUT "stdout 1\en"; # this works for + print STDERR "stderr 1\en"; # subprocesses too + + close(STDOUT); + close(STDERR); + + open(STDOUT, ">&SAVEOUT"); + open(STDERR, ">&SAVEERR"); + + print STDOUT "stdout 2\en"; + print STDERR "stderr 2\en"; + +.fi +If you open a pipe on the command \*(L"\-\*(R", i.e. either \*(L"|\-\*(R" or \*(L"\-|\*(R", +then there is an implicit fork done, and the return value of open +is the pid of the child within the parent process, and 0 within the child +process. +(Use defined($pid) to determine if the open was successful.) +The filehandle behaves normally for the parent, but i/o to that +filehandle is piped from/to the +.IR STDOUT / STDIN +of the child process. +In the child process the filehandle isn't opened\*(--i/o happens from/to +the new +.I STDOUT +or +.IR STDIN . +Typically this is used like the normal piped open when you want to exercise +more control over just how the pipe command gets executed, such as when +you are running setuid, and don't want to have to scan shell commands +for metacharacters. +The following pairs are more or less equivalent: +.nf + +.ne 5 + open(FOO, "|tr \'[a\-z]\' \'[A\-Z]\'"); + open(FOO, "|\-") || exec \'tr\', \'[a\-z]\', \'[A\-Z]\'; + + open(FOO, "cat \-n '$file'|"); + open(FOO, "\-|") || exec \'cat\', \'\-n\', $file; + +.fi +Explicitly closing any piped filehandle causes the parent process to wait for the +child to finish, and returns the status value in $?. +Note: on any operation which may do a fork, +unflushed buffers remain unflushed in both +processes, which means you may need to set $| to +avoid duplicate output. +.Sp +The filename that is passed to open will have leading and trailing +whitespace deleted. +In order to open a file with arbitrary weird characters in it, it's necessary +to protect any leading and trailing whitespace thusly: +.nf + +.ne 2 + $file =~ s#^(\es)#./$1#; + open(FOO, "< $file\e0"); + +.fi +.Ip "opendir(DIRHANDLE,EXPR)" 8 3 +Opens a directory named EXPR for processing by readdir(), telldir(), seekdir(), +rewinddir() and closedir(). +Returns true if successful. +DIRHANDLEs have their own namespace separate from FILEHANDLEs. +.Ip "ord(EXPR)" 8 4 +.Ip "ord EXPR" 8 +Returns the numeric ascii value of the first character of EXPR. +If EXPR is omitted, uses $_. +''' Comments on f & d by gnb@melba.bby.oz.au 22/11/89 +.Ip "pack(TEMPLATE,LIST)" 8 4 +Takes an array or list of values and packs it into a binary structure, +returning the string containing the structure. +The TEMPLATE is a sequence of characters that give the order and type +of values, as follows: +.nf + + A An ascii string, will be space padded. + a An ascii string, will be null padded. + c A signed char value. + C An unsigned char value. + s A signed short value. + S An unsigned short value. + i A signed integer value. + I An unsigned integer value. + l A signed long value. + L An unsigned long value. + n A short in \*(L"network\*(R" order. + N A long in \*(L"network\*(R" order. + f A single-precision float in the native format. + d A double-precision float in the native format. + p A pointer to a string. + v A short in \*(L"VAX\*(R" (little-endian) order. + V A long in \*(L"VAX\*(R" (little-endian) order. + x A null byte. + X Back up a byte. + @ Null fill to absolute position. + u A uuencoded string. + b A bit string (ascending bit order, like vec()). + B A bit string (descending bit order). + h A hex string (low nybble first). + H A hex string (high nybble first). + +.fi +Each letter may optionally be followed by a number which gives a repeat +count. +With all types except "a", "A", "b", "B", "h" and "H", +the pack function will gobble up that many values +from the LIST. +A * for the repeat count means to use however many items are left. +The "a" and "A" types gobble just one value, but pack it as a string of length +count, +padding with nulls or spaces as necessary. +(When unpacking, "A" strips trailing spaces and nulls, but "a" does not.) +Likewise, the "b" and "B" fields pack a string that many bits long. +The "h" and "H" fields pack a string that many nybbles long. +Real numbers (floats and doubles) are in the native machine format +only; due to the multiplicity of floating formats around, and the lack +of a standard \*(L"network\*(R" representation, no facility for +interchange has been made. +This means that packed floating point data +written on one machine may not be readable on another - even if both +use IEEE floating point arithmetic (as the endian-ness of the memory +representation is not part of the IEEE spec). +Note that perl uses +doubles internally for all numeric calculation, and converting from +double -> float -> double will lose precision (i.e. unpack("f", +pack("f", $foo)) will not in general equal $foo). +.br +Examples: +.nf + + $foo = pack("cccc",65,66,67,68); + # foo eq "ABCD" + $foo = pack("c4",65,66,67,68); + # same thing + + $foo = pack("ccxxcc",65,66,67,68); + # foo eq "AB\e0\e0CD" + + $foo = pack("s2",1,2); + # "\e1\e0\e2\e0" on little-endian + # "\e0\e1\e0\e2" on big-endian + + $foo = pack("a4","abcd","x","y","z"); + # "abcd" + + $foo = pack("aaaa","abcd","x","y","z"); + # "axyz" + + $foo = pack("a14","abcdefg"); + # "abcdefg\e0\e0\e0\e0\e0\e0\e0" + + $foo = pack("i9pl", gmtime); + # a real struct tm (on my system anyway) + + sub bintodec { + unpack("N", pack("B32", substr("0" x 32 . shift, -32))); + } +.fi +The same template may generally also be used in the unpack function. +.Ip "pipe(READHANDLE,WRITEHANDLE)" 8 3 +Opens a pair of connected pipes like the corresponding system call. +Note that if you set up a loop of piped processes, deadlock can occur +unless you are very careful. +In addition, note that perl's pipes use stdio buffering, so you may need +to set $| to flush your WRITEHANDLE after each command, depending on +the application. +[Requires version 3.0 patchlevel 9.] +.Ip "pop(ARRAY)" 8 +.Ip "pop ARRAY" 8 6 +Pops and returns the last value of the array, shortening the array by 1. +Has the same effect as +.nf + + $tmp = $ARRAY[$#ARRAY\-\|\-]; + +.fi +If there are no elements in the array, returns the undefined value. +.Ip "print(FILEHANDLE LIST)" 8 10 +.Ip "print(LIST)" 8 +.Ip "print FILEHANDLE LIST" 8 +.Ip "print LIST" 8 +.Ip "print" 8 +Prints a string or a comma-separated list of strings. +Returns non-zero if successful. +FILEHANDLE may be a scalar variable name, in which case the variable contains +the name of the filehandle, thus introducing one level of indirection. +(NOTE: If FILEHANDLE is a variable and the next token is a term, it may be +misinterpreted as an operator unless you interpose a + or put parens around +the arguments.) +If FILEHANDLE is omitted, prints by default to standard output (or to the +last selected output channel\*(--see select()). +If LIST is also omitted, prints $_ to +.IR STDOUT . +To set the default output channel to something other than +.I STDOUT +use the select operation. +Note that, because print takes a LIST, anything in the LIST is evaluated +in an array context, and any subroutine that you call will have one or more +of its expressions evaluated in an array context. +Also be careful not to follow the print keyword with a left parenthesis +unless you want the corresponding right parenthesis to terminate the +arguments to the print\*(--interpose a + or put parens around all the arguments. +.Ip "printf(FILEHANDLE LIST)" 8 10 +.Ip "printf(LIST)" 8 +.Ip "printf FILEHANDLE LIST" 8 +.Ip "printf LIST" 8 +Equivalent to a \*(L"print FILEHANDLE sprintf(LIST)\*(R". +.Ip "push(ARRAY,LIST)" 8 7 +Treats ARRAY (@ is optional) as a stack, and pushes the values of LIST +onto the end of ARRAY. +The length of ARRAY increases by the length of LIST. +Has the same effect as +.nf + + for $value (LIST) { + $ARRAY[++$#ARRAY] = $value; + } + +.fi +but is more efficient. +.Ip "q/STRING/" 8 5 +.Ip "qq/STRING/" 8 +.Ip "qx/STRING/" 8 +These are not really functions, but simply syntactic sugar to let you +avoid putting too many backslashes into quoted strings. +The q operator is a generalized single quote, and the qq operator a +generalized double quote. +The qx operator is a generalized backquote. +Any non-alphanumeric delimiter can be used in place of /, including newline. +If the delimiter is an opening bracket or parenthesis, the final delimiter +will be the corresponding closing bracket or parenthesis. +(Embedded occurrences of the closing bracket need to be backslashed as usual.) +Examples: +.nf + +.ne 5 + $foo = q!I said, "You said, \'She said it.\'"!; + $bar = q(\'This is it.\'); + $today = qx{ date }; + $_ .= qq +*** The previous line contains the naughty word "$&".\en + if /(ibm|apple|awk)/; # :-) + +.fi +.Ip "rand(EXPR)" 8 8 +.Ip "rand EXPR" 8 +.Ip "rand" 8 +Returns a random fractional number between 0 and the value of EXPR. +(EXPR should be positive.) +If EXPR is omitted, returns a value between 0 and 1. +See also srand(). +.Ip "read(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5 +.Ip "read(FILEHANDLE,SCALAR,LENGTH)" 8 5 +Attempts to read LENGTH bytes of data into variable SCALAR from the specified +FILEHANDLE. +Returns the number of bytes actually read, or undef if there was an error. +SCALAR will be grown or shrunk to the length actually read. +An OFFSET may be specified to place the read data at some other place +than the beginning of the string. +This call is actually implemented in terms of stdio's fread call. To get +a true read system call, see sysread. +.Ip "readdir(DIRHANDLE)" 8 3 +.Ip "readdir DIRHANDLE" 8 +Returns the next directory entry for a directory opened by opendir(). +If used in an array context, returns all the rest of the entries in the +directory. +If there are no more entries, returns an undefined value in a scalar context +or a null list in an array context. +.Ip "readlink(EXPR)" 8 6 +.Ip "readlink EXPR" 8 +Returns the value of a symbolic link, if symbolic links are implemented. +If not, gives a fatal error. +If there is some system error, returns the undefined value and sets $! (errno). +If EXPR is omitted, uses $_. +.Ip "recv(SOCKET,SCALAR,LEN,FLAGS)" 8 4 +Receives a message on a socket. +Attempts to receive LENGTH bytes of data into variable SCALAR from the specified +SOCKET filehandle. +Returns the address of the sender, or the undefined value if there's an error. +SCALAR will be grown or shrunk to the length actually read. +Takes the same flags as the system call of the same name. +.Ip "redo LABEL" 8 8 +.Ip "redo" 8 +The +.I redo +command restarts the loop block without evaluating the conditional again. +The +.I continue +block, if any, is not executed. +If the LABEL is omitted, the command refers to the innermost enclosing loop. +This command is normally used by programs that want to lie to themselves +about what was just input: +.nf + +.ne 16 + # a simpleminded Pascal comment stripper + # (warning: assumes no { or } in strings) + line: while () { + while (s|\|({.*}.*\|){.*}|$1 \||) {} + s|{.*}| \||; + if (s|{.*| \||) { + $front = $_; + while () { + if (\|/\|}/\|) { # end of comment? + s|^|$front{|; + redo line; + } + } + } + print; + } + +.fi +.Ip "rename(OLDNAME,NEWNAME)" 8 2 +Changes the name of a file. +Returns 1 for success, 0 otherwise. +Will not work across filesystem boundaries. +.Ip "require(EXPR)" 8 6 +.Ip "require EXPR" 8 +.Ip "require" 8 +Includes the library file specified by EXPR, or by $_ if EXPR is not supplied. +Has semantics similar to the following subroutine: +.nf + + sub require { + local($filename) = @_; + return 1 if $INC{$filename}; + local($realfilename,$result); + ITER: { + foreach $prefix (@INC) { + $realfilename = "$prefix/$filename"; + if (-f $realfilename) { + $result = do $realfilename; + last ITER; + } + } + die "Can't find $filename in \e@INC"; + } + die $@ if $@; + die "$filename did not return true value" unless $result; + $INC{$filename} = $realfilename; + $result; + } + +.fi +Note that the file will not be included twice under the same specified name. +The file must return true as the last statement to indicate successful +execution of any initialization code, so it's customary to end +such a file with \*(L"1;\*(R" unless you're sure it'll return true otherwise. +.Ip "reset(EXPR)" 8 6 +.Ip "reset EXPR" 8 +.Ip "reset" 8 +Generally used in a +.I continue +block at the end of a loop to clear variables and reset ?? searches +so that they work again. +The expression is interpreted as a list of single characters (hyphens allowed +for ranges). +All variables and arrays beginning with one of those letters are reset to +their pristine state. +If the expression is omitted, one-match searches (?pattern?) are reset to +match again. +Only resets variables or searches in the current package. +Always returns 1. +Examples: +.nf + +.ne 3 + reset \'X\'; \h'|2i'# reset all X variables + reset \'a\-z\';\h'|2i'# reset lower case variables + reset; \h'|2i'# just reset ?? searches + +.fi +Note: resetting \*(L"A\-Z\*(R" is not recommended since you'll wipe out your ARGV and ENV +arrays. +.Sp +The use of reset on dbm associative arrays does not change the dbm file. +(It does, however, flush any entries cached by perl, which may be useful if +you are sharing the dbm file. +Then again, maybe not.) +.Ip "return LIST" 8 3 +Returns from a subroutine with the value specified. +(Note that a subroutine can automatically return +the value of the last expression evaluated. +That's the preferred method\*(--use of an explicit +.I return +is a bit slower.) +.Ip "reverse(LIST)" 8 4 +.Ip "reverse LIST" 8 +In an array context, returns an array value consisting of the elements +of LIST in the opposite order. +In a scalar context, returns a string value consisting of the bytes of +the first element of LIST in the opposite order. +.Ip "rewinddir(DIRHANDLE)" 8 5 +.Ip "rewinddir DIRHANDLE" 8 +Sets the current position to the beginning of the directory for the readdir() routine on DIRHANDLE. +.Ip "rindex(STR,SUBSTR,POSITION)" 8 6 +.Ip "rindex(STR,SUBSTR)" 8 4 +Works just like index except that it +returns the position of the LAST occurrence of SUBSTR in STR. +If POSITION is specified, returns the last occurrence at or before that +position. +.Ip "rmdir(FILENAME)" 8 4 +.Ip "rmdir FILENAME" 8 +Deletes the directory specified by FILENAME if it is empty. +If it succeeds it returns 1, otherwise it returns 0 and sets $! (errno). +If FILENAME is omitted, uses $_. +.Ip "s/PATTERN/REPLACEMENT/gieo" 8 3 +Searches a string for a pattern, and if found, replaces that pattern with the +replacement text and returns the number of substitutions made. +Otherwise it returns false (0). +The \*(L"g\*(R" is optional, and if present, indicates that all occurrences +of the pattern are to be replaced. +The \*(L"i\*(R" is also optional, and if present, indicates that matching +is to be done in a case-insensitive manner. +The \*(L"e\*(R" is likewise optional, and if present, indicates that +the replacement string is to be evaluated as an expression rather than just +as a double-quoted string. +Any non-alphanumeric delimiter may replace the slashes; +if single quotes are used, no +interpretation is done on the replacement string (the e modifier overrides +this, however); if backquotes are used, the replacement string is a command +to execute whose output will be used as the actual replacement text. +If the PATTERN is delimited by bracketing quotes, the REPLACEMENT +has its own pair of quotes, which may or may not be bracketing quotes, e.g. +s(foo)(bar) or s/bar/. +If no string is specified via the =~ or !~ operator, +the $_ string is searched and modified. +(The string specified with =~ must be a scalar variable, an array element, +or an assignment to one of those, i.e. an lvalue.) +If the pattern contains a $ that looks like a variable rather than an +end-of-string test, the variable will be interpolated into the pattern at +run-time. +If you only want the pattern compiled once the first time the variable is +interpolated, add an \*(L"o\*(R" at the end. +If the PATTERN evaluates to a null string, the most recent successful +regular expression is used instead. +See also the section on regular expressions. +Examples: +.nf + + s/\|\e\|bgreen\e\|b/mauve/g; # don't change wintergreen + + $path \|=~ \|s|\|/usr/bin|\|/usr/local/bin|; + + s/Login: $foo/Login: $bar/; # run-time pattern + + ($foo = $bar) =~ s/bar/foo/; + + $_ = \'abc123xyz\'; + s/\ed+/$&*2/e; # yields \*(L'abc246xyz\*(R' + s/\ed+/sprintf("%5d",$&)/e; # yields \*(L'abc 246xyz\*(R' + s/\ew/$& x 2/eg; # yields \*(L'aabbcc 224466xxyyzz\*(R' + + s/\|([^ \|]*\|) *\|([^ \|]*\|)\|/\|$2 $1/; # reverse 1st two fields + +.fi +(Note the use of $ instead of \|\e\| in the last example. See section +on regular expressions.) +.Ip "scalar(EXPR)" 8 3 +Forces EXPR to be interpreted in a scalar context and returns the value +of EXPR. +.Ip "seek(FILEHANDLE,POSITION,WHENCE)" 8 3 +Randomly positions the file pointer for FILEHANDLE, just like the fseek() +call of stdio. +FILEHANDLE may be an expression whose value gives the name of the filehandle. +Returns 1 upon success, 0 otherwise. +.Ip "seekdir(DIRHANDLE,POS)" 8 3 +Sets the current position for the readdir() routine on DIRHANDLE. +POS must be a value returned by telldir(). +Has the same caveats about possible directory compaction as the corresponding +system library routine. +.Ip "select(FILEHANDLE)" 8 3 +.Ip "select" 8 3 +Returns the currently selected filehandle. +Sets the current default filehandle for output, if FILEHANDLE is supplied. +This has two effects: first, a +.I write +or a +.I print +without a filehandle will default to this FILEHANDLE. +Second, references to variables related to output will refer to this output +channel. +For example, if you have to set the top of form format for more than +one output channel, you might do the following: +.nf + +.ne 4 + select(REPORT1); + $^ = \'report1_top\'; + select(REPORT2); + $^ = \'report2_top\'; + +.fi +FILEHANDLE may be an expression whose value gives the name of the actual filehandle. +Thus: +.nf + + $oldfh = select(STDERR); $| = 1; select($oldfh); + +.fi +.Ip "select(RBITS,WBITS,EBITS,TIMEOUT)" 8 3 +This calls the select system call with the bitmasks specified, which can +be constructed using fileno() and vec(), along these lines: +.nf + + $rin = $win = $ein = ''; + vec($rin,fileno(STDIN),1) = 1; + vec($win,fileno(STDOUT),1) = 1; + $ein = $rin | $win; + +.fi +If you want to select on many filehandles you might wish to write a subroutine: +.nf + + sub fhbits { + local(@fhlist) = split(' ',$_[0]); + local($bits); + for (@fhlist) { + vec($bits,fileno($_),1) = 1; + } + $bits; + } + $rin = &fhbits('STDIN TTY SOCK'); + +.fi +The usual idiom is: +.nf + + ($nfound,$timeleft) = + select($rout=$rin, $wout=$win, $eout=$ein, $timeout); + +or to block until something becomes ready: + +.ie t \{\ + $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef); +'br\} +.el \{\ + $nfound = select($rout=$rin, $wout=$win, + $eout=$ein, undef); +'br\} + +.fi +Any of the bitmasks can also be undef. +The timeout, if specified, is in seconds, which may be fractional. +NOTE: not all implementations are capable of returning the $timeleft. +If not, they always return $timeleft equal to the supplied $timeout. +.Ip "semctl(ID,SEMNUM,CMD,ARG)" 8 4 +Calls the System V IPC function semctl. If CMD is &IPC_STAT or +&GETALL, then ARG must be a variable which will hold the returned +semid_ds structure or semaphore value array. Returns like ioctl: the +undefined value for error, "0 but true" for zero, or the actual return +value otherwise. +.Ip "semget(KEY,NSEMS,SIZE,FLAGS)" 8 4 +Calls the System V IPC function semget. Returns the semaphore id, or +the undefined value if there is an error. +.Ip "semop(KEY,OPSTRING)" 8 4 +Calls the System V IPC function semop to perform semaphore operations +such as signaling and waiting. OPSTRING must be a packed array of +semop structures. Each semop structure can be generated with +\&'pack("sss", $semnum, $semop, $semflag)'. The number of semaphore +operations is implied by the length of OPSTRING. Returns true if +successful, or false if there is an error. As an example, the +following code waits on semaphore $semnum of semaphore id $semid: +.nf + + $semop = pack("sss", $semnum, -1, 0); + die "Semaphore trouble: $!\en" unless semop($semid, $semop); + +.fi +To signal the semaphore, replace "-1" with "1". +.Ip "send(SOCKET,MSG,FLAGS,TO)" 8 4 +.Ip "send(SOCKET,MSG,FLAGS)" 8 +Sends a message on a socket. +Takes the same flags as the system call of the same name. +On unconnected sockets you must specify a destination to send TO. +Returns the number of characters sent, or the undefined value if +there is an error. +.Ip "setpgrp(PID,PGRP)" 8 4 +Sets the current process group for the specified PID, 0 for the current +process. +Will produce a fatal error if used on a machine that doesn't implement +setpgrp(2). +.Ip "setpriority(WHICH,WHO,PRIORITY)" 8 4 +Sets the current priority for a process, a process group, or a user. +(See setpriority(2).) +Will produce a fatal error if used on a machine that doesn't implement +setpriority(2). +.Ip "setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)" 8 3 +Sets the socket option requested. +Returns undefined if there is an error. +OPTVAL may be specified as undef if you don't want to pass an argument. +.Ip "shift(ARRAY)" 8 6 +.Ip "shift ARRAY" 8 +.Ip "shift" 8 +Shifts the first value of the array off and returns it, +shortening the array by 1 and moving everything down. +If there are no elements in the array, returns the undefined value. +If ARRAY is omitted, shifts the @ARGV array in the main program, and the @_ +array in subroutines. +(This is determined lexically.) +See also unshift(), push() and pop(). +Shift() and unshift() do the same thing to the left end of an array that push() +and pop() do to the right end. +.Ip "shmctl(ID,CMD,ARG)" 8 4 +Calls the System V IPC function shmctl. If CMD is &IPC_STAT, then ARG +must be a variable which will hold the returned shmid_ds structure. +Returns like ioctl: the undefined value for error, "0 but true" for +zero, or the actual return value otherwise. +.Ip "shmget(KEY,SIZE,FLAGS)" 8 4 +Calls the System V IPC function shmget. Returns the shared memory +segment id, or the undefined value if there is an error. +.Ip "shmread(ID,VAR,POS,SIZE)" 8 4 +.Ip "shmwrite(ID,STRING,POS,SIZE)" 8 +Reads or writes the System V shared memory segment ID starting at +position POS for size SIZE by attaching to it, copying in/out, and +detaching from it. When reading, VAR must be a variable which +will hold the data read. When writing, if STRING is too long, +only SIZE bytes are used; if STRING is too short, nulls are +written to fill out SIZE bytes. Return true if successful, or +false if there is an error. +.Ip "shutdown(SOCKET,HOW)" 8 3 +Shuts down a socket connection in the manner indicated by HOW, which has +the same interpretation as in the system call of the same name. +.Ip "sin(EXPR)" 8 4 +.Ip "sin EXPR" 8 +Returns the sine of EXPR (expressed in radians). +If EXPR is omitted, returns sine of $_. +.Ip "sleep(EXPR)" 8 6 +.Ip "sleep EXPR" 8 +.Ip "sleep" 8 +Causes the script to sleep for EXPR seconds, or forever if no EXPR. +May be interrupted by sending the process a SIGALRM. +Returns the number of seconds actually slept. +You probably cannot mix alarm() and sleep() calls, since sleep() is +often implemented using alarm(). +.Ip "socket(SOCKET,DOMAIN,TYPE,PROTOCOL)" 8 3 +Opens a socket of the specified kind and attaches it to filehandle SOCKET. +DOMAIN, TYPE and PROTOCOL are specified the same as for the system call +of the same name. +You may need to run h2ph on sys/socket.h to get the proper values handy +in a perl library file. +Return true if successful. +See the example in the section on Interprocess Communication. +.Ip "socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)" 8 3 +Creates an unnamed pair of sockets in the specified domain, of the specified +type. +DOMAIN, TYPE and PROTOCOL are specified the same as for the system call +of the same name. +If unimplemented, yields a fatal error. +Return true if successful. +.Ip "sort(SUBROUTINE LIST)" 8 9 +.Ip "sort(LIST)" 8 +.Ip "sort SUBROUTINE LIST" 8 +.Ip "sort BLOCK LIST" 8 +.Ip "sort LIST" 8 +Sorts the LIST and returns the sorted array value. +Nonexistent values of arrays are stripped out. +If SUBROUTINE or BLOCK is omitted, sorts in standard string comparison order. +If SUBROUTINE is specified, gives the name of a subroutine that returns +an integer less than, equal to, or greater than 0, +depending on how the elements of the array are to be ordered. +(The <=> and cmp operators are extremely useful in such routines.) +SUBROUTINE may be a scalar variable name, in which case the value provides +the name of the subroutine to use. +In place of a SUBROUTINE name, you can provide a BLOCK as an anonymous, +in-line sort subroutine. +.Sp +In the interests of efficiency the normal calling code for subroutines +is bypassed, with the following effects: the subroutine may not be a recursive +subroutine, and the two elements to be compared are passed into the subroutine +not via @_ but as $a and $b (see example below). +They are passed by reference so don't modify $a and $b. +.Sp +Examples: +.nf + +.ne 2 + # sort lexically + @articles = sort @files; + +.ne 2 + # same thing, but with explicit sort routine + @articles = sort {$a cmp $b} @files; + +.ne 2 + # same thing in reversed order + @articles = sort {$b cmp $a} @files; + +.ne 2 + # sort numerically ascending + @articles = sort {$a <=> $b} @files; + +.ne 2 + # sort numerically descending + @articles = sort {$b <=> $a} @files; + +.ne 5 + # sort using explicit subroutine name + sub byage { + $age{$a} <=> $age{$b}; # presuming integers + } + @sortedclass = sort byage @class; + +.ne 9 + sub reverse { $b cmp $a; } + @harry = (\'dog\',\'cat\',\'x\',\'Cain\',\'Abel\'); + @george = (\'gone\',\'chased\',\'yz\',\'Punished\',\'Axed\'); + print sort @harry; + # prints AbelCaincatdogx + print sort reverse @harry; + # prints xdogcatCainAbel + print sort @george, \'to\', @harry; + # prints AbelAxedCainPunishedcatchaseddoggonetoxyz + +.fi +.Ip "splice(ARRAY,OFFSET,LENGTH,LIST)" 8 8 +.Ip "splice(ARRAY,OFFSET,LENGTH)" 8 +.Ip "splice(ARRAY,OFFSET)" 8 +Removes the elements designated by OFFSET and LENGTH from an array, and +replaces them with the elements of LIST, if any. +Returns the elements removed from the array. +The array grows or shrinks as necessary. +If LENGTH is omitted, removes everything from OFFSET onward. +The following equivalencies hold (assuming $[ == 0): +.nf + + push(@a,$x,$y)\h'|3.5i'splice(@a,$#a+1,0,$x,$y) + pop(@a)\h'|3.5i'splice(@a,-1) + shift(@a)\h'|3.5i'splice(@a,0,1) + unshift(@a,$x,$y)\h'|3.5i'splice(@a,0,0,$x,$y) + $a[$x] = $y\h'|3.5i'splice(@a,$x,1,$y); + +Example, assuming array lengths are passed before arrays: + + sub aeq { # compare two array values + local(@a) = splice(@_,0,shift); + local(@b) = splice(@_,0,shift); + return 0 unless @a == @b; # same len? + while (@a) { + return 0 if pop(@a) ne pop(@b); + } + return 1; + } + if (&aeq($len,@foo[1..$len],0+@bar,@bar)) { ... } + +.fi +.Ip "split(/PATTERN/,EXPR,LIMIT)" 8 8 +.Ip "split(/PATTERN/,EXPR)" 8 8 +.Ip "split(/PATTERN/)" 8 +.Ip "split" 8 +Splits a string into an array of strings, and returns it. +(If not in an array context, returns the number of fields found and splits +into the @_ array. +(In an array context, you can force the split into @_ +by using ?? as the pattern delimiters, but it still returns the array value.)) +If EXPR is omitted, splits the $_ string. +If PATTERN is also omitted, splits on whitespace (/[\ \et\en]+/). +Anything matching PATTERN is taken to be a delimiter separating the fields. +(Note that the delimiter may be longer than one character.) +If LIMIT is specified, splits into no more than that many fields (though it +may split into fewer). +If LIMIT is unspecified, trailing null fields are stripped (which +potential users of pop() would do well to remember). +A pattern matching the null string (not to be confused with a null pattern //, +which is just one member of the set of patterns matching a null string) +will split the value of EXPR into separate characters at each point it +matches that way. +For example: +.nf + + print join(\':\', split(/ */, \'hi there\')); + +.fi +produces the output \*(L'h:i:t:h:e:r:e\*(R'. +.Sp +The LIMIT parameter can be used to partially split a line +.nf + + ($login, $passwd, $remainder) = split(\|/\|:\|/\|, $_, 3); + +.fi +(When assigning to a list, if LIMIT is omitted, perl supplies a LIMIT one +larger than the number of variables in the list, to avoid unnecessary work. +For the list above LIMIT would have been 4 by default. +In time critical applications it behooves you not to split into +more fields than you really need.) +.Sp +If the PATTERN contains parentheses, additional array elements are created +from each matching substring in the delimiter. +.Sp + split(/([,-])/,"1-10,20"); +.Sp +produces the array value +.Sp + (1,'-',10,',',20) +.Sp +The pattern /PATTERN/ may be replaced with an expression to specify patterns +that vary at runtime. +(To do runtime compilation only once, use /$variable/o.) +As a special case, specifying a space (\'\ \') will split on white space +just as split with no arguments does, but leading white space does NOT +produce a null first field. +Thus, split(\'\ \') can be used to emulate +.IR awk 's +default behavior, whereas +split(/\ /) will give you as many null initial fields as there are +leading spaces. +.Sp +Example: +.nf + +.ne 5 + open(passwd, \'/etc/passwd\'); + while () { +.ie t \{\ + ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(\|/\|:\|/\|); +'br\} +.el \{\ + ($login, $passwd, $uid, $gid, $gcos, $home, $shell) + = split(\|/\|:\|/\|); +'br\} + .\|.\|. + } + +.fi +(Note that $shell above will still have a newline on it. See chop().) +See also +.IR join . +.Ip "sprintf(FORMAT,LIST)" 8 4 +Returns a string formatted by the usual printf conventions. +The * character is not supported. +.Ip "sqrt(EXPR)" 8 4 +.Ip "sqrt EXPR" 8 +Return the square root of EXPR. +If EXPR is omitted, returns square root of $_. +.Ip "srand(EXPR)" 8 4 +.Ip "srand EXPR" 8 +Sets the random number seed for the +.I rand +operator. +If EXPR is omitted, does srand(time). +.Ip "stat(FILEHANDLE)" 8 8 +.Ip "stat FILEHANDLE" 8 +.Ip "stat(EXPR)" 8 +.Ip "stat SCALARVARIABLE" 8 +Returns a 13-element array giving the statistics for a file, either the file +opened via FILEHANDLE, or named by EXPR. +Returns a null list if the stat fails. +Typically used as follows: +.nf + +.ne 3 + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) + = stat($filename); + +.fi +If stat is passed the special filehandle consisting of an underline, +no stat is done, but the current contents of the stat structure from +the last stat or filetest are returned. +Example: +.nf + +.ne 3 + if (-x $file && (($d) = stat(_)) && $d < 0) { + print "$file is executable NFS file\en"; + } + +.fi +(This only works on machines for which the device number is negative under NFS.) +.Ip "study(SCALAR)" 8 6 +.Ip "study SCALAR" 8 +.Ip "study" +Takes extra time to study SCALAR ($_ if unspecified) in anticipation of +doing many pattern matches on the string before it is next modified. +This may or may not save time, depending on the nature and number of patterns +you are searching on, and on the distribution of character frequencies in +the string to be searched\*(--you probably want to compare runtimes with and +without it to see which runs faster. +Those loops which scan for many short constant strings (including the constant +parts of more complex patterns) will benefit most. +You may have only one study active at a time\*(--if you study a different +scalar the first is \*(L"unstudied\*(R". +(The way study works is this: a linked list of every character in the string +to be searched is made, so we know, for example, where all the \*(L'k\*(R' characters +are. +From each search string, the rarest character is selected, based on some +static frequency tables constructed from some C programs and English text. +Only those places that contain this \*(L"rarest\*(R" character are examined.) +.Sp +For example, here is a loop which inserts index producing entries before any line +containing a certain pattern: +.nf + +.ne 8 + while (<>) { + study; + print ".IX foo\en" if /\ebfoo\eb/; + print ".IX bar\en" if /\ebbar\eb/; + print ".IX blurfl\en" if /\ebblurfl\eb/; + .\|.\|. + print; + } + +.fi +In searching for /\ebfoo\eb/, only those locations in $_ that contain \*(L'f\*(R' +will be looked at, because \*(L'f\*(R' is rarer than \*(L'o\*(R'. +In general, this is a big win except in pathological cases. +The only question is whether it saves you more time than it took to build +the linked list in the first place. +.Sp +Note that if you have to look for strings that you don't know till runtime, +you can build an entire loop as a string and eval that to avoid recompiling +all your patterns all the time. +Together with undefining $/ to input entire files as one record, this can +be very fast, often faster than specialized programs like fgrep. +The following scans a list of files (@files) +for a list of words (@words), and prints out the names of those files that +contain a match: +.nf + +.ne 12 + $search = \'while (<>) { study;\'; + foreach $word (@words) { + $search .= "++\e$seen{\e$ARGV} if /\e\eb$word\e\eb/;\en"; + } + $search .= "}"; + @ARGV = @files; + undef $/; + eval $search; # this screams + $/ = "\en"; # put back to normal input delim + foreach $file (sort keys(%seen)) { + print $file, "\en"; + } + +.fi +.Ip "substr(EXPR,OFFSET,LEN)" 8 2 +.Ip "substr(EXPR,OFFSET)" 8 2 +Extracts a substring out of EXPR and returns it. +First character is at offset 0, or whatever you've set $[ to. +If OFFSET is negative, starts that far from the end of the string. +If LEN is omitted, returns everything to the end of the string. +You can use the substr() function as an lvalue, in which case EXPR must +be an lvalue. +If you assign something shorter than LEN, the string will shrink, and +if you assign something longer than LEN, the string will grow to accommodate it. +To keep the string the same length you may need to pad or chop your value using +sprintf(). +.Ip "symlink(OLDFILE,NEWFILE)" 8 2 +Creates a new filename symbolically linked to the old filename. +Returns 1 for success, 0 otherwise. +On systems that don't support symbolic links, produces a fatal error at +run time. +To check for that, use eval: +.nf + + $symlink_exists = (eval \'symlink("","");\', $@ eq \'\'); + +.fi +.Ip "syscall(LIST)" 8 6 +.Ip "syscall LIST" 8 +Calls the system call specified as the first element of the list, passing +the remaining elements as arguments to the system call. +If unimplemented, produces a fatal error. +The arguments are interpreted as follows: if a given argument is numeric, +the argument is passed as an int. +If not, the pointer to the string value is passed. +You are responsible to make sure a string is pre-extended long enough +to receive any result that might be written into a string. +If your integer arguments are not literals and have never been interpreted +in a numeric context, you may need to add 0 to them to force them to look +like numbers. +.nf + + require 'syscall.ph'; # may need to run h2ph + syscall(&SYS_write, fileno(STDOUT), "hi there\en", 9); + +.fi +.Ip "sysread(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5 +.Ip "sysread(FILEHANDLE,SCALAR,LENGTH)" 8 5 +Attempts to read LENGTH bytes of data into variable SCALAR from the specified +FILEHANDLE, using the system call read(2). +It bypasses stdio, so mixing this with other kinds of reads may cause +confusion. +Returns the number of bytes actually read, or undef if there was an error. +SCALAR will be grown or shrunk to the length actually read. +An OFFSET may be specified to place the read data at some other place +than the beginning of the string. +.Ip "system(LIST)" 8 6 +.Ip "system LIST" 8 +Does exactly the same thing as \*(L"exec LIST\*(R" except that a fork +is done first, and the parent process waits for the child process to complete. +Note that argument processing varies depending on the number of arguments. +The return value is the exit status of the program as returned by the wait() +call. +To get the actual exit value divide by 256. +See also +.IR exec . +.Ip "syswrite(FILEHANDLE,SCALAR,LENGTH,OFFSET)" 8 5 +.Ip "syswrite(FILEHANDLE,SCALAR,LENGTH)" 8 5 +Attempts to write LENGTH bytes of data from variable SCALAR to the specified +FILEHANDLE, using the system call write(2). +It bypasses stdio, so mixing this with prints may cause +confusion. +Returns the number of bytes actually written, or undef if there was an error. +An OFFSET may be specified to place the read data at some other place +than the beginning of the string. +.Ip "tell(FILEHANDLE)" 8 6 +.Ip "tell FILEHANDLE" 8 6 +.Ip "tell" 8 +Returns the current file position for FILEHANDLE. +FILEHANDLE may be an expression whose value gives the name of the actual +filehandle. +If FILEHANDLE is omitted, assumes the file last read. +.Ip "telldir(DIRHANDLE)" 8 5 +.Ip "telldir DIRHANDLE" 8 +Returns the current position of the readdir() routines on DIRHANDLE. +Value may be given to seekdir() to access a particular location in +a directory. +Has the same caveats about possible directory compaction as the corresponding +system library routine. +.Ip "time" 8 4 +Returns the number of non-leap seconds since 00:00:00 UTC, January 1, 1970. +Suitable for feeding to gmtime() and localtime(). +.Ip "times" 8 4 +Returns a four-element array giving the user and system times, in seconds, for this +process and the children of this process. +.Sp + ($user,$system,$cuser,$csystem) = times; +.Sp +.Ip "tr/SEARCHLIST/REPLACEMENTLIST/cds" 8 5 +.Ip "y/SEARCHLIST/REPLACEMENTLIST/cds" 8 +Translates all occurrences of the characters found in the search list with +the corresponding character in the replacement list. +It returns the number of characters replaced or deleted. +If no string is specified via the =~ or !~ operator, +the $_ string is translated. +(The string specified with =~ must be a scalar variable, an array element, +or an assignment to one of those, i.e. an lvalue.) +For +.I sed +devotees, +.I y +is provided as a synonym for +.IR tr . +If the SEARCHLIST is delimited by bracketing quotes, the REPLACEMENTLIST +has its own pair of quotes, which may or may not be bracketing quotes, e.g. +tr[A-Z][a-z] or tr(+-*/)/ABCD/. +.Sp +If the c modifier is specified, the SEARCHLIST character set is complemented. +If the d modifier is specified, any characters specified by SEARCHLIST that +are not found in REPLACEMENTLIST are deleted. +(Note that this is slightly more flexible than the behavior of some +.I tr +programs, which delete anything they find in the SEARCHLIST, period.) +If the s modifier is specified, sequences of characters that were translated +to the same character are squashed down to 1 instance of the character. +.Sp +If the d modifier was used, the REPLACEMENTLIST is always interpreted exactly +as specified. +Otherwise, if the REPLACEMENTLIST is shorter than the SEARCHLIST, +the final character is replicated till it is long enough. +If the REPLACEMENTLIST is null, the SEARCHLIST is replicated. +This latter is useful for counting characters in a class, or for squashing +character sequences in a class. +.Sp +Examples: +.nf + + $ARGV[1] \|=~ \|y/A\-Z/a\-z/; \h'|3i'# canonicalize to lower case + + $cnt = tr/*/*/; \h'|3i'# count the stars in $_ + + $cnt = tr/0\-9//; \h'|3i'# count the digits in $_ + + tr/a\-zA\-Z//s; \h'|3i'# bookkeeper \-> bokeper + + ($HOST = $host) =~ tr/a\-z/A\-Z/; + + y/a\-zA\-Z/ /cs; \h'|3i'# change non-alphas to single space + + tr/\e200\-\e377/\e0\-\e177/;\h'|3i'# delete 8th bit + +.fi +.Ip "truncate(FILEHANDLE,LENGTH)" 8 4 +.Ip "truncate(EXPR,LENGTH)" 8 +Truncates the file opened on FILEHANDLE, or named by EXPR, to the specified +length. +Produces a fatal error if truncate isn't implemented on your system. +.Ip "umask(EXPR)" 8 4 +.Ip "umask EXPR" 8 +.Ip "umask" 8 +Sets the umask for the process and returns the old one. +If EXPR is omitted, merely returns current umask. +.Ip "undef(EXPR)" 8 6 +.Ip "undef EXPR" 8 +.Ip "undef" 8 +Undefines the value of EXPR, which must be an lvalue. +Use only on a scalar value, an entire array, or a subroutine name (using &). +(Undef will probably not do what you expect on most predefined variables or +dbm array values.) +Always returns the undefined value. +You can omit the EXPR, in which case nothing is undefined, but you still +get an undefined value that you could, for instance, return from a subroutine. +Examples: +.nf + +.ne 6 + undef $foo; + undef $bar{'blurfl'}; + undef @ary; + undef %assoc; + undef &mysub; + return (wantarray ? () : undef) if $they_blew_it; + +.fi +.Ip "unlink(LIST)" 8 4 +.Ip "unlink LIST" 8 +Deletes a list of files. +Returns the number of files successfully deleted. +.nf + +.ne 2 + $cnt = unlink \'a\', \'b\', \'c\'; + unlink @goners; + unlink <*.bak>; + +.fi +Note: unlink will not delete directories unless you are superuser and the +.B \-U +flag is supplied to +.IR perl . +Even if these conditions are met, be warned that unlinking a directory +can inflict damage on your filesystem. +Use rmdir instead. +.Ip "unpack(TEMPLATE,EXPR)" 8 4 +Unpack does the reverse of pack: it takes a string representing +a structure and expands it out into an array value, returning the array +value. +(In a scalar context, it merely returns the first value produced.) +The TEMPLATE has the same format as in the pack function. +Here's a subroutine that does substring: +.nf + +.ne 4 + sub substr { + local($what,$where,$howmuch) = @_; + unpack("x$where a$howmuch", $what); + } + +.ne 3 +and then there's + + sub ord { unpack("c",$_[0]); } + +.fi +In addition, you may prefix a field with a % to indicate that +you want a -bit checksum of the items instead of the items themselves. +Default is a 16-bit checksum. +For example, the following computes the same number as the System V sum program: +.nf + +.ne 4 + while (<>) { + $checksum += unpack("%16C*", $_); + } + $checksum %= 65536; + +.fi +.Ip "unshift(ARRAY,LIST)" 8 4 +Does the opposite of a +.IR shift . +Or the opposite of a +.IR push , +depending on how you look at it. +Prepends list to the front of the array, and returns the number of elements +in the new array. +.nf + + unshift(ARGV, \'\-e\') unless $ARGV[0] =~ /^\-/; + +.fi +.Ip "utime(LIST)" 8 2 +.Ip "utime LIST" 8 2 +Changes the access and modification times on each file of a list of files. +The first two elements of the list must be the NUMERICAL access and +modification times, in that order. +Returns the number of files successfully changed. +The inode modification time of each file is set to the current time. +Example of a \*(L"touch\*(R" command: +.nf + +.ne 3 + #!/usr/bin/perl + $now = time; + utime $now, $now, @ARGV; + +.fi +.Ip "values(ASSOC_ARRAY)" 8 6 +.Ip "values ASSOC_ARRAY" 8 +Returns a normal array consisting of all the values of the named associative +array. +The values are returned in an apparently random order, but it is the same order +as either the keys() or each() function would produce on the same array. +See also keys() and each(). +.Ip "vec(EXPR,OFFSET,BITS)" 8 2 +Treats a string as a vector of unsigned integers, and returns the value +of the bitfield specified. +May also be assigned to. +BITS must be a power of two from 1 to 32. +.Sp +Vectors created with vec() can also be manipulated with the logical operators +|, & and ^, +which will assume a bit vector operation is desired when both operands are +strings. +This interpretation is not enabled unless there is at least one vec() in +your program, to protect older programs. +.Sp +To transform a bit vector into a string or array of 0's and 1's, use these: +.nf + + $bits = unpack("b*", $vector); + @bits = split(//, unpack("b*", $vector)); + +.fi +If you know the exact length in bits, it can be used in place of the *. +.Ip "wait" 8 6 +Waits for a child process to terminate and returns the pid of the deceased +process, or -1 if there are no child processes. +The status is returned in $?. +.Ip "waitpid(PID,FLAGS)" 8 6 +Waits for a particular child process to terminate and returns the pid of the deceased +process, or -1 if there is no such child process. +The status is returned in $?. +If you say +.nf + + require "sys/wait.h"; + .\|.\|. + waitpid(-1,&WNOHANG); + +.fi +then you can do a non-blocking wait for any process. Non-blocking wait +is only available on machines supporting either the +.I waitpid (2) +or +.I wait4 (2) +system calls. +However, waiting for a particular pid with FLAGS of 0 is implemented +everywhere. (Perl emulates the system call by remembering the status +values of processes that have exited but have not been harvested by the +Perl script yet.) +.Ip "wantarray" 8 4 +Returns true if the context of the currently executing subroutine +is looking for an array value. +Returns false if the context is looking for a scalar. +.nf + + return wantarray ? () : undef; + +.fi +.Ip "warn(LIST)" 8 4 +.Ip "warn LIST" 8 +Produces a message on STDERR just like \*(L"die\*(R", but doesn't exit. +.Ip "write(FILEHANDLE)" 8 6 +.Ip "write(EXPR)" 8 +.Ip "write" 8 +Writes a formatted record (possibly multi-line) to the specified file, +using the format associated with that file. +By default the format for a file is the one having the same name is the +filehandle, but the format for the current output channel (see +.IR select ) +may be set explicitly +by assigning the name of the format to the $~ variable. +.Sp +Top of form processing is handled automatically: +if there is insufficient room on the current page for the formatted +record, the page is advanced by writing a form feed, +a special top-of-page format is used +to format the new page header, and then the record is written. +By default the top-of-page format is the name of the filehandle with +\*(L"_TOP\*(R" appended, but it may be dynamicallly set to the +format of your choice by assigning the name to the $^ variable while +the filehandle is selected. +The number of lines remaining on the current page is in variable $-, which +can be set to 0 to force a new page. +.Sp +If FILEHANDLE is unspecified, output goes to the current default output channel, +which starts out as +.I STDOUT +but may be changed by the +.I select +operator. +If the FILEHANDLE is an EXPR, then the expression is evaluated and the +resulting string is used to look up the name of the FILEHANDLE at run time. +For more on formats, see the section on formats later on. +.Sp +Note that write is NOT the opposite of read. +.Sh "Precedence" +.I Perl +operators have the following associativity and precedence: +.nf + +nonassoc\h'|1i'print printf exec system sort reverse +\h'1.5i'chmod chown kill unlink utime die return +left\h'|1i', +right\h'|1i'= += \-= *= etc. +right\h'|1i'?: +nonassoc\h'|1i'.\|. +left\h'|1i'|| +left\h'|1i'&& +left\h'|1i'| ^ +left\h'|1i'& +nonassoc\h'|1i'== != <=> eq ne cmp +nonassoc\h'|1i'< > <= >= lt gt le ge +nonassoc\h'|1i'chdir exit eval reset sleep rand umask +nonassoc\h'|1i'\-r \-w \-x etc. +left\h'|1i'<< >> +left\h'|1i'+ \- . +left\h'|1i'* / % x +left\h'|1i'=~ !~ +right\h'|1i'! ~ and unary minus +right\h'|1i'** +nonassoc\h'|1i'++ \-\|\- +left\h'|1i'\*(L'(\*(R' + +.fi +As mentioned earlier, if any list operator (print, etc.) or +any unary operator (chdir, etc.) +is followed by a left parenthesis as the next token on the same line, +the operator and arguments within parentheses are taken to +be of highest precedence, just like a normal function call. +Examples: +.nf + + chdir $foo || die;\h'|3i'# (chdir $foo) || die + chdir($foo) || die;\h'|3i'# (chdir $foo) || die + chdir ($foo) || die;\h'|3i'# (chdir $foo) || die + chdir +($foo) || die;\h'|3i'# (chdir $foo) || die + +but, because * is higher precedence than ||: + + chdir $foo * 20;\h'|3i'# chdir ($foo * 20) + chdir($foo) * 20;\h'|3i'# (chdir $foo) * 20 + chdir ($foo) * 20;\h'|3i'# (chdir $foo) * 20 + chdir +($foo) * 20;\h'|3i'# chdir ($foo * 20) + + rand 10 * 20;\h'|3i'# rand (10 * 20) + rand(10) * 20;\h'|3i'# (rand 10) * 20 + rand (10) * 20;\h'|3i'# (rand 10) * 20 + rand +(10) * 20;\h'|3i'# rand (10 * 20) + +.fi +In the absence of parentheses, +the precedence of list operators such as print, sort or chmod is +either very high or very low depending on whether you look at the left +side of operator or the right side of it. +For example, in +.nf + + @ary = (1, 3, sort 4, 2); + print @ary; # prints 1324 + +.fi +the commas on the right of the sort are evaluated before the sort, but +the commas on the left are evaluated after. +In other words, list operators tend to gobble up all the arguments that +follow them, and then act like a simple term with regard to the preceding +expression. +Note that you have to be careful with parens: +.nf + +.ne 3 + # These evaluate exit before doing the print: + print($foo, exit); # Obviously not what you want. + print $foo, exit; # Nor is this. + +.ne 4 + # These do the print before evaluating exit: + (print $foo), exit; # This is what you want. + print($foo), exit; # Or this. + print ($foo), exit; # Or even this. + +Also note that + + print ($foo & 255) + 1, "\en"; + +.fi +probably doesn't do what you expect at first glance. +.Sh "Subroutines" +A subroutine may be declared as follows: +.nf + + sub NAME BLOCK + +.fi +.PP +Any arguments passed to the routine come in as array @_, +that is ($_[0], $_[1], .\|.\|.). +The array @_ is a local array, but its values are references to the +actual scalar parameters. +The return value of the subroutine is the value of the last expression +evaluated, and can be either an array value or a scalar value. +Alternately, a return statement may be used to specify the returned value and +exit the subroutine. +To create local variables see the +.I local +operator. +.PP +A subroutine is called using the +.I do +operator or the & operator. +.nf + +.ne 12 +Example: + + sub MAX { + local($max) = pop(@_); + foreach $foo (@_) { + $max = $foo \|if \|$max < $foo; + } + $max; + } + + .\|.\|. + $bestday = &MAX($mon,$tue,$wed,$thu,$fri); + +.ne 21 +Example: + + # get a line, combining continuation lines + # that start with whitespace + sub get_line { + $thisline = $lookahead; + line: while ($lookahead = ) { + if ($lookahead \|=~ \|/\|^[ \^\e\|t]\|/\|) { + $thisline \|.= \|$lookahead; + } + else { + last line; + } + } + $thisline; + } + + $lookahead = ; # get first line + while ($_ = do get_line(\|)) { + .\|.\|. + } + +.fi +.nf +.ne 6 +Use array assignment to a local list to name your formal arguments: + + sub maybeset { + local($key, $value) = @_; + $foo{$key} = $value unless $foo{$key}; + } + +.fi +This also has the effect of turning call-by-reference into call-by-value, +since the assignment copies the values. +.Sp +Subroutines may be called recursively. +If a subroutine is called using the & form, the argument list is optional. +If omitted, no @_ array is set up for the subroutine; the @_ array at the +time of the call is visible to subroutine instead. +.nf + + do foo(1,2,3); # pass three arguments + &foo(1,2,3); # the same + + do foo(); # pass a null list + &foo(); # the same + &foo; # pass no arguments\*(--more efficient + +.fi +.Sh "Passing By Reference" +Sometimes you don't want to pass the value of an array to a subroutine but +rather the name of it, so that the subroutine can modify the global copy +of it rather than working with a local copy. +In perl you can refer to all the objects of a particular name by prefixing +the name with a star: *foo. +When evaluated, it produces a scalar value that represents all the objects +of that name, including any filehandle, format or subroutine. +When assigned to within a local() operation, it causes the name mentioned +to refer to whatever * value was assigned to it. +Example: +.nf + + sub doubleary { + local(*someary) = @_; + foreach $elem (@someary) { + $elem *= 2; + } + } + do doubleary(*foo); + do doubleary(*bar); + +.fi +Assignment to *name is currently recommended only inside a local(). +You can actually assign to *name anywhere, but the previous referent of +*name may be stranded forever. +This may or may not bother you. +.Sp +Note that scalars are already passed by reference, so you can modify scalar +arguments without using this mechanism by referring explicitly to the $_[nnn] +in question. +You can modify all the elements of an array by passing all the elements +as scalars, but you have to use the * mechanism to push, pop or change the +size of an array. +The * mechanism will probably be more efficient in any case. +.Sp +Since a *name value contains unprintable binary data, if it is used as +an argument in a print, or as a %s argument in a printf or sprintf, it +then has the value '*name', just so it prints out pretty. +.Sp +Even if you don't want to modify an array, this mechanism is useful for +passing multiple arrays in a single LIST, since normally the LIST mechanism +will merge all the array values so that you can't extract out the +individual arrays. +.Sh "Regular Expressions" +The patterns used in pattern matching are regular expressions such as +those supplied in the Version 8 regexp routines. +(In fact, the routines are derived from Henry Spencer's freely redistributable +reimplementation of the V8 routines.) +In addition, \ew matches an alphanumeric character (including \*(L"_\*(R") and \eW a nonalphanumeric. +Word boundaries may be matched by \eb, and non-boundaries by \eB. +A whitespace character is matched by \es, non-whitespace by \eS. +A numeric character is matched by \ed, non-numeric by \eD. +You may use \ew, \es and \ed within character classes. +Also, \en, \er, \ef, \et and \eNNN have their normal interpretations. +Within character classes \eb represents backspace rather than a word boundary. +Alternatives may be separated by |. +The bracketing construct \|(\ .\|.\|.\ \|) may also be used, in which case \e +matches the digit'th substring. +(Outside of the pattern, always use $ instead of \e in front of the digit. +The scope of $ (and $\`, $& and $\') +extends to the end of the enclosing BLOCK or eval string, or to +the next pattern match with subexpressions. +The \e notation sometimes works outside the current pattern, but should +not be relied upon.) +You may have as many parentheses as you wish. If you have more than 9 +substrings, the variables $10, $11, ... refer to the corresponding +substring. Within the pattern, \e10, \e11, +etc. refer back to substrings if there have been at least that many left parens +before the backreference. Otherwise (for backward compatibilty) \e10 +is the same as \e010, a backspace, +and \e11 the same as \e011, a tab. +And so on. +(\e1 through \e9 are always backreferences.) +.PP +$+ returns whatever the last bracket match matched. +$& returns the entire matched string. +($0 used to return the same thing, but not any more.) +$\` returns everything before the matched string. +$\' returns everything after the matched string. +Examples: +.nf + + s/\|^\|([^ \|]*\|) \|*([^ \|]*\|)\|/\|$2 $1\|/; # swap first two words + +.ne 5 + if (/\|Time: \|(.\|.\|):\|(.\|.\|):\|(.\|.\|)\|/\|) { + $hours = $1; + $minutes = $2; + $seconds = $3; + } + +.fi +By default, the ^ character is only guaranteed to match at the beginning +of the string, +the $ character only at the end (or before the newline at the end) +and +.I perl +does certain optimizations with the assumption that the string contains +only one line. +The behavior of ^ and $ on embedded newlines will be inconsistent. +You may, however, wish to treat a string as a multi-line buffer, such that +the ^ will match after any newline within the string, and $ will match +before any newline. +At the cost of a little more overhead, you can do this by setting the variable +$* to 1. +Setting it back to 0 makes +.I perl +revert to its old behavior. +.PP +To facilitate multi-line substitutions, the . character never matches a newline +(even when $* is 0). +In particular, the following leaves a newline on the $_ string: +.nf + + $_ = ; + s/.*(some_string).*/$1/; + +If the newline is unwanted, try one of + + s/.*(some_string).*\en/$1/; + s/.*(some_string)[^\e000]*/$1/; + s/.*(some_string)(.|\en)*/$1/; + chop; s/.*(some_string).*/$1/; + /(some_string)/ && ($_ = $1); + +.fi +Any item of a regular expression may be followed with digits in curly brackets +of the form {n,m}, where n gives the minimum number of times to match the item +and m gives the maximum. +The form {n} is equivalent to {n,n} and matches exactly n times. +The form {n,} matches n or more times. +(If a curly bracket occurs in any other context, it is treated as a regular +character.) +The * modifier is equivalent to {0,}, the + modifier to {1,} and the ? modifier +to {0,1}. +There is no limit to the size of n or m, but large numbers will chew up +more memory. +.Sp +You will note that all backslashed metacharacters in +.I perl +are alphanumeric, +such as \eb, \ew, \en. +Unlike some other regular expression languages, there are no backslashed +symbols that aren't alphanumeric. +So anything that looks like \e\e, \e(, \e), \e<, \e>, \e{, or \e} is always +interpreted as a literal character, not a metacharacter. +This makes it simple to quote a string that you want to use for a pattern +but that you are afraid might contain metacharacters. +Simply quote all the non-alphanumeric characters: +.nf + + $pattern =~ s/(\eW)/\e\e$1/g; + +.fi +.Sh "Formats" +Output record formats for use with the +.I write +operator may declared as follows: +.nf + +.ne 3 + format NAME = + FORMLIST + . + +.fi +If name is omitted, format \*(L"STDOUT\*(R" is defined. +FORMLIST consists of a sequence of lines, each of which may be of one of three +types: +.Ip 1. 4 +A comment. +.Ip 2. 4 +A \*(L"picture\*(R" line giving the format for one output line. +.Ip 3. 4 +An argument line supplying values to plug into a picture line. +.PP +Picture lines are printed exactly as they look, except for certain fields +that substitute values into the line. +Each picture field starts with either @ or ^. +The @ field (not to be confused with the array marker @) is the normal +case; ^ fields are used +to do rudimentary multi-line text block filling. +The length of the field is supplied by padding out the field +with multiple <, >, or | characters to specify, respectively, left justification, +right justification, or centering. +As an alternate form of right justification, +you may also use # characters (with an optional .) to specify a numeric field. +(Use of ^ instead of @ causes the field to be blanked if undefined.) +If any of the values supplied for these fields contains a newline, only +the text up to the newline is printed. +The special field @* can be used for printing multi-line values. +It should appear by itself on a line. +.PP +The values are specified on the following line, in the same order as +the picture fields. +The values should be separated by commas. +.PP +Picture fields that begin with ^ rather than @ are treated specially. +The value supplied must be a scalar variable name which contains a text +string. +.I Perl +puts as much text as it can into the field, and then chops off the front +of the string so that the next time the variable is referenced, +more of the text can be printed. +Normally you would use a sequence of fields in a vertical stack to print +out a block of text. +If you like, you can end the final field with .\|.\|., which will appear in the +output if the text was too long to appear in its entirety. +You can change which characters are legal to break on by changing the +variable $: to a list of the desired characters. +.PP +Since use of ^ fields can produce variable length records if the text to be +formatted is short, you can suppress blank lines by putting the tilde (~) +character anywhere in the line. +(Normally you should put it in the front if possible, for visibility.) +The tilde will be translated to a space upon output. +If you put a second tilde contiguous to the first, the line will be repeated +until all the fields on the line are exhausted. +(If you use a field of the @ variety, the expression you supply had better +not give the same value every time forever!) +.PP +Examples: +.nf +.lg 0 +.cs R 25 +.ft C + +.ne 10 +# a report on the /etc/passwd file +format STDOUT_TOP = +\& Passwd File +Name Login Office Uid Gid Home +------------------------------------------------------------------ +\&. +format STDOUT = +@<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<< +$name, $login, $office,$uid,$gid, $home +\&. + +.ne 29 +# a report from a bug report form +format STDOUT_TOP = +\& Bug Reports +@<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>> +$system, $%, $date +------------------------------------------------------------------ +\&. +format STDOUT = +Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $subject +Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $index, $description +Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $priority, $date, $description +From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $from, $description +Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $programmer, $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<< +\& $description +\&~ ^<<<<<<<<<<<<<<<<<<<<<<<... +\& $description +\&. + +.ft R +.cs R +.lg +.fi +It is possible to intermix prints with writes on the same output channel, +but you'll have to handle $\- (lines left on the page) yourself. +.PP +If you are printing lots of fields that are usually blank, you should consider +using the reset operator between records. +Not only is it more efficient, but it can prevent the bug of adding another +field and forgetting to zero it. +.Sh "Interprocess Communication" +The IPC facilities of perl are built on the Berkeley socket mechanism. +If you don't have sockets, you can ignore this section. +The calls have the same names as the corresponding system calls, +but the arguments tend to differ, for two reasons. +First, perl file handles work differently than C file descriptors. +Second, perl already knows the length of its strings, so you don't need +to pass that information. +Here is a sample client (untested): +.nf + + ($them,$port) = @ARGV; + $port = 2345 unless $port; + $them = 'localhost' unless $them; + + $SIG{'INT'} = 'dokill'; + sub dokill { kill 9,$child if $child; } + + require 'sys/socket.ph'; + + $sockaddr = 'S n a4 x8'; + chop($hostname = `hostname`); + + ($name, $aliases, $proto) = getprotobyname('tcp'); + ($name, $aliases, $port) = getservbyname($port, 'tcp') + unless $port =~ /^\ed+$/; +.ie t \{\ + ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname); +'br\} +.el \{\ + ($name, $aliases, $type, $len, $thisaddr) = + gethostbyname($hostname); +'br\} + ($name, $aliases, $type, $len, $thataddr) = gethostbyname($them); + + $this = pack($sockaddr, &AF_INET, 0, $thisaddr); + $that = pack($sockaddr, &AF_INET, $port, $thataddr); + + socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; + bind(S, $this) || die "bind: $!"; + connect(S, $that) || die "connect: $!"; + + select(S); $| = 1; select(stdout); + + if ($child = fork) { + while (<>) { + print S; + } + sleep 3; + do dokill(); + } + else { + while () { + print; + } + } + +.fi +And here's a server: +.nf + + ($port) = @ARGV; + $port = 2345 unless $port; + + require 'sys/socket.ph'; + + $sockaddr = 'S n a4 x8'; + + ($name, $aliases, $proto) = getprotobyname('tcp'); + ($name, $aliases, $port) = getservbyname($port, 'tcp') + unless $port =~ /^\ed+$/; + + $this = pack($sockaddr, &AF_INET, $port, "\e0\e0\e0\e0"); + + select(NS); $| = 1; select(stdout); + + socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!"; + bind(S, $this) || die "bind: $!"; + listen(S, 5) || die "connect: $!"; + + select(S); $| = 1; select(stdout); + + for (;;) { + print "Listening again\en"; + ($addr = accept(NS,S)) || die $!; + print "accept ok\en"; + + ($af,$port,$inetaddr) = unpack($sockaddr,$addr); + @inetaddr = unpack('C4',$inetaddr); + print "$af $port @inetaddr\en"; + + while () { + print; + print NS; + } + } + +.fi +.Sh "Predefined Names" +The following names have special meaning to +.IR perl . +I could have used alphabetic symbols for some of these, but I didn't want +to take the chance that someone would say reset \*(L"a\-zA\-Z\*(R" and wipe them all +out. +You'll just have to suffer along with these silly symbols. +Most of them have reasonable mnemonics, or analogues in one of the shells. +.Ip $_ 8 +The default input and pattern-searching space. +The following pairs are equivalent: +.nf + +.ne 2 + while (<>) {\|.\|.\|. # only equivalent in while! + while ($_ = <>) {\|.\|.\|. + +.ne 2 + /\|^Subject:/ + $_ \|=~ \|/\|^Subject:/ + +.ne 2 + y/a\-z/A\-Z/ + $_ =~ y/a\-z/A\-Z/ + +.ne 2 + chop + chop($_) + +.fi +(Mnemonic: underline is understood in certain operations.) +.Ip $. 8 +The current input line number of the last filehandle that was read. +Readonly. +Remember that only an explicit close on the filehandle resets the line number. +Since <> never does an explicit close, line numbers increase across ARGV files +(but see examples under eof). +(Mnemonic: many programs use . to mean the current line number.) +.Ip $/ 8 +The input record separator, newline by default. +Works like +.IR awk 's +RS variable, including treating blank lines as delimiters +if set to the null string. +You may set it to a multicharacter string to match a multi-character +delimiter. +Note that setting it to "\en\en" means something slightly different +than setting it to "", if the file contains consecutive blank lines. +Setting it to "" will treat two or more consecutive blank lines as a single +blank line. +Setting it to "\en\en" will blindly assume that the next input character +belongs to the next paragraph, even if it's a newline. +(Mnemonic: / is used to delimit line boundaries when quoting poetry.) +.Ip $, 8 +The output field separator for the print operator. +Ordinarily the print operator simply prints out the comma separated fields +you specify. +In order to get behavior more like +.IR awk , +set this variable as you would set +.IR awk 's +OFS variable to specify what is printed between fields. +(Mnemonic: what is printed when there is a , in your print statement.) +.Ip $"" 8 +This is like $, except that it applies to array values interpolated into +a double-quoted string (or similar interpreted string). +Default is a space. +(Mnemonic: obvious, I think.) +.Ip $\e 8 +The output record separator for the print operator. +Ordinarily the print operator simply prints out the comma separated fields +you specify, with no trailing newline or record separator assumed. +In order to get behavior more like +.IR awk , +set this variable as you would set +.IR awk 's +ORS variable to specify what is printed at the end of the print. +(Mnemonic: you set $\e instead of adding \en at the end of the print. +Also, it's just like /, but it's what you get \*(L"back\*(R" from +.IR perl .) +.Ip $# 8 +The output format for printed numbers. +This variable is a half-hearted attempt to emulate +.IR awk 's +OFMT variable. +There are times, however, when +.I awk +and +.I perl +have differing notions of what +is in fact numeric. +Also, the initial value is %.20g rather than %.6g, so you need to set $# +explicitly to get +.IR awk 's +value. +(Mnemonic: # is the number sign.) +.Ip $% 8 +The current page number of the currently selected output channel. +(Mnemonic: % is page number in nroff.) +.Ip $= 8 +The current page length (printable lines) of the currently selected output +channel. +Default is 60. +(Mnemonic: = has horizontal lines.) +.Ip $\- 8 +The number of lines left on the page of the currently selected output channel. +(Mnemonic: lines_on_page \- lines_printed.) +.Ip $~ 8 +The name of the current report format for the currently selected output +channel. +Default is name of the filehandle. +(Mnemonic: brother to $^.) +.Ip $^ 8 +The name of the current top-of-page format for the currently selected output +channel. +Default is name of the filehandle with \*(L"_TOP\*(R" appended. +(Mnemonic: points to top of page.) +.Ip $| 8 +If set to nonzero, forces a flush after every write or print on the currently +selected output channel. +Default is 0. +Note that +.I STDOUT +will typically be line buffered if output is to the +terminal and block buffered otherwise. +Setting this variable is useful primarily when you are outputting to a pipe, +such as when you are running a +.I perl +script under rsh and want to see the +output as it's happening. +(Mnemonic: when you want your pipes to be piping hot.) +.Ip $$ 8 +The process number of the +.I perl +running this script. +(Mnemonic: same as shells.) +.Ip $? 8 +The status returned by the last pipe close, backtick (\`\`) command or +.I system +operator. +Note that this is the status word returned by the wait() system +call, so the exit value of the subprocess is actually ($? >> 8). +$? & 255 gives which signal, if any, the process died from, and whether +there was a core dump. +(Mnemonic: similar to sh and ksh.) +.Ip $& 8 4 +The string matched by the last successful pattern match +(not counting any matches hidden +within a BLOCK or eval enclosed by the current BLOCK). +(Mnemonic: like & in some editors.) +.Ip $\` 8 4 +The string preceding whatever was matched by the last successful pattern match +(not counting any matches hidden within a BLOCK or eval enclosed by the current +BLOCK). +(Mnemonic: \` often precedes a quoted string.) +.Ip $\' 8 4 +The string following whatever was matched by the last successful pattern match +(not counting any matches hidden within a BLOCK or eval enclosed by the current +BLOCK). +(Mnemonic: \' often follows a quoted string.) +Example: +.nf + +.ne 3 + $_ = \'abcdefghi\'; + /def/; + print "$\`:$&:$\'\en"; # prints abc:def:ghi + +.fi +.Ip $+ 8 4 +The last bracket matched by the last search pattern. +This is useful if you don't know which of a set of alternative patterns +matched. +For example: +.nf + + /Version: \|(.*\|)|Revision: \|(.*\|)\|/ \|&& \|($rev = $+); + +.fi +(Mnemonic: be positive and forward looking.) +.Ip $* 8 2 +Set to 1 to do multiline matching within a string, 0 to tell +.I perl +that it can assume that strings contain a single line, for the purpose +of optimizing pattern matches. +Pattern matches on strings containing multiple newlines can produce confusing +results when $* is 0. +Default is 0. +(Mnemonic: * matches multiple things.) +Note that this variable only influences the interpretation of ^ and $. +A literal newline can be searched for even when $* == 0. +.Ip $0 8 +Contains the name of the file containing the +.I perl +script being executed. +Assigning to $0 modifies the argument area that the ps(1) program sees. +(Mnemonic: same as sh and ksh.) +.Ip $ 8 +Contains the subpattern from the corresponding set of parentheses in the last +pattern matched, not counting patterns matched in nested blocks that have +been exited already. +(Mnemonic: like \edigit.) +.Ip $[ 8 2 +The index of the first element in an array, and of the first character in +a substring. +Default is 0, but you could set it to 1 to make +.I perl +behave more like +.I awk +(or Fortran) +when subscripting and when evaluating the index() and substr() functions. +(Mnemonic: [ begins subscripts.) +.Ip $] 8 2 +The string printed out when you say \*(L"perl -v\*(R". +It can be used to determine at the beginning of a script whether the perl +interpreter executing the script is in the right range of versions. +If used in a numeric context, returns the version + patchlevel / 1000. +Example: +.nf + +.ne 8 + # see if getc is available + ($version,$patchlevel) = + $] =~ /(\ed+\e.\ed+).*\enPatch level: (\ed+)/; + print STDERR "(No filename completion available.)\en" + if $version * 1000 + $patchlevel < 2016; + +or, used numerically, + + warn "No checksumming!\en" if $] < 3.019; + +.fi +(Mnemonic: Is this version of perl in the right bracket?) +.Ip $; 8 2 +The subscript separator for multi-dimensional array emulation. +If you refer to an associative array element as +.nf + $foo{$a,$b,$c} + +it really means + + $foo{join($;, $a, $b, $c)} + +But don't put + + @foo{$a,$b,$c} # a slice\*(--note the @ + +which means + + ($foo{$a},$foo{$b},$foo{$c}) + +.fi +Default is "\e034", the same as SUBSEP in +.IR awk . +Note that if your keys contain binary data there might not be any safe +value for $;. +(Mnemonic: comma (the syntactic subscript separator) is a semi-semicolon. +Yeah, I know, it's pretty lame, but $, is already taken for something more +important.) +.Ip $! 8 2 +If used in a numeric context, yields the current value of errno, with all the +usual caveats. +(This means that you shouldn't depend on the value of $! to be anything +in particular unless you've gotten a specific error return indicating a +system error.) +If used in a string context, yields the corresponding system error string. +You can assign to $! in order to set errno +if, for instance, you want $! to return the string for error n, or you want +to set the exit value for the die operator. +(Mnemonic: What just went bang?) +.Ip $@ 8 2 +The perl syntax error message from the last eval command. +If null, the last eval parsed and executed correctly (although the operations +you invoked may have failed in the normal fashion). +(Mnemonic: Where was the syntax error \*(L"at\*(R"?) +.Ip $< 8 2 +The real uid of this process. +(Mnemonic: it's the uid you came FROM, if you're running setuid.) +.Ip $> 8 2 +The effective uid of this process. +Example: +.nf + +.ne 2 + $< = $>; # set real uid to the effective uid + ($<,$>) = ($>,$<); # swap real and effective uid + +.fi +(Mnemonic: it's the uid you went TO, if you're running setuid.) +Note: $< and $> can only be swapped on machines supporting setreuid(). +.Ip $( 8 2 +The real gid of this process. +If you are on a machine that supports membership in multiple groups +simultaneously, gives a space separated list of groups you are in. +The first number is the one returned by getgid(), and the subsequent ones +by getgroups(), one of which may be the same as the first number. +(Mnemonic: parentheses are used to GROUP things. +The real gid is the group you LEFT, if you're running setgid.) +.Ip $) 8 2 +The effective gid of this process. +If you are on a machine that supports membership in multiple groups +simultaneously, gives a space separated list of groups you are in. +The first number is the one returned by getegid(), and the subsequent ones +by getgroups(), one of which may be the same as the first number. +(Mnemonic: parentheses are used to GROUP things. +The effective gid is the group that's RIGHT for you, if you're running setgid.) +.Sp +Note: $<, $>, $( and $) can only be set on machines that support the +corresponding set[re][ug]id() routine. +$( and $) can only be swapped on machines supporting setregid(). +.Ip $: 8 2 +The current set of characters after which a string may be broken to +fill continuation fields (starting with ^) in a format. +Default is "\ \en-", to break on whitespace or hyphens. +(Mnemonic: a \*(L"colon\*(R" in poetry is a part of a line.) +.Ip $^D 8 2 +The current value of the debugging flags. +(Mnemonic: value of +.B \-D +switch.) +.Ip $^F 8 2 +The maximum system file descriptor, ordinarily 2. System file descriptors +are passed to subprocesses, while higher file descriptors are not. +During an open, system file descriptors are preserved even if the open +fails. Ordinary file descriptors are closed before the open is attempted. +.Ip $^I 8 2 +The current value of the inplace-edit extension. +Use undef to disable inplace editing. +(Mnemonic: value of +.B \-i +switch.) +.Ip $^L 8 2 +What formats output to perform a formfeed. Default is \ef. +.Ip $^P 8 2 +The internal flag that the debugger clears so that it doesn't +debug itself. You could conceivable disable debugging yourself +by clearing it. +.Ip $^T 8 2 +The time at which the script began running, in seconds since the epoch. +The values returned by the +.B \-M , +.B \-A +and +.B \-C +filetests are based on this value. +.Ip $^W 8 2 +The current value of the warning switch. +(Mnemonic: related to the +.B \-w +switch.) +.Ip $^X 8 2 +The name that Perl itself was executed as, from argv[0]. +.Ip $ARGV 8 3 +contains the name of the current file when reading from <>. +.Ip @ARGV 8 3 +The array ARGV contains the command line arguments intended for the script. +Note that $#ARGV is the generally number of arguments minus one, since +$ARGV[0] is the first argument, NOT the command name. +See $0 for the command name. +.Ip @INC 8 3 +The array INC contains the list of places to look for +.I perl +scripts to be +evaluated by the \*(L"do EXPR\*(R" command or the \*(L"require\*(R" command. +It initially consists of the arguments to any +.B \-I +command line switches, followed +by the default +.I perl +library, probably \*(L"/usr/local/lib/perl\*(R", +followed by \*(L".\*(R", to represent the current directory. +.Ip %INC 8 3 +The associative array INC contains entries for each filename that has +been included via \*(L"do\*(R" or \*(L"require\*(R". +The key is the filename you specified, and the value is the location of +the file actually found. +The \*(L"require\*(R" command uses this array to determine whether +a given file has already been included. +.Ip $ENV{expr} 8 2 +The associative array ENV contains your current environment. +Setting a value in ENV changes the environment for child processes. +.Ip $SIG{expr} 8 2 +The associative array SIG is used to set signal handlers for various signals. +Example: +.nf + +.ne 12 + sub handler { # 1st argument is signal name + local($sig) = @_; + print "Caught a SIG$sig\-\|\-shutting down\en"; + close(LOG); + exit(0); + } + + $SIG{\'INT\'} = \'handler\'; + $SIG{\'QUIT\'} = \'handler\'; + .\|.\|. + $SIG{\'INT\'} = \'DEFAULT\'; # restore default action + $SIG{\'QUIT\'} = \'IGNORE\'; # ignore SIGQUIT + +.fi +The SIG array only contains values for the signals actually set within +the perl script. +.Sh "Packages" +Perl provides a mechanism for alternate namespaces to protect packages from +stomping on each others variables. +By default, a perl script starts compiling into the package known as \*(L"main\*(R". +By use of the +.I package +declaration, you can switch namespaces. +The scope of the package declaration is from the declaration itself to the end +of the enclosing block (the same scope as the local() operator). +Typically it would be the first declaration in a file to be included by +the \*(L"require\*(R" operator. +You can switch into a package in more than one place; it merely influences +which symbol table is used by the compiler for the rest of that block. +You can refer to variables and filehandles in other packages by prefixing +the identifier with the package name and a single quote. +If the package name is null, the \*(L"main\*(R" package as assumed. +.PP +Only identifiers starting with letters are stored in the packages symbol +table. +All other symbols are kept in package \*(L"main\*(R". +In addition, the identifiers STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV, INC +and SIG are forced to be in package \*(L"main\*(R", even when used for +other purposes than their built-in one. +Note also that, if you have a package called \*(L"m\*(R", \*(L"s\*(R" +or \*(L"y\*(R", the you can't use the qualified form of an identifier since it +will be interpreted instead as a pattern match, a substitution +or a translation. +.PP +Eval'ed strings are compiled in the package in which the eval was compiled +in. +(Assignments to $SIG{}, however, assume the signal handler specified is in the +main package. +Qualify the signal handler name if you wish to have a signal handler in +a package.) +For an example, examine perldb.pl in the perl library. +It initially switches to the DB package so that the debugger doesn't interfere +with variables in the script you are trying to debug. +At various points, however, it temporarily switches back to the main package +to evaluate various expressions in the context of the main package. +.PP +The symbol table for a package happens to be stored in the associative array +of that name prepended with an underscore. +The value in each entry of the associative array is +what you are referring to when you use the *name notation. +In fact, the following have the same effect (in package main, anyway), +though the first is more +efficient because it does the symbol table lookups at compile time: +.nf + +.ne 2 + local(*foo) = *bar; + local($_main{'foo'}) = $_main{'bar'}; + +.fi +You can use this to print out all the variables in a package, for instance. +Here is dumpvar.pl from the perl library: +.nf +.ne 11 + package dumpvar; + + sub main'dumpvar { + \& ($package) = @_; + \& local(*stab) = eval("*_$package"); + \& while (($key,$val) = each(%stab)) { + \& { + \& local(*entry) = $val; + \& if (defined $entry) { + \& print "\e$$key = '$entry'\en"; + \& } +.ne 7 + \& if (defined @entry) { + \& print "\e@$key = (\en"; + \& foreach $num ($[ .. $#entry) { + \& print " $num\et'",$entry[$num],"'\en"; + \& } + \& print ")\en"; + \& } +.ne 10 + \& if ($key ne "_$package" && defined %entry) { + \& print "\e%$key = (\en"; + \& foreach $key (sort keys(%entry)) { + \& print " $key\et'",$entry{$key},"'\en"; + \& } + \& print ")\en"; + \& } + \& } + \& } + } + +.fi +Note that, even though the subroutine is compiled in package dumpvar, the +name of the subroutine is qualified so that its name is inserted into package +\*(L"main\*(R". +.Sh "Style" +Each programmer will, of course, have his or her own preferences in regards +to formatting, but there are some general guidelines that will make your +programs easier to read. +.Ip 1. 4 4 +Just because you CAN do something a particular way doesn't mean that +you SHOULD do it that way. +.I Perl +is designed to give you several ways to do anything, so consider picking +the most readable one. +For instance + + open(FOO,$foo) || die "Can't open $foo: $!"; + +is better than + + die "Can't open $foo: $!" unless open(FOO,$foo); + +because the second way hides the main point of the statement in a +modifier. +On the other hand + + print "Starting analysis\en" if $verbose; + +is better than + + $verbose && print "Starting analysis\en"; + +since the main point isn't whether the user typed -v or not. +.Sp +Similarly, just because an operator lets you assume default arguments +doesn't mean that you have to make use of the defaults. +The defaults are there for lazy systems programmers writing one-shot +programs. +If you want your program to be readable, consider supplying the argument. +.Sp +Along the same lines, just because you +.I can +omit parentheses in many places doesn't mean that you ought to: +.nf + + return print reverse sort num values array; + return print(reverse(sort num (values(%array)))); + +.fi +When in doubt, parenthesize. +At the very least it will let some poor schmuck bounce on the % key in vi. +.Sp +Even if you aren't in doubt, consider the mental welfare of the person who +has to maintain the code after you, and who will probably put parens in +the wrong place. +.Ip 2. 4 4 +Don't go through silly contortions to exit a loop at the top or the +bottom, when +.I perl +provides the "last" operator so you can exit in the middle. +Just outdent it a little to make it more visible: +.nf + +.ne 7 + line: + for (;;) { + statements; + last line if $foo; + next line if /^#/; + statements; + } + +.fi +.Ip 3. 4 4 +Don't be afraid to use loop labels\*(--they're there to enhance readability as +well as to allow multi-level loop breaks. +See last example. +.Ip 4. 4 4 +For portability, when using features that may not be implemented on every +machine, test the construct in an eval to see if it fails. +If you know what version or patchlevel a particular feature was implemented, +you can test $] to see if it will be there. +.Ip 5. 4 4 +Choose mnemonic identifiers. +.Ip 6. 4 4 +Be consistent. +.Sh "Debugging" +If you invoke +.I perl +with a +.B \-d +switch, your script will be run under a debugging monitor. +It will halt before the first executable statement and ask you for a +command, such as: +.Ip "h" 12 4 +Prints out a help message. +.Ip "T" 12 4 +Stack trace. +.Ip "s" 12 4 +Single step. +Executes until it reaches the beginning of another statement. +.Ip "n" 12 4 +Next. +Executes over subroutine calls, until it reaches the beginning of the +next statement. +.Ip "f" 12 4 +Finish. +Executes statements until it has finished the current subroutine. +.Ip "c" 12 4 +Continue. +Executes until the next breakpoint is reached. +.Ip "c line" 12 4 +Continue to the specified line. +Inserts a one-time-only breakpoint at the specified line. +.Ip "" 12 4 +Repeat last n or s. +.Ip "l min+incr" 12 4 +List incr+1 lines starting at min. +If min is omitted, starts where last listing left off. +If incr is omitted, previous value of incr is used. +.Ip "l min-max" 12 4 +List lines in the indicated range. +.Ip "l line" 12 4 +List just the indicated line. +.Ip "l" 12 4 +List next window. +.Ip "-" 12 4 +List previous window. +.Ip "w line" 12 4 +List window around line. +.Ip "l subname" 12 4 +List subroutine. +If it's a long subroutine it just lists the beginning. +Use \*(L"l\*(R" to list more. +.Ip "/pattern/" 12 4 +Regular expression search forward for pattern; the final / is optional. +.Ip "?pattern?" 12 4 +Regular expression search backward for pattern; the final ? is optional. +.Ip "L" 12 4 +List lines that have breakpoints or actions. +.Ip "S" 12 4 +Lists the names of all subroutines. +.Ip "t" 12 4 +Toggle trace mode on or off. +.Ip "b line condition" 12 4 +Set a breakpoint. +If line is omitted, sets a breakpoint on the +line that is about to be executed. +If a condition is specified, it is evaluated each time the statement is +reached and a breakpoint is taken only if the condition is true. +Breakpoints may only be set on lines that begin an executable statement. +.Ip "b subname condition" 12 4 +Set breakpoint at first executable line of subroutine. +.Ip "d line" 12 4 +Delete breakpoint. +If line is omitted, deletes the breakpoint on the +line that is about to be executed. +.Ip "D" 12 4 +Delete all breakpoints. +.Ip "a line command" 12 4 +Set an action for line. +A multi-line command may be entered by backslashing the newlines. +.Ip "A" 12 4 +Delete all line actions. +.Ip "< command" 12 4 +Set an action to happen before every debugger prompt. +A multi-line command may be entered by backslashing the newlines. +.Ip "> command" 12 4 +Set an action to happen after the prompt when you've just given a command +to return to executing the script. +A multi-line command may be entered by backslashing the newlines. +.Ip "V package" 12 4 +List all variables in package. +Default is main package. +.Ip "! number" 12 4 +Redo a debugging command. +If number is omitted, redoes the previous command. +.Ip "! -number" 12 4 +Redo the command that was that many commands ago. +.Ip "H -number" 12 4 +Display last n commands. +Only commands longer than one character are listed. +If number is omitted, lists them all. +.Ip "q or ^D" 12 4 +Quit. +.Ip "command" 12 4 +Execute command as a perl statement. +A missing semicolon will be supplied. +.Ip "p expr" 12 4 +Same as \*(L"print DB'OUT expr\*(R". +The DB'OUT filehandle is opened to /dev/tty, regardless of where STDOUT +may be redirected to. +.PP +If you want to modify the debugger, copy perldb.pl from the perl library +to your current directory and modify it as necessary. +(You'll also have to put -I. on your command line.) +You can do some customization by setting up a .perldb file which contains +initialization code. +For instance, you could make aliases like these: +.nf + + $DB'alias{'len'} = 's/^len(.*)/p length($1)/'; + $DB'alias{'stop'} = 's/^stop (at|in)/b/'; + $DB'alias{'.'} = + 's/^\e./p "\e$DB\e'sub(\e$DB\e'line):\et",\e$DB\e'line[\e$DB\e'line]/'; + +.fi +.Sh "Setuid Scripts" +.I Perl +is designed to make it easy to write secure setuid and setgid scripts. +Unlike shells, which are based on multiple substitution passes on each line +of the script, +.I perl +uses a more conventional evaluation scheme with fewer hidden \*(L"gotchas\*(R". +Additionally, since the language has more built-in functionality, it +has to rely less upon external (and possibly untrustworthy) programs to +accomplish its purposes. +.PP +In an unpatched 4.2 or 4.3bsd kernel, setuid scripts are intrinsically +insecure, but this kernel feature can be disabled. +If it is, +.I perl +can emulate the setuid and setgid mechanism when it notices the otherwise +useless setuid/gid bits on perl scripts. +If the kernel feature isn't disabled, +.I perl +will complain loudly that your setuid script is insecure. +You'll need to either disable the kernel setuid script feature, or put +a C wrapper around the script. +.PP +When perl is executing a setuid script, it takes special precautions to +prevent you from falling into any obvious traps. +(In some ways, a perl script is more secure than the corresponding +C program.) +Any command line argument, environment variable, or input is marked as +\*(L"tainted\*(R", and may not be used, directly or indirectly, in any +command that invokes a subshell, or in any command that modifies files, +directories or processes. +Any variable that is set within an expression that has previously referenced +a tainted value also becomes tainted (even if it is logically impossible +for the tainted value to influence the variable). +For example: +.nf + +.ne 5 + $foo = shift; # $foo is tainted + $bar = $foo,\'bar\'; # $bar is also tainted + $xxx = <>; # Tainted + $path = $ENV{\'PATH\'}; # Tainted, but see below + $abc = \'abc\'; # Not tainted + +.ne 4 + system "echo $foo"; # Insecure + system "/bin/echo", $foo; # Secure (doesn't use sh) + system "echo $bar"; # Insecure + system "echo $abc"; # Insecure until PATH set + +.ne 5 + $ENV{\'PATH\'} = \'/bin:/usr/bin\'; + $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\'; + + $path = $ENV{\'PATH\'}; # Not tainted + system "echo $abc"; # Is secure now! + +.ne 5 + open(FOO,"$foo"); # OK + open(FOO,">$foo"); # Not OK + + open(FOO,"echo $foo|"); # Not OK, but... + open(FOO,"-|") || exec \'echo\', $foo; # OK + + $zzz = `echo $foo`; # Insecure, zzz tainted + + unlink $abc,$foo; # Insecure + umask $foo; # Insecure + +.ne 3 + exec "echo $foo"; # Insecure + exec "echo", $foo; # Secure (doesn't use sh) + exec "sh", \'-c\', $foo; # Considered secure, alas + +.fi +The taintedness is associated with each scalar value, so some elements +of an array can be tainted, and others not. +.PP +If you try to do something insecure, you will get a fatal error saying +something like \*(L"Insecure dependency\*(R" or \*(L"Insecure PATH\*(R". +Note that you can still write an insecure system call or exec, +but only by explicitly doing something like the last example above. +You can also bypass the tainting mechanism by referencing +subpatterns\*(--\c +.I perl +presumes that if you reference a substring using $1, $2, etc, you knew +what you were doing when you wrote the pattern: +.nf + + $ARGV[0] =~ /^\-P(\ew+)$/; + $printer = $1; # Not tainted + +.fi +This is fairly secure since \ew+ doesn't match shell metacharacters. +Use of .+ would have been insecure, but +.I perl +doesn't check for that, so you must be careful with your patterns. +This is the ONLY mechanism for untainting user supplied filenames if you +want to do file operations on them (unless you make $> equal to $<). +.PP +It's also possible to get into trouble with other operations that don't care +whether they use tainted values. +Make judicious use of the file tests in dealing with any user-supplied +filenames. +When possible, do opens and such after setting $> = $<. +.I Perl +doesn't prevent you from opening tainted filenames for reading, so be +careful what you print out. +The tainting mechanism is intended to prevent stupid mistakes, not to remove +the need for thought. +.SH ENVIRONMENT +.Ip HOME 12 4 +Used if chdir has no argument. +.Ip LOGDIR 12 4 +Used if chdir has no argument and HOME is not set. +.Ip PATH 12 4 +Used in executing subprocesses, and in finding the script if \-S +is used. +.Ip PERLLIB 12 4 +A colon-separated list of directories in which to look for Perl library +files before looking in the standard library and the current directory. +.Ip PERLDB 12 4 +The command used to get the debugger code. If unset, uses +.br + + require 'perldb.pl' + +.PP +Apart from these, +.I perl +uses no other environment variables, except to make them available +to the script being executed, and to child processes. +However, scripts running setuid would do well to execute the following lines +before doing anything else, just to keep people honest: +.nf + +.ne 3 + $ENV{\'PATH\'} = \'/bin:/usr/bin\'; # or whatever you need + $ENV{\'SHELL\'} = \'/bin/sh\' if $ENV{\'SHELL\'} ne \'\'; + $ENV{\'IFS\'} = \'\' if $ENV{\'IFS\'} ne \'\'; + +.fi +.SH AUTHOR +Larry Wall +.br +MS-DOS port by Diomidis Spinellis +.SH FILES +/tmp/perl\-eXXXXXX temporary file for +.B \-e +commands. +.SH SEE ALSO +a2p awk to perl translator +.br +s2p sed to perl translator +.SH DIAGNOSTICS +Compilation errors will tell you the line number of the error, with an +indication of the next token or token type that was to be examined. +(In the case of a script passed to +.I perl +via +.B \-e +switches, each +.B \-e +is counted as one line.) +.PP +Setuid scripts have additional constraints that can produce error messages +such as \*(L"Insecure dependency\*(R". +See the section on setuid scripts. +.SH TRAPS +Accustomed +.IR awk +users should take special note of the following: +.Ip * 4 2 +Semicolons are required after all simple statements in +.I perl +(except at the end of a block). +Newline is not a statement delimiter. +.Ip * 4 2 +Curly brackets are required on ifs and whiles. +.Ip * 4 2 +Variables begin with $ or @ in +.IR perl . +.Ip * 4 2 +Arrays index from 0 unless you set $[. +Likewise string positions in substr() and index(). +.Ip * 4 2 +You have to decide whether your array has numeric or string indices. +.Ip * 4 2 +Associative array values do not spring into existence upon mere reference. +.Ip * 4 2 +You have to decide whether you want to use string or numeric comparisons. +.Ip * 4 2 +Reading an input line does not split it for you. You get to split it yourself +to an array. +And the +.I split +operator has different arguments. +.Ip * 4 2 +The current input line is normally in $_, not $0. +It generally does not have the newline stripped. +($0 is the name of the program executed.) +.Ip * 4 2 +$ does not refer to fields\*(--it refers to substrings matched by the last +match pattern. +.Ip * 4 2 +The +.I print +statement does not add field and record separators unless you set +$, and $\e. +.Ip * 4 2 +You must open your files before you print to them. +.Ip * 4 2 +The range operator is \*(L".\|.\*(R", not comma. +(The comma operator works as in C.) +.Ip * 4 2 +The match operator is \*(L"=~\*(R", not \*(L"~\*(R". +(\*(L"~\*(R" is the one's complement operator, as in C.) +.Ip * 4 2 +The exponentiation operator is \*(L"**\*(R", not \*(L"^\*(R". +(\*(L"^\*(R" is the XOR operator, as in C.) +.Ip * 4 2 +The concatenation operator is \*(L".\*(R", not the null string. +(Using the null string would render \*(L"/pat/ /pat/\*(R" unparsable, +since the third slash would be interpreted as a division operator\*(--the +tokener is in fact slightly context sensitive for operators like /, ?, and <. +And in fact, . itself can be the beginning of a number.) +.Ip * 4 2 +.IR Next , +.I exit +and +.I continue +work differently. +.Ip * 4 2 +The following variables work differently +.nf + + Awk \h'|2.5i'Perl + ARGC \h'|2.5i'$#ARGV + ARGV[0] \h'|2.5i'$0 + FILENAME\h'|2.5i'$ARGV + FNR \h'|2.5i'$. \- something + FS \h'|2.5i'(whatever you like) + NF \h'|2.5i'$#Fld, or some such + NR \h'|2.5i'$. + OFMT \h'|2.5i'$# + OFS \h'|2.5i'$, + ORS \h'|2.5i'$\e + RLENGTH \h'|2.5i'length($&) + RS \h'|2.5i'$/ + RSTART \h'|2.5i'length($\`) + SUBSEP \h'|2.5i'$; + +.fi +.Ip * 4 2 +When in doubt, run the +.I awk +construct through a2p and see what it gives you. +.PP +Cerebral C programmers should take note of the following: +.Ip * 4 2 +Curly brackets are required on ifs and whiles. +.Ip * 4 2 +You should use \*(L"elsif\*(R" rather than \*(L"else if\*(R" +.Ip * 4 2 +.I Break +and +.I continue +become +.I last +and +.IR next , +respectively. +.Ip * 4 2 +There's no switch statement. +.Ip * 4 2 +Variables begin with $ or @ in +.IR perl . +.Ip * 4 2 +Printf does not implement *. +.Ip * 4 2 +Comments begin with #, not /*. +.Ip * 4 2 +You can't take the address of anything. +.Ip * 4 2 +ARGV must be capitalized. +.Ip * 4 2 +The \*(L"system\*(R" calls link, unlink, rename, etc. return nonzero for success, not 0. +.Ip * 4 2 +Signal handlers deal with signal names, not numbers. +.PP +Seasoned +.I sed +programmers should take note of the following: +.Ip * 4 2 +Backreferences in substitutions use $ rather than \e. +.Ip * 4 2 +The pattern matching metacharacters (, ), and | do not have backslashes in front. +.Ip * 4 2 +The range operator is .\|. rather than comma. +.PP +Sharp shell programmers should take note of the following: +.Ip * 4 2 +The backtick operator does variable interpretation without regard to the +presence of single quotes in the command. +.Ip * 4 2 +The backtick operator does no translation of the return value, unlike csh. +.Ip * 4 2 +Shells (especially csh) do several levels of substitution on each command line. +.I Perl +does substitution only in certain constructs such as double quotes, +backticks, angle brackets and search patterns. +.Ip * 4 2 +Shells interpret scripts a little bit at a time. +.I Perl +compiles the whole program before executing it. +.Ip * 4 2 +The arguments are available via @ARGV, not $1, $2, etc. +.Ip * 4 2 +The environment is not automatically made available as variables. +.SH ERRATA\0AND\0ADDENDA +The Perl book, +.I Programming\0Perl , +has the following omissions and goofs. +.PP +On page 5, the examples which read +.nf + + eval "/usr/bin/perl + +should read + + eval "exec /usr/bin/perl + +.fi +.PP +On page 195, the equivalent to the System V sum program only works for +very small files. To do larger files, use +.nf + + undef $/; + $checksum = unpack("%32C*",<>) % 32767; + +.fi +.PP +The descriptions of alarm and sleep refer to signal SIGALARM. These +should refer to SIGALRM. +.PP +The +.B \-0 +switch to set the initial value of $/ was added to Perl after the book +went to press. +.PP +The +.B \-l +switch now does automatic line ending processing. +.PP +The qx// construct is now a synonym for backticks. +.PP +$0 may now be assigned to set the argument displayed by +.I ps (1). +.PP +The new @###.## format was omitted accidentally from the description +on formats. +.PP +It wasn't known at press time that s///ee caused multiple evaluations of +the replacement expression. This is to be construed as a feature. +.PP +(LIST) x $count now does array replication. +.PP +There is now no limit on the number of parentheses in a regular expression. +.PP +In double-quote context, more escapes are supported: \ee, \ea, \ex1b, \ec[, +\el, \eL, \eu, \eU, \eE. The latter five control up/lower case translation. +.PP +The +.B $/ +variable may now be set to a multi-character delimiter. +.PP +There is now a g modifier on ordinary pattern matching that causes it +to iterate through a string finding multiple matches. +.PP +All of the $^X variables are new except for $^T. +.PP +The default top-of-form format for FILEHANDLE is now FILEHANDLE_TOP rather +than top. +.PP +The eval {} and sort {} constructs were added in version 4.018. +.PP +The v and V (little-endian) template options for pack and unpack were +added in 4.019. +.SH BUGS +.PP +.I Perl +is at the mercy of your machine's definitions of various operations +such as type casting, atof() and sprintf(). +.PP +If your stdio requires an seek or eof between reads and writes on a particular +stream, so does +.IR perl . +(This doesn't apply to sysread() and syswrite().) +.PP +While none of the built-in data types have any arbitrary size limits (apart +from memory size), there are still a few arbitrary limits: +a given identifier may not be longer than 255 characters, +and no component of your PATH may be longer than 255 if you use \-S. +A regular expression may not compile to more than 32767 bytes internally. +.PP +.I Perl +actually stands for Pathologically Eclectic Rubbish Lister, but don't tell +anyone I said that. +.rn }` '' diff --git a/gnu/usr.bin/perl/perl/perl.c b/gnu/usr.bin/perl/perl/perl.c new file mode 100644 index 0000000..a963db8 --- /dev/null +++ b/gnu/usr.bin/perl/perl/perl.c @@ -0,0 +1,1449 @@ +char rcsid[] = "$RCSfile: perl.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:37 $\nPatch level: ###\n"; +/* + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: perl.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:37 nate + * PERL! + * + * Revision 4.0.1.8 1993/02/05 19:39:30 lwall + * patch36: the taintanyway code wasn't tainting anyway + * patch36: Malformed cmd links core dump apparently fixed + * + * Revision 4.0.1.7 92/06/08 14:50:39 lwall + * patch20: PERLLIB now supports multiple directories + * patch20: running taintperl explicitly now does checks even if $< == $> + * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space + * patch20: perl -P now uses location of sed determined by Configure + * patch20: form feed for formats is now specifiable via $^L + * patch20: paragraph mode now skips extra newlines automatically + * patch20: eval "1 #comment" didn't work + * patch20: couldn't require . files + * patch20: semantic compilation errors didn't abort execution + * + * Revision 4.0.1.6 91/11/11 16:38:45 lwall + * patch19: default arg for shift was wrong after first subroutine definition + * patch19: op/regexp.t failed from missing arg to bcmp() + * + * Revision 4.0.1.5 91/11/05 18:03:32 lwall + * patch11: random cleanup + * patch11: $0 was being truncated at times + * patch11: cppstdin now installed outside of source directory + * patch11: -P didn't allow use of #elif or #undef + * patch11: prepared for ctype implementations that don't define isascii() + * patch11: added eval {} + * patch11: eval confused by string containing null + * + * Revision 4.0.1.4 91/06/10 01:23:07 lwall + * patch10: perl -v printed incorrect copyright notice + * + * Revision 4.0.1.3 91/06/07 11:40:18 lwall + * patch4: changed old $^P to $^X + * + * Revision 4.0.1.2 91/06/07 11:26:16 lwall + * patch4: new copyright notice + * patch4: added $^P variable to control calling of perldb routines + * patch4: added $^F variable to specify maximum system fd, default 2 + * patch4: debugger lost track of lines in eval + * + * Revision 4.0.1.1 91/04/11 17:49:05 lwall + * patch1: fixed undefined environ problem + * + * Revision 4.0 91/03/20 01:37:44 lwall + * 4.0 baseline. + * + */ + +/*SUPPRESS 560*/ + +#include "EXTERN.h" +#include "perl.h" +#include "perly.h" +#include "patchlevel.h" + +char *getenv(); + +#ifdef IAMSUID +#ifndef DOSUID +#define DOSUID +#endif +#endif + +#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW +#ifdef DOSUID +#undef DOSUID +#endif +#endif + +static char* moreswitches(); +static void incpush(); +static char* cddir; +static bool minus_c; +static char patchlevel[6]; +static char *nrs = "\n"; +static int nrschar = '\n'; /* final char of rs, or 0777 if none */ +static int nrslen = 1; + +main(argc,argv,env) +register int argc; +register char **argv; +register char **env; +{ + register STR *str; + register char *s; + char *scriptname; + char *getenv(); + bool dosearch = FALSE; +#ifdef DOSUID + char *validarg = ""; +#endif + +#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW +#ifdef IAMSUID +#undef IAMSUID + fatal("suidperl is no longer needed since the kernel can now execute\n\ +setuid perl scripts securely.\n"); +#endif +#endif + + origargv = argv; + origargc = argc; + origenviron = environ; + uid = (int)getuid(); + euid = (int)geteuid(); + gid = (int)getgid(); + egid = (int)getegid(); + sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL); +#ifdef MSDOS + /* + * There is no way we can refer to them from Perl so close them to save + * space. The other alternative would be to provide STDAUX and STDPRN + * filehandles. + */ + (void)fclose(stdaux); + (void)fclose(stdprn); +#endif + if (do_undump) { + origfilename = savestr(argv[0]); + do_undump = 0; + loop_ptr = -1; /* start label stack again */ + goto just_doit; + } +#ifdef TAINT +#ifndef DOSUID + if (uid == euid && gid == egid) + taintanyway = TRUE; /* running taintperl explicitly */ +#endif +#endif + (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL); + linestr = Str_new(65,80); + str_nset(linestr,"",0); + str = str_make("",0); /* first used for -I flags */ + curstash = defstash = hnew(0); + curstname = str_make("main",4); + stab_xhash(stabent("_main",TRUE)) = defstash; + defstash->tbl_name = "main"; + incstab = hadd(aadd(stabent("INC",TRUE))); + incstab->str_pok |= SP_MULTI; + for (argc--,argv++; argc > 0; argc--,argv++) { + if (argv[0][0] != '-' || !argv[0][1]) + break; +#ifdef DOSUID + if (*validarg) + validarg = " PHOOEY "; + else + validarg = argv[0]; +#endif + s = argv[0]+1; + reswitch: + switch (*s) { + case '0': + case 'a': + case 'c': + case 'd': + case 'D': + case 'i': + case 'l': + case 'n': + case 'p': + case 'u': + case 'U': + case 'v': + case 'w': + if (s = moreswitches(s)) + goto reswitch; + break; + + case 'e': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -e allowed in setuid scripts"); +#endif + if (!e_fp) { + e_tmpname = savestr(TMPPATH); + (void)mktemp(e_tmpname); + if (!*e_tmpname) + fatal("Can't mktemp()"); + e_fp = fopen(e_tmpname,"w"); + if (!e_fp) + fatal("Cannot open temporary file"); + } + if (argv[1]) { + fputs(argv[1],e_fp); + argc--,argv++; + } + (void)putc('\n', e_fp); + break; + case 'I': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -I allowed in setuid scripts"); +#endif + str_cat(str,"-"); + str_cat(str,s); + str_cat(str," "); + if (*++s) { + (void)apush(stab_array(incstab),str_make(s,0)); + } + else if (argv[1]) { + (void)apush(stab_array(incstab),str_make(argv[1],0)); + str_cat(str,argv[1]); + argc--,argv++; + str_cat(str," "); + } + break; + case 'P': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -P allowed in setuid scripts"); +#endif + preprocess = TRUE; + s++; + goto reswitch; + case 's': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -s allowed in setuid scripts"); +#endif + doswitches = TRUE; + s++; + goto reswitch; + case 'S': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -S allowed in setuid scripts"); +#endif + dosearch = TRUE; + s++; + goto reswitch; + case 'x': + doextract = TRUE; + s++; + if (*s) + cddir = savestr(s); + break; + case '-': + argc--,argv++; + goto switch_end; + case 0: + break; + default: + fatal("Unrecognized switch: -%s",s); + } + } + switch_end: + scriptname = argv[0]; + if (e_fp) { + if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) + fatal("Can't write to temp file for -e: %s", strerror(errno)); + argc++,argv--; + scriptname = e_tmpname; + } + +#ifdef DOSISH +#define PERLLIB_SEP ';' +#else +#define PERLLIB_SEP ':' +#endif +#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */ + incpush(getenv("PERLLIB")); +#endif /* TAINT */ + +#ifndef PRIVLIB +#define PRIVLIB "/usr/local/lib/perl" +#endif + incpush(PRIVLIB); + (void)apush(stab_array(incstab),str_make(".",1)); + + str_set(&str_no,No); + str_set(&str_yes,Yes); + + /* open script */ + + if (scriptname == Nullch) +#ifdef MSDOS + { + if ( isatty(fileno(stdin)) ) + moreswitches("v"); + scriptname = "-"; + } +#else + scriptname = "-"; +#endif + if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) { + char *xfound = Nullch, *xfailed = Nullch; + int len; + + bufend = s + strlen(s); + while (*s) { +#ifndef DOSISH + s = cpytill(tokenbuf,s,bufend,':',&len); +#else +#ifdef atarist + for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++); + tokenbuf[len] = '\0'; +#else + for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++); + tokenbuf[len] = '\0'; +#endif +#endif + if (*s) + s++; +#ifndef DOSISH + if (len && tokenbuf[len-1] != '/') +#else +#ifdef atarist + if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/'))) +#else + if (len && tokenbuf[len-1] != '\\') +#endif +#endif + (void)strcat(tokenbuf+len,"/"); + (void)strcat(tokenbuf+len,scriptname); +#ifdef DEBUGGING + if (debug & 1) + fprintf(stderr,"Looking for %s\n",tokenbuf); +#endif + if (stat(tokenbuf,&statbuf) < 0) /* not there? */ + continue; + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) { + xfound = tokenbuf; /* bingo! */ + break; + } + if (!xfailed) + xfailed = savestr(tokenbuf); + } + if (!xfound) + fatal("Can't execute %s", xfailed ? xfailed : scriptname ); + if (xfailed) + Safefree(xfailed); + scriptname = savestr(xfound); + } + + fdpid = anew(Nullstab); /* for remembering popen pids by fd */ + pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */ + + origfilename = savestr(scriptname); + curcmd->c_filestab = fstab(origfilename); + if (strEQ(origfilename,"-")) + scriptname = ""; + if (preprocess) { + char *cpp = CPPSTDIN; + + if (strEQ(cpp,"cppstdin")) + sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp); + else + sprintf(tokenbuf, "%s", cpp); + str_cat(str,"-I"); + str_cat(str,PRIVLIB); +#ifdef MSDOS + (void)sprintf(buf, "\ +sed %s -e \"/^[^#]/b\" \ + -e \"/^#[ ]*include[ ]/b\" \ + -e \"/^#[ ]*define[ ]/b\" \ + -e \"/^#[ ]*if[ ]/b\" \ + -e \"/^#[ ]*ifdef[ ]/b\" \ + -e \"/^#[ ]*ifndef[ ]/b\" \ + -e \"/^#[ ]*else/b\" \ + -e \"/^#[ ]*elif[ ]/b\" \ + -e \"/^#[ ]*undef[ ]/b\" \ + -e \"/^#[ ]*endif/b\" \ + -e \"s/^#.*//\" \ + %s | %s -C %s %s", + (doextract ? "-e \"1,/^#/d\n\"" : ""), +#else + (void)sprintf(buf, "\ +%s %s -e '/^[^#]/b' \ + -e '/^#[ ]*include[ ]/b' \ + -e '/^#[ ]*define[ ]/b' \ + -e '/^#[ ]*if[ ]/b' \ + -e '/^#[ ]*ifdef[ ]/b' \ + -e '/^#[ ]*ifndef[ ]/b' \ + -e '/^#[ ]*else/b' \ + -e '/^#[ ]*elif[ ]/b' \ + -e '/^#[ ]*undef[ ]/b' \ + -e '/^#[ ]*endif/b' \ + -e 's/^[ ]*#.*//' \ + %s | %s -C %s %s", +#ifdef LOC_SED + LOC_SED, +#else + "sed", +#endif + (doextract ? "-e '1,/^#/d\n'" : ""), +#endif + scriptname, tokenbuf, str_get(str), CPPMINUS); +#ifdef DEBUGGING + if (debug & 64) { + fputs(buf,stderr); + fputs("\n",stderr); + } +#endif + doextract = FALSE; +#ifdef IAMSUID /* actually, this is caught earlier */ + if (euid != uid && !euid) { /* if running suidperl */ +#ifdef HAS_SETEUID + (void)seteuid(uid); /* musn't stay setuid root */ +#else +#ifdef HAS_SETREUID + (void)setreuid(-1, uid); +#else + setuid(uid); +#endif +#endif + if (geteuid() != uid) + fatal("Can't do seteuid!\n"); + } +#endif /* IAMSUID */ + rsfp = mypopen(buf,"r"); + } + else if (!*scriptname) { +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("Can't take set-id script from stdin"); +#endif + rsfp = stdin; + } + else + rsfp = fopen(scriptname,"r"); + if ((FILE*)rsfp == Nullfp) { +#ifdef DOSUID +#ifndef IAMSUID /* in case script is not readable before setuid */ + if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 && + statbuf.st_mode & (S_ISUID|S_ISGID)) { + (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); + execv(buf, origargv); /* try again */ + fatal("Can't do setuid\n"); + } +#endif +#endif + fatal("Can't open perl script \"%s\": %s\n", + stab_val(curcmd->c_filestab)->str_ptr, strerror(errno)); + } + str_free(str); /* free -I directories */ + str = Nullstr; + + /* do we need to emulate setuid on scripts? */ + + /* This code is for those BSD systems that have setuid #! scripts disabled + * in the kernel because of a security problem. Merely defining DOSUID + * in perl will not fix that problem, but if you have disabled setuid + * scripts in the kernel, this will attempt to emulate setuid and setgid + * on scripts that have those now-otherwise-useless bits set. The setuid + * root version must be called suidperl or sperlN.NNN. If regular perl + * discovers that it has opened a setuid script, it calls suidperl with + * the same argv that it had. If suidperl finds that the script it has + * just opened is NOT setuid root, it sets the effective uid back to the + * uid. We don't just make perl setuid root because that loses the + * effective uid we had before invoking perl, if it was different from the + * uid. + * + * DOSUID must be defined in both perl and suidperl, and IAMSUID must + * be defined in suidperl only. suidperl must be setuid root. The + * Configure script will set this up for you if you want it. + * + * There is also the possibility of have a script which is running + * set-id due to a C wrapper. We want to do the TAINT checks + * on these set-id scripts, but don't want to have the overhead of + * them in normal perl, and can't use suidperl because it will lose + * the effective uid info, so we have an additional non-setuid root + * version called taintperl or tperlN.NNN that just does the TAINT checks. + */ + +#ifdef DOSUID + if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ + fatal("Can't stat script \"%s\"",origfilename); + if (statbuf.st_mode & (S_ISUID|S_ISGID)) { + int len; + +#ifdef IAMSUID +#ifndef HAS_SETREUID + /* On this access check to make sure the directories are readable, + * there is actually a small window that the user could use to make + * filename point to an accessible directory. So there is a faint + * chance that someone could execute a setuid script down in a + * non-accessible directory. I don't know what to do about that. + * But I don't think it's too important. The manual lies when + * it says access() is useful in setuid programs. + */ + if (access(stab_val(curcmd->c_filestab)->str_ptr,1)) /*double check*/ + fatal("Permission denied"); +#else + /* If we can swap euid and uid, then we can determine access rights + * with a simple stat of the file, and then compare device and + * inode to make sure we did stat() on the same file we opened. + * Then we just have to make sure he or she can execute it. + */ + { + struct stat tmpstatbuf; + + if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid) + fatal("Can't swap uid and euid"); /* really paranoid */ + if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0) + fatal("Permission denied"); /* testing full pathname here */ + if (tmpstatbuf.st_dev != statbuf.st_dev || + tmpstatbuf.st_ino != statbuf.st_ino) { + (void)fclose(rsfp); + if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */ + fprintf(rsfp, +"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\ +(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n", + uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino, + statbuf.st_dev, statbuf.st_ino, + stab_val(curcmd->c_filestab)->str_ptr, + statbuf.st_uid, statbuf.st_gid); + (void)mypclose(rsfp); + } + fatal("Permission denied\n"); + } + if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid) + fatal("Can't reswap uid and euid"); + if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */ + fatal("Permission denied\n"); + } +#endif /* HAS_SETREUID */ +#endif /* IAMSUID */ + + if (!S_ISREG(statbuf.st_mode)) + fatal("Permission denied"); + if (statbuf.st_mode & S_IWOTH) + fatal("Setuid/gid script is writable by world"); + doswitches = FALSE; /* -s is insecure in suid */ + curcmd->c_line++; + if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch || + strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */ + fatal("No #! line"); + s = tokenbuf+2; + if (*s == ' ') s++; + while (!isSPACE(*s)) s++; + if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ + fatal("Not a perl script"); + while (*s == ' ' || *s == '\t') s++; + /* + * #! arg must be what we saw above. They can invoke it by + * mentioning suidperl explicitly, but they may not add any strange + * arguments beyond what #! says if they do invoke suidperl that way. + */ + len = strlen(validarg); + if (strEQ(validarg," PHOOEY ") || + strnNE(s,validarg,len) || !isSPACE(s[len])) + fatal("Args must match #! line"); + +#ifndef IAMSUID + if (euid != uid && (statbuf.st_mode & S_ISUID) && + euid == statbuf.st_uid) + if (!do_undump) + fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ +FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); +#endif /* IAMSUID */ + + if (euid) { /* oops, we're not the setuid root perl */ + (void)fclose(rsfp); +#ifndef IAMSUID + (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); + execv(buf, origargv); /* try again */ +#endif + fatal("Can't do setuid\n"); + } + + if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) { +#ifdef HAS_SETEGID + (void)setegid(statbuf.st_gid); +#else +#ifdef HAS_SETREGID + (void)setregid((GIDTYPE)-1,statbuf.st_gid); +#else + setgid(statbuf.st_gid); +#endif +#endif + if (getegid() != statbuf.st_gid) + fatal("Can't do setegid!\n"); + } + if (statbuf.st_mode & S_ISUID) { + if (statbuf.st_uid != euid) +#ifdef HAS_SETEUID + (void)seteuid(statbuf.st_uid); /* all that for this */ +#else +#ifdef HAS_SETREUID + (void)setreuid((UIDTYPE)-1,statbuf.st_uid); +#else + setuid(statbuf.st_uid); +#endif +#endif + if (geteuid() != statbuf.st_uid) + fatal("Can't do seteuid!\n"); + } + else if (uid) { /* oops, mustn't run as root */ +#ifdef HAS_SETEUID + (void)seteuid((UIDTYPE)uid); +#else +#ifdef HAS_SETREUID + (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid); +#else + setuid((UIDTYPE)uid); +#endif +#endif + if (geteuid() != uid) + fatal("Can't do seteuid!\n"); + } + uid = (int)getuid(); + euid = (int)geteuid(); + gid = (int)getgid(); + egid = (int)getegid(); + if (!cando(S_IXUSR,TRUE,&statbuf)) + fatal("Permission denied\n"); /* they can't do this */ + } +#ifdef IAMSUID + else if (preprocess) + fatal("-P not allowed for setuid/setgid script\n"); + else + fatal("Script is not setuid/setgid in suidperl\n"); +#else +#ifndef TAINT /* we aren't taintperl or suidperl */ + /* script has a wrapper--can't run suidperl or we lose euid */ + else if (euid != uid || egid != gid) { + (void)fclose(rsfp); + (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); + execv(buf, origargv); /* try again */ + fatal("Can't run setuid script with taint checks"); + } +#endif /* TAINT */ +#endif /* IAMSUID */ +#else /* !DOSUID */ +#ifndef TAINT /* we aren't taintperl or suidperl */ + if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ +#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW + fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ + if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) + || + (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) + ) + if (!do_undump) + fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ +FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); +#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ + /* not set-id, must be wrapped */ + (void)fclose(rsfp); + (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); + execv(buf, origargv); /* try again */ + fatal("Can't run setuid script with taint checks"); + } +#endif /* TAINT */ +#endif /* DOSUID */ + +#if !defined(IAMSUID) && !defined(TAINT) + + /* skip forward in input to the real script? */ + + while (doextract) { + if ((s = str_gets(linestr, rsfp, 0)) == Nullch) + fatal("No Perl script found in input\n"); + if (*s == '#' && s[1] == '!' && instr(s,"perl")) { + ungetc('\n',rsfp); /* to keep line count right */ + doextract = FALSE; + if (s = instr(s,"perl -")) { + s += 6; + /*SUPPRESS 530*/ + while (s = moreswitches(s)) ; + } + if (cddir && chdir(cddir) < 0) + fatal("Can't chdir to %s",cddir); + } + } +#endif /* !defined(IAMSUID) && !defined(TAINT) */ + + defstab = stabent("_",TRUE); + + subname = str_make("main",4); + if (perldb) { + debstash = hnew(0); + stab_xhash(stabent("_DB",TRUE)) = debstash; + curstash = debstash; + dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE)))); + tmpstab->str_pok |= SP_MULTI; + dbargs->ary_flags = 0; + DBstab = stabent("DB",TRUE); + DBstab->str_pok |= SP_MULTI; + DBline = stabent("dbline",TRUE); + DBline->str_pok |= SP_MULTI; + DBsub = hadd(tmpstab = stabent("sub",TRUE)); + tmpstab->str_pok |= SP_MULTI; + DBsingle = stab_val((tmpstab = stabent("single",TRUE))); + tmpstab->str_pok |= SP_MULTI; + DBtrace = stab_val((tmpstab = stabent("trace",TRUE))); + tmpstab->str_pok |= SP_MULTI; + DBsignal = stab_val((tmpstab = stabent("signal",TRUE))); + tmpstab->str_pok |= SP_MULTI; + curstash = defstash; + } + + /* init tokener */ + + bufend = bufptr = str_get(linestr); + + savestack = anew(Nullstab); /* for saving non-local values */ + stack = anew(Nullstab); /* for saving non-local values */ + stack->ary_flags = 0; /* not a real array */ + afill(stack,63); afill(stack,-1); /* preextend stack */ + afill(savestack,63); afill(savestack,-1); + + /* now parse the script */ + + error_count = 0; + if (yyparse() || error_count) { + if (minus_c) + fatal("%s had compilation errors.\n", origfilename); + else { + fatal("Execution of %s aborted due to compilation errors.\n", + origfilename); + } + } + + New(50,loop_stack,128,struct loop); +#ifdef DEBUGGING + if (debug) { + New(51,debname,128,char); + New(52,debdelim,128,char); + } +#endif + curstash = defstash; + + preprocess = FALSE; + if (e_fp) { + e_fp = Nullfp; + (void)UNLINK(e_tmpname); + } + + /* initialize everything that won't change if we undump */ + + if (sigstab = stabent("SIG",allstabs)) { + sigstab->str_pok |= SP_MULTI; + (void)hadd(sigstab); + } + + magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006"); + userinit(); /* in case linked C routines want magical variables */ + + amperstab = stabent("&",allstabs); + leftstab = stabent("`",allstabs); + rightstab = stabent("'",allstabs); + sawampersand = (amperstab || leftstab || rightstab); + if (tmpstab = stabent(":",allstabs)) + str_set(stab_val(tmpstab),chopset); + if (tmpstab = stabent("\024",allstabs)) + time(&basetime); + + /* these aren't necessarily magical */ + if (tmpstab = stabent("\014",allstabs)) { + str_set(stab_val(tmpstab),"\f"); + formfeed = stab_val(tmpstab); + } + if (tmpstab = stabent(";",allstabs)) + str_set(STAB_STR(tmpstab),"\034"); + if (tmpstab = stabent("]",allstabs)) { + str = STAB_STR(tmpstab); + str_set(str,rcsid); + str->str_u.str_nval = atof(patchlevel); + str->str_nok = 1; + } + str_nset(stab_val(stabent("\"", TRUE)), " ", 1); + + stdinstab = stabent("STDIN",TRUE); + stdinstab->str_pok |= SP_MULTI; + if (!stab_io(stdinstab)) + stab_io(stdinstab) = stio_new(); + stab_io(stdinstab)->ifp = stdin; + tmpstab = stabent("stdin",TRUE); + stab_io(tmpstab) = stab_io(stdinstab); + tmpstab->str_pok |= SP_MULTI; + + tmpstab = stabent("STDOUT",TRUE); + tmpstab->str_pok |= SP_MULTI; + if (!stab_io(tmpstab)) + stab_io(tmpstab) = stio_new(); + stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout; + defoutstab = tmpstab; + tmpstab = stabent("stdout",TRUE); + stab_io(tmpstab) = stab_io(defoutstab); + tmpstab->str_pok |= SP_MULTI; + + curoutstab = stabent("STDERR",TRUE); + curoutstab->str_pok |= SP_MULTI; + if (!stab_io(curoutstab)) + stab_io(curoutstab) = stio_new(); + stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr; + tmpstab = stabent("stderr",TRUE); + stab_io(tmpstab) = stab_io(curoutstab); + tmpstab->str_pok |= SP_MULTI; + curoutstab = defoutstab; /* switch back to STDOUT */ + + statname = Str_new(66,0); /* last filename we did stat on */ + + /* now that script is parsed, we can modify record separator */ + + rs = nrs; + rslen = nrslen; + rschar = nrschar; + rspara = (nrslen == 2); + str_nset(stab_val(stabent("/", TRUE)), rs, rslen); + + if (do_undump) + my_unexec(); + + just_doit: /* come here if running an undumped a.out */ + argc--,argv++; /* skip name of script */ + if (doswitches) { + for (; argc > 0 && **argv == '-'; argc--,argv++) { + if (argv[0][1] == '-') { + argc--,argv++; + break; + } + if (s = index(argv[0], '=')) { + *s++ = '\0'; + str_set(stab_val(stabent(argv[0]+1,TRUE)),s); + } + else + str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0); + } + } +#ifdef TAINT + tainted = 1; +#endif + if (tmpstab = stabent("0",allstabs)) { + str_set(stab_val(tmpstab),origfilename); + magicname("0", Nullch, 0); + } + if (tmpstab = stabent("\030",allstabs)) + str_set(stab_val(tmpstab),origargv[0]); + if (argvstab = stabent("ARGV",allstabs)) { + argvstab->str_pok |= SP_MULTI; + (void)aadd(argvstab); + aclear(stab_array(argvstab)); + for (; argc > 0; argc--,argv++) { + (void)apush(stab_array(argvstab),str_make(argv[0],0)); + } + } +#ifdef TAINT + (void) stabent("ENV",TRUE); /* must test PATH and IFS */ +#endif + if (envstab = stabent("ENV",allstabs)) { + envstab->str_pok |= SP_MULTI; + (void)hadd(envstab); + hclear(stab_hash(envstab), FALSE); + if (env != environ) + environ[0] = Nullch; + for (; *env; env++) { + if (!(s = index(*env,'='))) + continue; + *s++ = '\0'; + str = str_make(s--,0); + str_magic(str, envstab, 'E', *env, s - *env); + (void)hstore(stab_hash(envstab), *env, s - *env, str, 0); + *s = '='; + } + } +#ifdef TAINT + tainted = 0; +#endif + if (tmpstab = stabent("$",allstabs)) + str_numset(STAB_STR(tmpstab),(double)getpid()); + + if (dowarn) { + stab_check('A','Z'); + stab_check('a','z'); + } + + if (setjmp(top_env)) /* sets goto_targ on longjump */ + loop_ptr = -1; /* start label stack again */ + +#ifdef DEBUGGING + if (debug & 1024) + dump_all(); + if (debug) + fprintf(stderr,"\nEXECUTING...\n\n"); +#endif + + if (minus_c) { + fprintf(stderr,"%s syntax OK\n", origfilename); + exit(0); + } + + /* do it */ + + (void) cmd_exec(main_root,G_SCALAR,-1); + + if (goto_targ) + fatal("Can't find label \"%s\"--aborting",goto_targ); + exit(0); + /* NOTREACHED */ +} + +void +magicalize(list) +register char *list; +{ + char sym[2]; + + sym[1] = '\0'; + while (*sym = *list++) + magicname(sym, Nullch, 0); +} + +void +magicname(sym,name,namlen) +char *sym; +char *name; +int namlen; +{ + register STAB *stab; + + if (stab = stabent(sym,allstabs)) { + stab_flags(stab) = SF_VMAGIC; + str_magic(stab_val(stab), stab, 0, name, namlen); + } +} + +static void +incpush(p) +char *p; +{ + char *s; + + if (!p) + return; + + /* Break at all separators */ + while (*p) { + /* First, skip any consecutive separators */ + while ( *p == PERLLIB_SEP ) { + /* Uncomment the next line for PATH semantics */ + /* (void)apush(stab_array(incstab), str_make(".", 1)); */ + p++; + } + if ( (s = index(p, PERLLIB_SEP)) != Nullch ) { + (void)apush(stab_array(incstab), str_make(p, (int)(s - p))); + p = s + 1; + } else { + (void)apush(stab_array(incstab), str_make(p, 0)); + break; + } + } +} + +void +savelines(array, str) +ARRAY *array; +STR *str; +{ + register char *s = str->str_ptr; + register char *send = str->str_ptr + str->str_cur; + register char *t; + register int line = 1; + + while (s && s < send) { + STR *tmpstr = Str_new(85,0); + + t = index(s, '\n'); + if (t) + t++; + else + t = send; + + str_nset(tmpstr, s, t - s); + astore(array, line++, tmpstr); + s = t; + } +} + +/* this routine is in perl.c by virtue of being sort of an alternate main() */ + +int +do_eval(str,optype,stash,savecmd,gimme,arglast) +STR *str; +int optype; +HASH *stash; +int savecmd; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + int retval; + CMD *myroot = Nullcmd; + ARRAY *ar; + int i; + CMD * VOLATILE oldcurcmd = curcmd; + VOLATILE int oldtmps_base = tmps_base; + VOLATILE int oldsave = savestack->ary_fill; + VOLATILE int oldperldb = perldb; + SPAT * VOLATILE oldspat = curspat; + SPAT * VOLATILE oldlspat = lastspat; + static char *last_eval = Nullch; + static long last_elen = 0; + static CMD *last_root = Nullcmd; + VOLATILE int sp = arglast[0]; + char *specfilename; + char *tmpfilename; + int parsing = 1; + + tmps_base = tmps_max; + if (curstash != stash) { + (void)savehptr(&curstash); + curstash = stash; + } + str_set(stab_val(stabent("@",TRUE)),""); + if (curcmd->c_line == 0) /* don't debug debugger... */ + perldb = FALSE; + curcmd = &compiling; + if (optype == O_EVAL) { /* normal eval */ + curcmd->c_filestab = fstab("(eval)"); + curcmd->c_line = 1; + str_sset(linestr,str); + str_cat(linestr,";\n;\n"); /* be kind to them */ + if (perldb) + savelines(stab_xarray(curcmd->c_filestab), linestr); + } + else { + if (last_root && !in_eval) { + Safefree(last_eval); + last_eval = Nullch; + cmd_free(last_root); + last_root = Nullcmd; + } + specfilename = str_get(str); + str_set(linestr,""); + if (optype == O_REQUIRE && &str_undef != + hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) { + curcmd = oldcurcmd; + tmps_base = oldtmps_base; + st[++sp] = &str_yes; + perldb = oldperldb; + return sp; + } + tmpfilename = savestr(specfilename); + if (*tmpfilename == '/' || + (*tmpfilename == '.' && + (tmpfilename[1] == '/' || + (tmpfilename[1] == '.' && tmpfilename[2] == '/')))) + { + rsfp = fopen(tmpfilename,"r"); + } + else { + ar = stab_array(incstab); + for (i = 0; i <= ar->ary_fill; i++) { + (void)sprintf(buf, "%s/%s", + str_get(afetch(ar,i,TRUE)), specfilename); + rsfp = fopen(buf,"r"); + if (rsfp) { + char *s = buf; + + if (*s == '.' && s[1] == '/') + s += 2; + Safefree(tmpfilename); + tmpfilename = savestr(s); + break; + } + } + } + curcmd->c_filestab = fstab(tmpfilename); + Safefree(tmpfilename); + tmpfilename = Nullch; + if (!rsfp) { + curcmd = oldcurcmd; + tmps_base = oldtmps_base; + if (optype == O_REQUIRE) { + sprintf(tokenbuf,"Can't locate %s in @INC", specfilename); + if (instr(tokenbuf,".h ")) + strcat(tokenbuf," (change .h to .ph maybe?)"); + if (instr(tokenbuf,".ph ")) + strcat(tokenbuf," (did you run h2ph?)"); + fatal("%s",tokenbuf); + } + if (gimme != G_ARRAY) + st[++sp] = &str_undef; + perldb = oldperldb; + return sp; + } + curcmd->c_line = 0; + } + in_eval++; + oldoldbufptr = oldbufptr = bufptr = str_get(linestr); + bufend = bufptr + linestr->str_cur; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } + loop_stack[loop_ptr].loop_label = "_EVAL_"; + loop_stack[loop_ptr].loop_sp = sp; +#ifdef DEBUGGING + if (debug & 4) { + deb("(Pushing label #%d _EVAL_)\n", loop_ptr); + } +#endif + eval_root = Nullcmd; + if (setjmp(loop_stack[loop_ptr].loop_env)) { + retval = 1; + } + else { + error_count = 0; + if (rsfp) { + retval = yyparse(); + retval |= error_count; + } + else if (last_root && last_elen == bufend - bufptr + && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){ + retval = 0; + eval_root = last_root; /* no point in reparsing */ + } + else if (in_eval == 1 && !savecmd) { + if (last_root) { + Safefree(last_eval); + last_eval = Nullch; + cmd_free(last_root); + } + last_root = Nullcmd; + last_elen = bufend - bufptr; + last_eval = nsavestr(bufptr, last_elen); + retval = yyparse(); + retval |= error_count; + if (!retval) + last_root = eval_root; + if (!last_root) { + Safefree(last_eval); + last_eval = Nullch; + } + } + else + retval = yyparse(); + } + myroot = eval_root; /* in case cmd_exec does another eval! */ + + if (retval || error_count) { + st = stack->ary_array; + sp = arglast[0]; + if (gimme != G_ARRAY) + st[++sp] = &str_undef; + if (parsing) { +#ifndef MANGLEDPARSE +#ifdef DEBUGGING + if (debug & 128) + fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root); +#endif + cmd_free(eval_root); +#endif + /*SUPPRESS 29*/ /*SUPPRESS 30*/ + if ((CMD*)eval_root == last_root) + last_root = Nullcmd; + eval_root = myroot = Nullcmd; + } + if (rsfp) { + fclose(rsfp); + rsfp = 0; + } + } + else { + parsing = 0; + sp = cmd_exec(eval_root,gimme,sp); + st = stack->ary_array; + for (i = arglast[0] + 1; i <= sp; i++) + st[i] = str_mortal(st[i]); + /* if we don't save result, free zaps it */ + if (savecmd) + eval_root = myroot; + else if (in_eval != 1 && myroot != last_root) + cmd_free(myroot); + if (eval_root == myroot) + eval_root = Nullcmd; + } + + perldb = oldperldb; + in_eval--; +#ifdef DEBUGGING + if (debug & 4) { + char *tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, + tmps ? tmps : "" ); + } +#endif + loop_ptr--; + tmps_base = oldtmps_base; + curspat = oldspat; + lastspat = oldlspat; + if (savestack->ary_fill > oldsave) /* let them use local() */ + restorelist(oldsave); + + if (optype != O_EVAL) { + if (retval) { + if (optype == O_REQUIRE) + fatal("%s", str_get(stab_val(stabent("@",TRUE)))); + } + else { + curcmd = oldcurcmd; + if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) { + (void)hstore(stab_hash(incstab), specfilename, + strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)), + 0 ); + } + else if (optype == O_REQUIRE) + fatal("%s did not return a true value", specfilename); + } + } + curcmd = oldcurcmd; + return sp; +} + +int +do_try(cmd,gimme,arglast) +CMD *cmd; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + + CMD * VOLATILE oldcurcmd = curcmd; + VOLATILE int oldtmps_base = tmps_base; + VOLATILE int oldsave = savestack->ary_fill; + SPAT * VOLATILE oldspat = curspat; + SPAT * VOLATILE oldlspat = lastspat; + VOLATILE int sp = arglast[0]; + + tmps_base = tmps_max; + str_set(stab_val(stabent("@",TRUE)),""); + in_eval++; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } + loop_stack[loop_ptr].loop_label = "_EVAL_"; + loop_stack[loop_ptr].loop_sp = sp; +#ifdef DEBUGGING + if (debug & 4) { + deb("(Pushing label #%d _EVAL_)\n", loop_ptr); + } +#endif + if (setjmp(loop_stack[loop_ptr].loop_env)) { + st = stack->ary_array; + sp = arglast[0]; + if (gimme != G_ARRAY) + st[++sp] = &str_undef; + } + else { + sp = cmd_exec(cmd,gimme,sp); + st = stack->ary_array; +/* for (i = arglast[0] + 1; i <= sp; i++) + st[i] = str_mortal(st[i]); not needed, I think */ + /* if we don't save result, free zaps it */ + } + + in_eval--; +#ifdef DEBUGGING + if (debug & 4) { + char *tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, + tmps ? tmps : "" ); + } +#endif + loop_ptr--; + tmps_base = oldtmps_base; + curspat = oldspat; + lastspat = oldlspat; + curcmd = oldcurcmd; + if (savestack->ary_fill > oldsave) /* let them use local() */ + restorelist(oldsave); + + return sp; +} + +/* This routine handles any switches that can be given during run */ + +static char * +moreswitches(s) +char *s; +{ + int numlen; + + switch (*s) { + case '0': + nrschar = scanoct(s, 4, &numlen); + nrs = nsavestr("\n",1); + *nrs = nrschar; + if (nrschar > 0377) { + nrslen = 0; + nrs = ""; + } + else if (!nrschar && numlen >= 2) { + nrslen = 2; + nrs = "\n\n"; + nrschar = '\n'; + } + return s + numlen; + case 'a': + minus_a = TRUE; + s++; + return s; + case 'c': + minus_c = TRUE; + s++; + return s; + case 'd': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -d allowed in setuid scripts"); +#endif + perldb = TRUE; + s++; + return s; + case 'D': +#ifdef DEBUGGING +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -D allowed in setuid scripts"); +#endif + debug = atoi(s+1) | 32768; +#else + warn("Recompile perl with -DDEBUGGING to use -D switch\n"); +#endif + /*SUPPRESS 530*/ + for (s++; isDIGIT(*s); s++) ; + return s; + case 'i': + inplace = savestr(s+1); + /*SUPPRESS 530*/ + for (s = inplace; *s && !isSPACE(*s); s++) ; + *s = '\0'; + break; + case 'I': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -I allowed in setuid scripts"); +#endif + if (*++s) { + (void)apush(stab_array(incstab),str_make(s,0)); + } + else + fatal("No space allowed after -I"); + break; + case 'l': + minus_l = TRUE; + s++; + if (isDIGIT(*s)) { + ors = savestr("\n"); + orslen = 1; + *ors = scanoct(s, 3 + (*s == '0'), &numlen); + s += numlen; + } + else { + ors = nsavestr(nrs,nrslen); + orslen = nrslen; + } + return s; + case 'n': + minus_n = TRUE; + s++; + return s; + case 'p': + minus_p = TRUE; + s++; + return s; + case 'u': + do_undump = TRUE; + s++; + return s; + case 'U': + unsafe = TRUE; + s++; + return s; + case 'v': + fputs("\nThis is perl, version 4.0\n\n",stdout); + fputs(rcsid,stdout); + fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout); +#ifdef MSDOS + fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", + stdout); +#ifdef OS2 + fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n", + stdout); +#endif +#endif +#ifdef atarist + fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); +#endif + fputs("\n\ +Perl may be copied only under the terms of either the Artistic License or the\n\ +GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout); +#ifdef MSDOS + usage(origargv[0]); +#endif + exit(0); + case 'w': + dowarn = TRUE; + s++; + return s; + case ' ': + case '\n': + case '\t': + break; + default: + fatal("Switch meaningless after -x: -%s",s); + } + return Nullch; +} + +/* compliments of Tom Christiansen */ + +/* unexec() can be found in the Gnu emacs distribution */ + +void +my_unexec() +{ +#ifdef UNEXEC + int status; + extern int etext; + static char dumpname[BUFSIZ]; + static char perlpath[256]; + + sprintf (dumpname, "%s.perldump", origfilename); + sprintf (perlpath, "%s/perl", BIN); + + status = unexec(dumpname, perlpath, &etext, sbrk(0), 0); + if (status) + fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname); + exit(status); +#else +#ifdef DOSISH + abort(); /* nothing else to do */ +#else /* ! MSDOS */ +# ifndef SIGABRT +# define SIGABRT SIGILL +# endif +# ifndef SIGILL +# define SIGILL 6 /* blech */ +# endif + kill(getpid(),SIGABRT); /* for use with undump */ +#endif /* ! MSDOS */ +#endif +} + diff --git a/gnu/usr.bin/perl/perl/perl.h b/gnu/usr.bin/perl/perl/perl.h new file mode 100644 index 0000000..8249c62 --- /dev/null +++ b/gnu/usr.bin/perl/perl/perl.h @@ -0,0 +1,1063 @@ +/* $RCSfile: perl.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:35 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: perl.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:35 nate + * PERL! + * + * Revision 4.0.1.7 1993/02/05 19:40:30 lwall + * patch36: worked around certain busted compilers that don't init statics right + * + * Revision 4.0.1.6 92/06/08 14:55:10 lwall + * patch20: added Atari ST portability + * patch20: bcopy() and memcpy() now tested for overlap safety + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: removed implicit int declarations on functions + * + * Revision 4.0.1.5 91/11/11 16:41:07 lwall + * patch19: uts wrongly defines S_ISDIR() et al + * patch19: too many preprocessors can't expand a macro right in #if + * patch19: added little-endian pack/unpack options + * + * Revision 4.0.1.4 91/11/05 18:06:10 lwall + * patch11: various portability fixes + * patch11: added support for dbz + * patch11: added some support for 64-bit integers + * patch11: hex() didn't understand leading 0x + * + * Revision 4.0.1.3 91/06/10 01:25:10 lwall + * patch10: certain pattern optimizations were botched + * + * Revision 4.0.1.2 91/06/07 11:28:33 lwall + * patch4: new copyright notice + * patch4: made some allowances for "semi-standard" C + * patch4: many, many itty-bitty portability fixes + * + * Revision 4.0.1.1 91/04/11 17:49:51 lwall + * patch1: hopefully straightened out some of the Xenix mess + * + * Revision 4.0 91/03/20 01:37:56 lwall + * 4.0 baseline. + * + */ + +#define VOIDWANT 1 +#include "config.h" + +#ifdef MYMALLOC +# ifdef HIDEMYMALLOC +# define malloc Mymalloc +# define realloc Myremalloc +# define free Myfree +# endif +# define safemalloc malloc +# define saferealloc realloc +# define safefree free +#endif + +/* work around some libPW problems */ +#define fatal Myfatal +#ifdef DOINIT +char Error[1]; +#endif + +/* define this once if either system, instead of cluttering up the src */ +#if defined(MSDOS) || defined(atarist) +#define DOSISH 1 +#endif + +#ifdef DOSISH +/* This stuff now in the MS-DOS config.h file. */ +#else /* !MSDOS */ + +/* + * The following symbols are defined if your operating system supports + * functions by that name. All Unixes I know of support them, thus they + * are not checked by the configuration script, but are directly defined + * here. + */ +#define HAS_ALARM +#define HAS_CHOWN +#define HAS_CHROOT +#define HAS_FORK +#define HAS_GETLOGIN +#define HAS_GETPPID +#define HAS_KILL +#define HAS_LINK +#define HAS_PIPE +#define HAS_WAIT +#define HAS_UMASK +/* + * The following symbols are defined if your operating system supports + * password and group functions in general. All Unix systems do. + */ +#define HAS_GROUP +#define HAS_PASSWD + +#endif /* !MSDOS */ + +#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) +# define STANDARD_C 1 +#endif + +#if defined(HASVOLATILE) || defined(STANDARD_C) +#define VOLATILE volatile +#else +#define VOLATILE +#endif + +#ifdef IAMSUID +# ifndef TAINT +# define TAINT +# endif +#endif + +#ifndef HAS_VFORK +# define vfork fork +#endif + +#ifdef HAS_GETPGRP2 +# ifndef HAS_GETPGRP +# define HAS_GETPGRP +# endif +# define getpgrp getpgrp2 +#endif + +#ifdef HAS_SETPGRP2 +# ifndef HAS_SETPGRP +# define HAS_SETPGRP +# endif +# define setpgrp setpgrp2 +#endif + +#include +#include +#include +#ifndef MSDOS +#ifdef PARAM_NEEDS_TYPES +#include +#endif +#include +#endif +#ifdef STANDARD_C +/* Use all the "standard" definitions */ +#include +#include +#define MEM_SIZE size_t +#else +typedef unsigned int MEM_SIZE; +#endif /* STANDARD_C */ + +#if defined(HAS_MEMCMP) && defined(mips) && defined(ultrix) +#undef HAS_MEMCMP +#endif + +#ifdef HAS_MEMCPY +# ifndef STANDARD_C +# ifndef memcpy + extern char * memcpy(); +# endif +# endif +#else +# ifndef memcpy +# ifdef HAS_BCOPY +# define memcpy(d,s,l) bcopy(s,d,l) +# else +# define memcpy(d,s,l) my_bcopy(s,d,l) +# endif +# endif +#endif /* HAS_MEMCPY */ + +#ifdef HAS_MEMSET +# ifndef STANDARD_C +# ifndef memset + extern char *memset(); +# endif +# endif +# define memzero(d,l) memset(d,0,l) +#else +# ifndef memzero +# ifdef HAS_BZERO +# define memzero(d,l) bzero(d,l) +# else +# define memzero(d,l) my_bzero(d,l) +# endif +# endif +#endif /* HAS_MEMSET */ + +#ifdef HAS_MEMCMP +# ifndef STANDARD_C +# ifndef memcmp + extern int memcmp(); +# endif +# endif +#else +# ifndef memcmp +# define memcmp(s1,s2,l) my_memcmp(s1,s2,l) +# endif +#endif /* HAS_MEMCMP */ + +/* we prefer bcmp slightly for comparisons that don't care about ordering */ +#ifndef HAS_BCMP +# ifndef bcmp +# define bcmp(s1,s2,l) memcmp(s1,s2,l) +# endif +#endif /* HAS_BCMP */ + +#ifndef HAS_MEMMOVE +#if defined(HAS_BCOPY) && defined(SAFE_BCOPY) +#define memmove(d,s,l) bcopy(s,d,l) +#else +#if defined(HAS_MEMCPY) && defined(SAFE_MEMCPY) +#define memmove(d,s,l) memcpy(d,s,l) +#else +#define memmove(d,s,l) my_bcopy(s,d,l) +#endif +#endif +#endif + +#ifndef _TYPES_ /* If types.h defines this it's easy. */ +#ifndef major /* Does everyone's types.h define this? */ +#include +#endif +#endif + +#ifdef I_NETINET_IN +#include +#endif + +#include +#if defined(uts) || defined(UTekV) +#undef S_ISDIR +#undef S_ISCHR +#undef S_ISBLK +#undef S_ISREG +#undef S_ISFIFO +#undef S_ISLNK +#define S_ISDIR(P) (((P)&S_IFMT)==S_IFDIR) +#define S_ISCHR(P) (((P)&S_IFMT)==S_IFCHR) +#define S_ISBLK(P) (((P)&S_IFMT)==S_IFBLK) +#define S_ISREG(P) (((P)&S_IFMT)==S_IFREG) +#define S_ISFIFO(P) (((P)&S_IFMT)==S_IFIFO) +#ifdef S_IFLNK +#define S_ISLNK(P) (((P)&S_IFMT)==S_IFLNK) +#endif +#endif + +#ifdef I_TIME +# include +#endif + +#ifdef I_SYS_TIME +# ifdef SYSTIMEKERNEL +# define KERNEL +# endif +# include +# ifdef SYSTIMEKERNEL +# undef KERNEL +# endif +#endif + +#ifndef MSDOS +#include +#endif + +#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR)) +#undef HAS_STRERROR +#endif + +#include +#ifndef MSDOS +#ifndef errno +extern int errno; /* ANSI allows errno to be an lvalue expr */ +#endif +#endif + +#ifndef strerror +#ifdef HAS_STRERROR +char *strerror(); +#else +extern int sys_nerr; +extern char *sys_errlist[]; +#define strerror(e) ((e) < 0 || (e) >= sys_nerr ? "(unknown)" : sys_errlist[e]) +#endif +#endif + +#ifdef I_SYSIOCTL +#ifndef _IOCTL_ +#include +#endif +#endif + +#if defined(mc300) || defined(mc500) || defined(mc700) || defined(mc6000) +#ifdef HAS_SOCKETPAIR +#undef HAS_SOCKETPAIR +#endif +#ifdef HAS_NDBM +#undef HAS_NDBM +#endif +#endif + +#ifdef WANT_DBZ +#include +#define SOME_DBM +#define dbm_fetch(db,dkey) fetch(dkey) +#define dbm_delete(db,dkey) fatal("dbz doesn't implement delete") +#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent) +#define dbm_close(db) dbmclose() +#define dbm_firstkey(db) (fatal("dbz doesn't implement traversal"),fetch()) +#define nextkey() (fatal("dbz doesn't implement traversal"),fetch()) +#define dbm_nextkey(db) (fatal("dbz doesn't implement traversal"),fetch()) +#ifdef HAS_NDBM +#undef HAS_NDBM +#endif +#ifndef HAS_ODBM +#define HAS_ODBM +#endif +#else +#ifdef HAS_GDBM +#ifdef I_GDBM +#include +#endif +#define SOME_DBM +#ifdef HAS_NDBM +#undef HAS_NDBM +#endif +#ifdef HAS_ODBM +#undef HAS_ODBM +#endif +#else +#ifdef HAS_NDBM +#include +#define SOME_DBM +#ifdef HAS_ODBM +#undef HAS_ODBM +#endif +#else +#ifdef HAS_ODBM +#ifdef NULL +#undef NULL /* suppress redefinition message */ +#endif +#include +#ifdef NULL +#undef NULL +#endif +#define NULL 0 /* silly thing is, we don't even use this */ +#define SOME_DBM +#define dbm_fetch(db,dkey) fetch(dkey) +#define dbm_delete(db,dkey) delete(dkey) +#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent) +#define dbm_close(db) dbmclose() +#define dbm_firstkey(db) firstkey() +#endif /* HAS_ODBM */ +#endif /* HAS_NDBM */ +#endif /* HAS_GDBM */ +#endif /* WANT_DBZ */ +#ifdef SOME_DBM +EXT char *dbmkey; +EXT int dbmlen; +#endif + +#if INTSIZE == 2 +#define htoni htons +#define ntohi ntohs +#else +#define htoni htonl +#define ntohi ntohl +#endif + +#if defined(I_DIRENT) +# include +# define DIRENT dirent +#else +# ifdef I_SYS_NDIR +# include +# define DIRENT direct +# else +# ifdef I_SYS_DIR +# ifdef hp9000s500 +# include /* may be wrong in the future */ +# else +# include +# endif +# define DIRENT direct +# endif +# endif +#endif + +#ifdef FPUTS_BOTCH +/* work around botch in SunOS 4.0.1 and 4.0.2 */ +# ifndef fputs +# define fputs(str,fp) fprintf(fp,"%s",str) +# endif +#endif + +/* + * The following gobbledygook brought to you on behalf of __STDC__. + * (I could just use #ifndef __STDC__, but this is more bulletproof + * in the face of half-implementations.) + */ + +#ifndef S_IFMT +# ifdef _S_IFMT +# define S_IFMT _S_IFMT +# else +# define S_IFMT 0170000 +# endif +#endif + +#ifndef S_ISDIR +# define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR) +#endif + +#ifndef S_ISCHR +# define S_ISCHR(m) ((m & S_IFMT) == S_IFCHR) +#endif + +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) (0) +# endif +#endif + +#ifndef S_ISREG +# define S_ISREG(m) ((m & S_IFMT) == S_IFREG) +#endif + +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) (0) +# endif +#endif + +#ifndef S_ISLNK +# ifdef _S_ISLNK +# define S_ISLNK(m) _S_ISLNK(m) +# else +# ifdef _S_IFLNK +# define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK) +# else +# ifdef S_IFLNK +# define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) (0) +# endif +# endif +# endif +#endif + +#ifndef S_ISSOCK +# ifdef _S_ISSOCK +# define S_ISSOCK(m) _S_ISSOCK(m) +# else +# ifdef _S_IFSOCK +# define S_ISSOCK(m) ((m & S_IFMT) == _S_IFSOCK) +# else +# ifdef S_IFSOCK +# define S_ISSOCK(m) ((m & S_IFMT) == S_IFSOCK) +# else +# define S_ISSOCK(m) (0) +# endif +# endif +# endif +#endif + +#ifndef S_IRUSR +# ifdef S_IREAD +# define S_IRUSR S_IREAD +# define S_IWUSR S_IWRITE +# define S_IXUSR S_IEXEC +# else +# define S_IRUSR 0400 +# define S_IWUSR 0200 +# define S_IXUSR 0100 +# endif +# define S_IRGRP (S_IRUSR>>3) +# define S_IWGRP (S_IWUSR>>3) +# define S_IXGRP (S_IXUSR>>3) +# define S_IROTH (S_IRUSR>>6) +# define S_IWOTH (S_IWUSR>>6) +# define S_IXOTH (S_IXUSR>>6) +#endif + +#ifndef S_ISUID +# define S_ISUID 04000 +#endif + +#ifndef S_ISGID +# define S_ISGID 02000 +#endif + +#ifdef f_next +#undef f_next +#endif + +#if defined(cray) || defined(gould) || defined(i860) +# define SLOPPYDIVIDE +#endif + +#if defined(cray) || defined(convex) || defined (uts) || BYTEORDER > 0xffff +# define QUAD +#endif + +#ifdef QUAD +# ifdef cray +# define quad int +# else +# if defined(convex) || defined (uts) +# define quad long long +# else +# define quad long +# endif +# endif +#endif + +typedef MEM_SIZE STRLEN; + +typedef struct arg ARG; +typedef struct cmd CMD; +typedef struct formcmd FCMD; +typedef struct scanpat SPAT; +typedef struct stio STIO; +typedef struct sub SUBR; +typedef struct string STR; +typedef struct atbl ARRAY; +typedef struct htbl HASH; +typedef struct regexp REGEXP; +typedef struct stabptrs STBP; +typedef struct stab STAB; +typedef struct callsave CSV; + +#include "handy.h" +#include "regexp.h" +#include "str.h" +#include "util.h" +#include "form.h" +#include "stab.h" +#include "spat.h" +#include "arg.h" +#include "cmd.h" +#include "array.h" +#include "hash.h" + +#if defined(iAPX286) || defined(M_I286) || defined(I80286) +# define I286 +#endif + +#ifndef STANDARD_C +#ifdef CHARSPRINTF + char *sprintf(); +#else + int sprintf(); +#endif +#endif + +EXT char *Yes INIT("1"); +EXT char *No INIT(""); + +/* "gimme" values */ + +/* Note: cmd.c assumes that it can use && to produce one of these values! */ +#define G_SCALAR 0 +#define G_ARRAY 1 + +#ifdef CRIPPLED_CC +int str_true(); +#else /* !CRIPPLED_CC */ +#define str_true(str) (Str = (str), \ + (Str->str_pok ? \ + ((*Str->str_ptr > '0' || \ + Str->str_cur > 1 || \ + (Str->str_cur && *Str->str_ptr != '0')) ? 1 : 0) \ + : \ + (Str->str_nok ? (Str->str_u.str_nval != 0.0) : 0 ) )) +#endif /* CRIPPLED_CC */ + +#ifdef DEBUGGING +#define str_peek(str) (Str = (str), \ + (Str->str_pok ? \ + Str->str_ptr : \ + (Str->str_nok ? \ + (sprintf(tokenbuf,"num(%g)",Str->str_u.str_nval), \ + (char*)tokenbuf) : \ + "" ))) +#endif + +#ifdef CRIPPLED_CC +char *str_get(); +#else +#ifdef TAINT +#define str_get(str) (Str = (str), tainted |= Str->str_tainted, \ + (Str->str_pok ? Str->str_ptr : str_2ptr(Str))) +#else +#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str))) +#endif /* TAINT */ +#endif /* CRIPPLED_CC */ + +#ifdef CRIPPLED_CC +double str_gnum(); +#else /* !CRIPPLED_CC */ +#ifdef TAINT +#define str_gnum(str) (Str = (str), tainted |= Str->str_tainted, \ + (Str->str_nok ? Str->str_u.str_nval : str_2num(Str))) +#else /* !TAINT */ +#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_u.str_nval : str_2num(Str))) +#endif /* TAINT*/ +#endif /* CRIPPLED_CC */ +EXT STR *Str; + +#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len) + +#ifndef DOSISH +#define STR_GROW(str,len) if ((str)->str_len < (len)) str_grow(str,len) +#define Str_Grow str_grow +#else +/* extra parentheses intentionally NOT placed around "len"! */ +#define STR_GROW(str,len) if ((str)->str_len < (unsigned long)len) \ + str_grow(str,(unsigned long)len) +#define Str_Grow(str,len) str_grow(str,(unsigned long)(len)) +#endif /* DOSISH */ + +#ifndef BYTEORDER +#define BYTEORDER 0x1234 +#endif + +#if defined(htonl) && !defined(HAS_HTONL) +#define HAS_HTONL +#endif +#if defined(htons) && !defined(HAS_HTONS) +#define HAS_HTONS +#endif +#if defined(ntohl) && !defined(HAS_NTOHL) +#define HAS_NTOHL +#endif +#if defined(ntohs) && !defined(HAS_NTOHS) +#define HAS_NTOHS +#endif +#ifndef HAS_HTONL +#if (BYTEORDER & 0xffff) != 0x4321 +#define HAS_HTONS +#define HAS_HTONL +#define HAS_NTOHS +#define HAS_NTOHL +#define MYSWAP +#define htons my_swap +#define htonl my_htonl +#define ntohs my_swap +#define ntohl my_ntohl +#endif +#else +#if (BYTEORDER & 0xffff) == 0x4321 +#undef HAS_HTONS +#undef HAS_HTONL +#undef HAS_NTOHS +#undef HAS_NTOHL +#endif +#endif + +/* + * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. + * -DWS + */ +#if BYTEORDER != 0x1234 +# define HAS_VTOHL +# define HAS_VTOHS +# define HAS_HTOVL +# define HAS_HTOVS +# if BYTEORDER == 0x4321 +# define vtohl(x) ((((x)&0xFF)<<24) \ + +(((x)>>24)&0xFF) \ + +(((x)&0x0000FF00)<<8) \ + +(((x)&0x00FF0000)>>8) ) +# define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF)) +# define htovl(x) vtohl(x) +# define htovs(x) vtohs(x) +# endif + /* otherwise default to functions in util.c */ +#endif + +#ifdef CASTNEGFLOAT +#define U_S(what) ((unsigned short)(what)) +#define U_I(what) ((unsigned int)(what)) +#define U_L(what) ((unsigned long)(what)) +#else +unsigned long castulong(); +#define U_S(what) ((unsigned int)castulong(what)) +#define U_I(what) ((unsigned int)castulong(what)) +#define U_L(what) (castulong(what)) +#endif + +CMD *add_label(); +CMD *block_head(); +CMD *append_line(); +CMD *make_acmd(); +CMD *make_ccmd(); +CMD *make_icmd(); +CMD *invert(); +CMD *addcond(); +CMD *addloop(); +CMD *wopt(); +CMD *over(); + +STAB *stabent(); +STAB *genstab(); + +ARG *stab2arg(); +ARG *op_new(); +ARG *make_op(); +ARG *make_match(); +ARG *make_split(); +ARG *rcatmaybe(); +ARG *listish(); +ARG *maybelistish(); +ARG *localize(); +ARG *fixeval(); +ARG *jmaybe(); +ARG *l(); +ARG *fixl(); +ARG *mod_match(); +ARG *make_list(); +ARG *cmd_to_arg(); +ARG *addflags(); +ARG *hide_ary(); +ARG *cval_to_arg(); + +STR *str_new(); +STR *stab_str(); + +int apply(); +int do_each(); +int do_subr(); +int do_match(); +int do_unpack(); +int eval(); /* this evaluates expressions */ +int do_eval(); /* this evaluates eval operator */ +int do_assign(); + +SUBR *make_sub(); + +FCMD *load_format(); + +char *scanpat(); +char *scansubst(); +char *scantrans(); +char *scanstr(); +char *scanident(); +char *str_append_till(); +char *str_gets(); +char *str_grow(); + +bool do_open(); +bool do_close(); +bool do_print(); +bool do_aprint(); +bool do_exec(); +bool do_aexec(); + +int do_subst(); +int cando(); +int ingroup(); +int whichsig(); +int userinit(); +#ifdef CRYPTSCRIPT +void cryptswitch(); +#endif + +void str_replace(); +void str_inc(); +void str_dec(); +void str_free(); +void cmd_free(); +void arg_free(); +void spat_free(); +void regfree(); +void stab_clear(); +void do_chop(); +void do_vop(); +void do_write(); +void do_join(); +void do_sprintf(); +void do_accept(); +void do_pipe(); +void do_vecset(); +void do_unshift(); +void do_execfree(); +void magicalize(); +void magicname(); +void savelist(); +void saveitem(); +void saveint(); +void savelong(); +void savesptr(); +void savehptr(); +void restorelist(); +void repeatcpy(); +void make_form(); +void dehoist(); +void format(); +void my_unexec(); +void fatal(); +void warn(); +#ifdef DEBUGGING +void dump_all(); +void dump_cmd(); +void dump_arg(); +void dump_flags(); +void dump_stab(); +void dump_spat(); +#endif +#ifdef MSTATS +void mstats(); +#endif + +HASH *savehash(); +ARRAY *saveary(); + +EXT char **origargv; +EXT int origargc; +EXT char **origenviron; +extern char **environ; + +EXT long subline INIT(0); +EXT STR *subname INIT(Nullstr); +EXT int arybase INIT(0); + +struct outrec { + long o_lines; + char *o_str; + int o_len; +}; + +EXT struct outrec outrec; +EXT struct outrec toprec; + +EXT STAB *stdinstab INIT(Nullstab); +EXT STAB *last_in_stab INIT(Nullstab); +EXT STAB *defstab INIT(Nullstab); +EXT STAB *argvstab INIT(Nullstab); +EXT STAB *envstab INIT(Nullstab); +EXT STAB *sigstab INIT(Nullstab); +EXT STAB *defoutstab INIT(Nullstab); +EXT STAB *curoutstab INIT(Nullstab); +EXT STAB *argvoutstab INIT(Nullstab); +EXT STAB *incstab INIT(Nullstab); +EXT STAB *leftstab INIT(Nullstab); +EXT STAB *amperstab INIT(Nullstab); +EXT STAB *rightstab INIT(Nullstab); +EXT STAB *DBstab INIT(Nullstab); +EXT STAB *DBline INIT(Nullstab); +EXT STAB *DBsub INIT(Nullstab); + +EXT HASH *defstash; /* main symbol table */ +EXT HASH *curstash; /* symbol table for current package */ +EXT HASH *debstash; /* symbol table for perldb package */ + +EXT STR *curstname; /* name of current package */ + +EXT STR *freestrroot INIT(Nullstr); +EXT STR *lastretstr INIT(Nullstr); +EXT STR *DBsingle INIT(Nullstr); +EXT STR *DBtrace INIT(Nullstr); +EXT STR *DBsignal INIT(Nullstr); +EXT STR *formfeed INIT(Nullstr); + +EXT int lastspbase; +EXT int lastsize; + +EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEFx"); +EXT char *origfilename; +EXT FILE * VOLATILE rsfp INIT(Nullfp); +EXT char buf[1024]; +EXT char *bufptr; +EXT char *oldbufptr; +EXT char *oldoldbufptr; +EXT char *bufend; + +EXT STR *linestr INIT(Nullstr); + +EXT char *rs INIT("\n"); +EXT int rschar INIT('\n'); /* final char of rs, or 0777 if none */ +EXT int rslen INIT(1); +EXT bool rspara INIT(FALSE); +EXT char *ofs INIT(Nullch); +EXT int ofslen INIT(0); +EXT char *ors INIT(Nullch); +EXT int orslen INIT(0); +EXT char *ofmt INIT(Nullch); +EXT char *inplace INIT(Nullch); +EXT char *nointrp INIT(""); + +EXT bool preprocess INIT(FALSE); +EXT bool minus_n INIT(FALSE); +EXT bool minus_p INIT(FALSE); +EXT bool minus_l INIT(FALSE); +EXT bool minus_a INIT(FALSE); +EXT bool doswitches INIT(FALSE); +EXT bool dowarn INIT(FALSE); +EXT bool doextract INIT(FALSE); +EXT bool allstabs INIT(FALSE); /* init all customary symbols in symbol table?*/ +EXT bool sawampersand INIT(FALSE); /* must save all match strings */ +EXT bool sawstudy INIT(FALSE); /* do fbminstr on all strings */ +EXT bool sawi INIT(FALSE); /* study must assume case insensitive */ +EXT bool sawvec INIT(FALSE); +EXT bool localizing INIT(FALSE); /* are we processing a local() list? */ + +#ifndef MAXSYSFD +# define MAXSYSFD 2 +#endif +EXT int maxsysfd INIT(MAXSYSFD); /* top fd to pass to subprocesses */ + +#ifdef CSH +EXT char *cshname INIT(CSH); +EXT int cshlen INIT(0); +#endif /* CSH */ + +#ifdef TAINT +EXT bool tainted INIT(FALSE); /* using variables controlled by $< */ +EXT bool taintanyway INIT(FALSE); /* force taint checks when !set?id */ +#endif + +EXT bool nomemok INIT(FALSE); /* let malloc context handle nomem */ + +#ifndef DOSISH +#define TMPPATH "/tmp/perl-eXXXXXX" +#else +#define TMPPATH "plXXXXXX" +#endif /* MSDOS */ +EXT char *e_tmpname; +EXT FILE *e_fp INIT(Nullfp); + +EXT char tokenbuf[256]; +EXT int expectterm INIT(TRUE); /* how to interpret ambiguous tokens */ +EXT VOLATILE int in_eval INIT(FALSE); /* trap fatal errors? */ +EXT int multiline INIT(0); /* $*--do strings hold >1 line? */ +EXT int forkprocess; /* so do_open |- can return proc# */ +EXT int do_undump INIT(0); /* -u or dump seen? */ +EXT int error_count INIT(0); /* how many errors so far, max 10 */ +EXT int multi_start INIT(0); /* 1st line of multi-line string */ +EXT int multi_end INIT(0); /* last line of multi-line string */ +EXT int multi_open INIT(0); /* delimiter of said string */ +EXT int multi_close INIT(0); /* delimiter of said string */ + +FILE *popen(); +/* char *str_get(); */ +STR *interp(); +void free_arg(); +STIO *stio_new(); +void hoistmust(); +void scanconst(); + +EXT struct stat statbuf; +EXT struct stat statcache; +EXT STAB *statstab INIT(Nullstab); +EXT STR *statname INIT(Nullstr); +#ifndef MSDOS +EXT struct tms timesbuf; +#endif +EXT int uid; +EXT int euid; +EXT int gid; +EXT int egid; +UIDTYPE getuid(); +UIDTYPE geteuid(); +GIDTYPE getgid(); +GIDTYPE getegid(); +EXT int unsafe; + +#ifdef DEBUGGING +EXT VOLATILE int debug INIT(0); +EXT int dlevel INIT(0); +EXT int dlmax INIT(128); +EXT char *debname; +EXT char *debdelim; +#define YYDEBUG 1 +#endif +EXT int perldb INIT(0); +#define YYMAXDEPTH 300 + +EXT line_t cmdline INIT(NOLINE); + +EXT STR str_undef; +EXT STR str_no; +EXT STR str_yes; + +/* runtime control stuff */ + +EXT struct loop { + char *loop_label; /* what the loop was called, if anything */ + int loop_sp; /* stack pointer to copy stuff down to */ + jmp_buf loop_env; +} *loop_stack; + +EXT int loop_ptr INIT(-1); +EXT int loop_max INIT(128); + +EXT jmp_buf top_env; + +EXT char * VOLATILE goto_targ INIT(Nullch); /* cmd_exec gets strange when set */ + +struct ufuncs { + int (*uf_val)(); + int (*uf_set)(); + int uf_index; +}; + +EXT ARRAY *stack; /* THE STACK */ + +EXT ARRAY * VOLATILE savestack; /* to save non-local values on */ + +EXT ARRAY *tosave; /* strings to save on recursive subroutine */ + +EXT ARRAY *lineary; /* lines of script for debugger */ +EXT ARRAY *dbargs; /* args to call listed by caller function */ + +EXT ARRAY *fdpid; /* keep fd-to-pid mappings for mypopen */ +EXT HASH *pidstatus; /* keep pid-to-status mappings for waitpid */ + +EXT int *di; /* for tmp use in debuggers */ +EXT char *dc; +EXT short *ds; + +/* Fix these up for __STDC__ */ +EXT time_t basetime INIT(0); +char *mktemp(); +#ifndef STANDARD_C +/* All of these are in stdlib.h or time.h for ANSI C */ +double atof(); +long time(); +struct tm *gmtime(), *localtime(); +char *index(), *rindex(); +char *strcpy(), *strcat(); +#endif /* ! STANDARD_C */ + +#ifdef EUNICE +#define UNLINK unlnk +int unlnk(); +#else +#define UNLINK unlink +#endif + +#ifndef HAS_SETREUID +#ifdef HAS_SETRESUID +#define setreuid(r,e) setresuid(r,e,-1) +#define HAS_SETREUID +#endif +#endif +#ifndef HAS_SETREGID +#ifdef HAS_SETRESGID +#define setregid(r,e) setresgid(r,e,-1) +#define HAS_SETREGID +#endif +#endif + +#define SCAN_DEF 0 +#define SCAN_TR 1 +#define SCAN_REPL 2 diff --git a/gnu/usr.bin/perl/perl/perly.c b/gnu/usr.bin/perl/perl/perly.c new file mode 100644 index 0000000..1084cc4 --- /dev/null +++ b/gnu/usr.bin/perl/perl/perly.c @@ -0,0 +1,3063 @@ +#ifndef lint +static char yysccsid[] = "@(#)yaccpar 1.9 (Berkeley) 02/21/93"; +#endif +#define YYBYACC 1 +#define YYMAJOR 1 +#define YYMINOR 9 +#define yyclearin (yychar=(-1)) +#define yyerrok (yyerrflag=0) +#define YYRECOVERING (yyerrflag!=0) +#define YYPREFIX "yy" +#line 43 "perly.y" +#include "INTERN.h" +#include "perl.h" + +/*SUPPRESS 530*/ +/*SUPPRESS 593*/ +/*SUPPRESS 595*/ + +STAB *scrstab; +ARG *arg4; /* rarely used arguments to make_op() */ +ARG *arg5; + +#line 58 "perly.y" +typedef union { + int ival; + char *cval; + ARG *arg; + CMD *cmdval; + struct compcmd compval; + STAB *stabval; + FCMD *formval; +} YYSTYPE; +#line 34 "y.tab.c" +#define WORD 257 +#define LABEL 258 +#define APPEND 259 +#define OPEN 260 +#define SSELECT 261 +#define LOOPEX 262 +#define DOTDOT 263 +#define USING 264 +#define FORMAT 265 +#define DO 266 +#define SHIFT 267 +#define PUSH 268 +#define POP 269 +#define LVALFUN 270 +#define WHILE 271 +#define UNTIL 272 +#define IF 273 +#define UNLESS 274 +#define ELSE 275 +#define ELSIF 276 +#define CONTINUE 277 +#define SPLIT 278 +#define FLIST 279 +#define FOR 280 +#define FILOP 281 +#define FILOP2 282 +#define FILOP3 283 +#define FILOP4 284 +#define FILOP22 285 +#define FILOP25 286 +#define FUNC0 287 +#define FUNC1 288 +#define FUNC2 289 +#define FUNC2x 290 +#define FUNC3 291 +#define FUNC4 292 +#define FUNC5 293 +#define HSHFUN 294 +#define HSHFUN3 295 +#define FLIST2 296 +#define SUB 297 +#define FILETEST 298 +#define LOCAL 299 +#define DELETE 300 +#define RELOP 301 +#define EQOP 302 +#define MULOP 303 +#define ADDOP 304 +#define PACKAGE 305 +#define AMPER 306 +#define FORMLIST 307 +#define REG 308 +#define ARYLEN 309 +#define ARY 310 +#define HSH 311 +#define STAR 312 +#define SUBST 313 +#define PATTERN 314 +#define RSTRING 315 +#define TRANS 316 +#define LISTOP 317 +#define OROR 318 +#define ANDAND 319 +#define UNIOP 320 +#define LS 321 +#define RS 322 +#define MATCH 323 +#define NMATCH 324 +#define UMINUS 325 +#define POW 326 +#define INC 327 +#define DEC 328 +#define YYERRCODE 256 +short yylhs[] = { -1, + 26, 0, 25, 25, 12, 12, 12, 5, 3, 6, + 6, 7, 7, 7, 7, 7, 10, 10, 10, 10, + 10, 10, 9, 9, 9, 9, 8, 8, 8, 8, + 8, 8, 8, 8, 11, 11, 21, 21, 24, 24, + 1, 1, 1, 2, 2, 27, 28, 15, 13, 13, + 16, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 22, 22, 22, 22, 22, 22, 18, 18, 19, + 19, 20, 20, 4, 4, 23, +}; +short yylen[] = { 2, + 0, 2, 3, 2, 0, 2, 5, 4, 0, 0, + 2, 1, 2, 1, 2, 3, 1, 1, 3, 3, + 3, 3, 5, 5, 3, 3, 6, 6, 4, 4, + 7, 6, 10, 2, 0, 1, 0, 1, 0, 1, + 1, 1, 1, 4, 3, 3, 3, 2, 3, 1, + 2, 3, 4, 4, 4, 4, 4, 4, 4, 4, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 5, 3, 3, 1, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 1, 4, 3, + 2, 2, 2, 1, 1, 4, 1, 1, 5, 6, + 5, 4, 5, 6, 8, 1, 1, 1, 1, 1, + 5, 5, 4, 4, 2, 5, 5, 4, 4, 2, + 1, 2, 1, 2, 2, 1, 2, 4, 7, 2, + 4, 5, 4, 2, 2, 3, 1, 5, 6, 6, + 7, 9, 6, 2, 4, 2, 4, 1, 1, 6, + 5, 4, 5, 4, 2, 1, 1, 3, 3, 4, + 5, 5, 6, 6, 7, 8, 4, 2, 6, 1, + 1, 1, 2, 2, 3, 3, 3, 1, 1, 1, + 1, 1, 1, 2, 1, 1, +}; +short yydefred[] = { 1, + 0, 10, 0, 40, 0, 0, 0, 12, 41, 11, + 14, 0, 42, 43, 0, 0, 0, 0, 17, 9, + 186, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 106, 0, 97, + 95, 109, 108, 107, 110, 0, 0, 0, 0, 0, + 0, 0, 15, 0, 0, 0, 13, 0, 0, 0, + 0, 171, 170, 34, 0, 45, 46, 47, 10, 130, + 0, 127, 0, 122, 0, 0, 93, 0, 180, 181, + 0, 146, 0, 0, 144, 155, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 134, 135, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 182, 183, 0, 168, 0, 0, 86, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 124, 0, 0, 0, 84, 85, + 0, 0, 0, 0, 0, 0, 0, 4, 16, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 82, 83, 44, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 29, 0, + 30, 0, 25, 0, 26, 0, 0, 0, 36, 0, + 0, 136, 0, 0, 0, 0, 0, 0, 158, 159, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 185, 0, 0, 6, 0, 3, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 8, 131, + 0, 0, 0, 0, 128, 113, 0, 118, 0, 147, + 0, 145, 0, 0, 0, 0, 152, 0, 154, 0, + 0, 0, 133, 0, 0, 0, 0, 0, 160, 0, + 0, 0, 0, 0, 167, 0, 0, 89, 0, 0, + 114, 0, 119, 0, 0, 96, 0, 102, 0, 184, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 132, 0, 0, 111, 116, 0, 27, 28, + 23, 24, 151, 0, 0, 0, 32, 138, 0, 0, + 0, 0, 161, 162, 0, 0, 0, 0, 0, 153, + 0, 0, 112, 117, 99, 103, 101, 0, 0, 0, + 0, 143, 150, 31, 0, 139, 0, 140, 0, 163, + 164, 0, 0, 169, 104, 0, 100, 7, 129, 0, + 141, 0, 165, 0, 0, 0, 0, 166, 105, 33, + 142, +}; +short yydgoto[] = { 1, + 8, 9, 89, 255, 76, 3, 10, 11, 77, 219, + 220, 168, 79, 80, 292, 294, 81, 198, 102, 137, + 208, 82, 83, 12, 84, 2, 13, 14, +}; +short yysindex[] = { 0, + 0, 0, -193, 0, -54, -229, -212, 0, 0, 0, + 0, 383, 0, 0, 22, -232, -31, 40, 0, 0, + 0, -37, -36, -132, 562, -7, 107, -2, 2819, -29, + -23, -22, -21, 109, 111, -3, -4, 113, 123, 143, + 170, 172, 173, 174, 175, 186, 187, 188, 189, -34, + 191, 200, 2896, 202, 11, -228, -60, 0, -32, 0, + 0, 0, 0, 0, 0, 741, 848, 2819, 2819, 2819, + 2819, 912, 0, 2819, 2819, -98, 0, 98, -35, 1707, + -197, 0, 0, 0, -64, 0, 0, 0, 0, 0, + 3011, 0, 3105, 0, 204, -30, 0, -122, 0, 0, + -231, 0, -231, -231, 0, 0, 2819, -31, 2819, -31, + 2819, -31, 2819, -31, 2819, 2819, 205, 1027, 0, 0, + 1144, 3105, 3105, 3105, 3105, 3105, 206, 1208, 2819, 2819, + 2819, 2819, 2819, 0, 0, -237, 0, -237, 2819, 0, + -122, 2819, 131, -62, 216, 220, 2819, 2819, 2819, 2819, + 2819, 5754, 2819, 221, 0, -122, -197, -197, 0, 0, + 229, 32, -197, -197, -31, 224, -31, 0, 0, 2819, + 2819, 2819, 2819, 2819, 2819, 2819, 2819, 1319, 1494, 2819, + 2819, 2819, 2819, 1605, 1669, 1780, 1955, 2066, 2819, 2819, + 2130, 0, 0, 0, -113, 281, 1707, 279, 0, 5647, + 283, 2244, 2362, 284, 289, 293, 221, 294, 0, 65, + 0, 67, 0, 126, 0, 5528, 32, 2819, 0, 286, + -39, 0, 305, 279, 303, 303, 328, 329, 0, 0, + 130, 5658, 5647, 5647, 5647, 5647, 333, 303, 5658, 32, + 2819, 252, 2436, 2533, 74, -12, 84, -9, 221, 221, + 221, 2819, 0, 2725, 297, 0, 2819, 0, 221, 221, + 221, 221, 1707, 474, -122, -187, 2819, -257, 2819, -138, + 1707, 954, 117, 512, 2819, 238, 2819, 238, 2819, 486, + 2819, -162, 2819, -162, 51, 51, 2819, 51, 0, 0, + 2819, 348, 2819, 303, 0, 0, 32, 0, 32, 0, + 2819, 0, -31, -31, -31, -31, 0, 146, 0, 32, + 2819, -31, 0, 352, 279, 303, 3105, 3105, 0, 353, + 153, 279, 303, 303, 0, 279, 355, 0, 100, 2819, + 0, 32, 0, 32, 276, 0, 277, 0, 3, 0, + 2819, 154, 1707, 1707, 2819, 1707, 1707, 1707, 1707, 1707, + 1707, 221, 0, 1707, 303, 0, 0, 32, 0, 0, + 0, 0, 0, 362, -31, 345, 0, 0, 364, 279, + 365, 303, 0, 0, 367, 369, 279, 303, 370, 0, + 287, 114, 0, 0, 0, 0, 0, 14, -31, 1989, + 372, 0, 0, 0, 1027, 0, 373, 0, 303, 0, + 0, 374, 279, 0, 0, 292, 0, 0, 0, 381, + 0, 279, 0, 384, 386, -31, 393, 0, 0, 0, + 0, +}; +short yyrindex[] = { 0, + 0, 0, 70, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 3189, 3385, 0, 3460, 0, 0, 5031, 0, + 0, 0, 0, 3497, 0, 0, 3539, 0, 0, 0, + 0, 0, 3576, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 5098, 0, 0, 0, 3661, 0, 3793, 0, + 0, 0, 0, 0, 0, 5195, 5207, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, -11, 2796, + 5280, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 3867, 3661, 0, 4782, 0, 0, + 0, 0, 0, 0, 0, 0, 396, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 385, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4825, 0, 0, 0, 3909, 3952, 0, 0, 0, 0, + 5347, 3661, 0, 4158, 0, 4849, 5444, 5501, 0, 0, + 3994, 0, 5570, 5596, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 452, 2647, 164, 0, 128, 404, + 0, 0, 0, 0, 0, 0, 23, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 389, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 4200, 4243, + 4285, 0, 0, 0, 4084, 0, 0, 0, 30, 64, + 79, 81, 3733, 1030, 4916, 3409, 0, 4534, 0, 4576, + 3830, 0, 1883, 1422, 0, 5843, 0, 5894, 0, 4957, + 0, 4666, 0, 4740, 4375, 4449, 0, 4491, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 394, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 3878, 4698, 0, 4858, 4989, 5104, 5370, 5668, + 5820, 417, 0, 165, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1582, + 0, 0, 0, 0, 418, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, +}; +short yygindex[] = { 0, + 0, 0, 0, -178, -17, 335, 0, 0, 0, 448, + 66, 0, 6067, 342, 168, -148, 430, -69, -6, -96, + 151, 0, 0, 0, -87, 0, 0, 0, +}; +#define YYTABLESIZE 6408 +short yytable[] = { 87, + 5, 253, 91, 93, 254, 136, 16, 97, 174, 203, + 107, 289, 108, 110, 112, 114, 109, 111, 113, 134, + 209, 105, 211, 201, 213, 99, 215, 17, 145, 18, + 148, 174, 101, 5, 174, 121, 118, 104, 309, 237, + 5, 238, 312, 5, 18, 5, 174, 18, 153, 155, + 144, 223, 224, 225, 226, 227, 228, 174, 150, 5, + 148, 328, 147, 38, 4, 189, 190, 308, 191, 2, + 21, 5, 253, 135, 86, 254, 315, 316, 100, 146, + 336, 38, 85, 338, 321, 322, 323, 324, 21, 326, + 149, 20, 147, 20, 204, 387, 205, 206, 88, 20, + 20, 20, 39, 6, 22, 304, 407, 305, 174, 39, + 174, 7, 39, 176, 39, 178, 179, 174, 356, 19, + 357, 20, 22, 5, 94, 5, 5, 174, 39, 192, + 193, 365, 335, 187, 188, 189, 190, 19, 191, 20, + 178, 179, 337, 174, 4, 355, 103, 256, 115, 258, + 116, 5, 122, 383, 186, 384, 169, 174, 381, 364, + 189, 190, 123, 191, 178, 186, 306, 370, 178, 174, + 319, 178, 406, 174, 377, 378, 165, 166, 167, 392, + 178, 179, 124, 6, 189, 190, 363, 191, 186, 293, + 186, 7, 39, 374, 389, 39, 291, 174, 187, 188, + 189, 190, 15, 191, 179, 51, 391, 179, 51, 125, + 185, 126, 127, 128, 129, 359, 360, 361, 362, 90, + 92, 186, 134, 399, 367, 130, 131, 132, 133, 403, + 138, 170, 171, 172, 173, 170, 171, 172, 173, 139, + 184, 142, 194, 202, 218, 242, 229, 371, 372, 99, + 412, 186, 119, 241, 99, 243, 5, 5, 5, 244, + 5, 5, 5, 257, 174, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 186, 135, 394, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 408, 100, 120, 117, 5, 5, 100, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 143, 252, + 5, 290, 291, 295, 300, 39, 39, 5, 5, 39, + 39, 39, 301, 302, 303, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 311, 313, 293, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 98, 39, 39, 39, + 106, 317, 318, 325, 330, 39, 191, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 341, 353, 39, + 186, 314, 368, 373, 141, 380, 39, 39, 420, 320, + 385, 386, 393, 395, 396, 398, 327, 400, 156, 401, + 404, 405, 409, 411, 413, 68, 415, 176, 177, 178, + 179, 416, 72, 195, 418, 75, 419, 74, 186, 186, + 186, 186, 197, 421, 200, 183, 37, 187, 188, 189, + 190, 73, 191, 35, 179, 186, 186, 18, 186, 186, + 186, 186, 37, 186, 186, 186, 216, 48, 35, 78, + 410, 366, 197, 197, 197, 197, 197, 197, 0, 0, + 232, 233, 234, 235, 236, 0, 0, 0, 0, 0, + 239, 0, 369, 0, 39, 0, 0, 0, 375, 376, + 0, 39, 0, 379, 39, 0, 39, 157, 158, 159, + 160, 0, 0, 163, 164, 20, 0, 0, 69, 0, + 39, 186, 0, 0, 0, 263, 264, 265, 266, 268, + 270, 271, 272, 273, 274, 276, 278, 280, 282, 284, + 285, 286, 288, 0, 0, 0, 0, 397, 176, 177, + 178, 179, 0, 0, 402, 0, 0, 0, 0, 186, + 0, 0, 0, 0, 0, 0, 0, 0, 187, 188, + 189, 190, 0, 191, 0, 0, 0, 185, 0, 0, + 414, 0, 0, 0, 39, 0, 0, 39, 0, 417, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 68, 263, 0, 184, 0, 0, + 0, 72, 0, 0, 75, 185, 74, 0, 343, 0, + 344, 0, 0, 0, 0, 0, 346, 0, 347, 0, + 348, 0, 349, 0, 350, 0, 0, 0, 351, 0, + 0, 0, 0, 0, 354, 184, 0, 0, 19, 21, + 0, 0, 22, 23, 24, 0, 0, 0, 25, 26, + 27, 28, 29, 30, 31, 32, 33, 0, 197, 197, + 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, + 44, 45, 46, 47, 48, 49, 50, 51, 52, 0, + 53, 54, 55, 0, 20, 0, 390, 69, 56, 0, + 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, + 0, 0, 67, 0, 0, 0, 0, 39, 39, 70, + 71, 39, 39, 39, 0, 0, 0, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 0, 0, 0, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, + 39, 39, 0, 0, 0, 0, 0, 39, 0, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, + 0, 39, 0, 68, 176, 177, 178, 179, 39, 39, + 72, 0, 0, 75, 0, 74, 176, 177, 178, 179, + 0, 182, 183, 0, 187, 188, 189, 190, 0, 191, + 0, 0, 0, 0, 0, 0, 187, 188, 189, 190, + 0, 191, 176, 177, 178, 179, 0, 0, 95, 0, + 0, 22, 23, 24, 0, 0, 0, 25, 26, 27, + 28, 29, 187, 188, 189, 190, 0, 191, 0, 34, + 35, 0, 37, 38, 39, 40, 41, 42, 43, 44, + 45, 46, 47, 48, 49, 50, 51, 52, 0, 53, + 54, 55, 0, 20, 0, 0, 69, 56, 0, 96, + 58, 59, 60, 61, 62, 63, 64, 65, 66, 0, + 68, 67, 0, 0, 0, 0, 0, 72, 70, 71, + 75, 0, 74, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 68, 0, 0, 0, 0, 0, + 0, 72, 161, 0, 75, 0, 74, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 20, 0, 0, 69, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 186, 0, 0, 0, 0, 0, 151, 0, 0, + 22, 23, 24, 0, 0, 0, 25, 26, 27, 28, + 29, 345, 0, 0, 180, 0, 181, 0, 34, 35, + 0, 37, 38, 39, 40, 41, 42, 43, 44, 45, + 46, 47, 48, 49, 50, 51, 52, 69, 53, 54, + 55, 0, 0, 0, 0, 0, 56, 185, 152, 58, + 59, 60, 61, 62, 63, 64, 65, 66, 0, 68, + 67, 0, 0, 0, 0, 0, 72, 70, 71, 75, + 71, 74, 0, 71, 0, 0, 0, 184, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 71, 71, 0, + 71, 0, 71, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 21, 0, 0, 22, 23, 24, + 0, 0, 0, 25, 26, 27, 28, 29, 0, 0, + 0, 0, 71, 0, 0, 34, 35, 0, 37, 38, + 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, + 49, 50, 51, 52, 0, 53, 54, 55, 0, 0, + 0, 0, 69, 56, 0, 57, 58, 59, 60, 61, + 62, 63, 64, 65, 66, 0, 0, 67, 21, 0, + 0, 22, 23, 24, 70, 71, 68, 25, 26, 27, + 28, 29, 0, 72, 222, 0, 75, 0, 74, 34, + 35, 0, 37, 38, 39, 40, 41, 42, 43, 44, + 45, 46, 47, 48, 49, 50, 51, 52, 0, 53, + 54, 55, 0, 0, 0, 0, 175, 56, 0, 57, + 58, 59, 60, 61, 62, 63, 64, 65, 66, 0, + 0, 67, 0, 0, 0, 0, 0, 0, 70, 71, + 68, 0, 0, 0, 0, 0, 0, 72, 230, 0, + 75, 0, 74, 0, 176, 177, 178, 179, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 69, + 0, 182, 183, 0, 187, 188, 189, 190, 0, 191, + 0, 0, 19, 21, 0, 0, 22, 23, 24, 0, + 0, 0, 25, 26, 27, 28, 29, 0, 0, 0, + 71, 71, 71, 71, 34, 35, 0, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, + 50, 51, 52, 0, 53, 54, 55, 0, 0, 0, + 0, 0, 56, 69, 57, 58, 59, 60, 61, 62, + 63, 64, 65, 66, 0, 0, 67, 0, 0, 0, + 0, 68, 0, 70, 71, 0, 71, 71, 72, 0, + 0, 75, 0, 74, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 267, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 199, 0, 0, 22, 23, 24, 0, 0, 0, 25, + 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, + 0, 34, 35, 0, 37, 38, 39, 40, 41, 42, + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, + 0, 53, 54, 55, 69, 0, 0, 0, 0, 56, + 0, 57, 58, 59, 60, 61, 62, 63, 64, 65, + 66, 0, 72, 67, 21, 72, 0, 22, 23, 24, + 70, 71, 0, 25, 26, 27, 28, 29, 0, 72, + 72, 0, 72, 0, 72, 34, 35, 0, 37, 38, + 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, + 49, 50, 51, 52, 0, 53, 54, 55, 0, 0, + 0, 0, 0, 56, 72, 57, 58, 59, 60, 61, + 62, 63, 64, 65, 66, 0, 68, 67, 0, 0, + 0, 0, 0, 72, 70, 71, 75, 0, 74, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 269, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 21, 0, 0, 22, 23, + 24, 0, 0, 0, 25, 26, 27, 28, 29, 0, + 0, 0, 0, 0, 0, 0, 34, 35, 0, 37, + 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 0, 53, 54, 55, 69, + 0, 0, 74, 0, 56, 74, 57, 58, 59, 60, + 61, 62, 63, 64, 65, 66, 0, 68, 67, 74, + 74, 0, 74, 0, 72, 70, 71, 75, 0, 74, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 275, 0, 0, 0, 0, + 0, 0, 0, 0, 74, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 72, 0, 0, 0, 0, 0, + 0, 0, 72, 72, 72, 72, 0, 0, 0, 0, + 0, 68, 0, 0, 0, 0, 0, 0, 72, 0, + 0, 75, 0, 74, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 277, + 69, 0, 0, 0, 0, 0, 0, 0, 0, 72, + 72, 0, 0, 0, 186, 0, 0, 0, 72, 72, + 21, 0, 0, 22, 23, 24, 0, 0, 0, 25, + 26, 27, 28, 29, 0, 0, 0, 180, 0, 181, + 0, 34, 35, 0, 37, 38, 39, 40, 41, 42, + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, + 0, 53, 54, 55, 69, 0, 0, 0, 0, 56, + 185, 57, 58, 59, 60, 61, 62, 63, 64, 65, + 66, 0, 68, 67, 0, 0, 0, 0, 0, 72, + 70, 71, 75, 0, 74, 0, 0, 0, 0, 0, + 184, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 279, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 74, 74, 74, 74, 0, 0, 0, 0, + 0, 21, 0, 0, 22, 23, 24, 0, 0, 0, + 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, + 0, 0, 34, 35, 0, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, + 52, 0, 53, 54, 55, 69, 0, 0, 74, 74, + 56, 0, 57, 58, 59, 60, 61, 62, 63, 64, + 65, 66, 0, 73, 67, 21, 73, 0, 22, 23, + 24, 70, 71, 0, 25, 26, 27, 28, 29, 0, + 73, 73, 0, 73, 0, 73, 34, 35, 0, 37, + 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 0, 53, 54, 55, 175, + 0, 0, 0, 0, 56, 73, 57, 58, 59, 60, + 61, 62, 63, 64, 65, 66, 0, 68, 67, 0, + 0, 0, 0, 0, 72, 70, 71, 75, 0, 74, + 0, 0, 0, 0, 0, 0, 0, 176, 177, 178, + 179, 0, 0, 0, 0, 281, 0, 0, 0, 0, + 0, 0, 0, 0, 182, 183, 186, 187, 188, 189, + 190, 0, 191, 0, 0, 0, 21, 0, 0, 22, + 23, 24, 0, 0, 0, 25, 26, 27, 28, 29, + 0, 181, 0, 0, 0, 0, 0, 34, 35, 0, + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, + 47, 48, 49, 50, 51, 52, 0, 53, 54, 55, + 69, 0, 185, 0, 0, 56, 0, 57, 58, 59, + 60, 61, 62, 63, 64, 65, 66, 0, 68, 67, + 0, 0, 0, 0, 0, 72, 70, 71, 75, 0, + 74, 0, 184, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 283, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 73, 0, 0, 0, 0, + 0, 0, 0, 73, 73, 73, 73, 0, 0, 0, + 0, 0, 68, 0, 0, 0, 0, 0, 0, 72, + 0, 0, 75, 0, 74, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 287, 69, 0, 0, 0, 0, 0, 0, 0, 0, + 73, 0, 0, 0, 0, 0, 0, 0, 0, 73, + 73, 21, 0, 0, 22, 23, 24, 0, 0, 0, + 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, + 0, 0, 34, 35, 0, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, + 52, 175, 53, 54, 55, 69, 0, 0, 0, 0, + 56, 0, 57, 58, 59, 60, 61, 62, 63, 64, + 65, 66, 0, 0, 67, 0, 68, 0, 0, 0, + 0, 70, 71, 72, 296, 0, 75, 0, 74, 176, + 177, 178, 179, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 182, 183, 0, 187, + 188, 189, 190, 0, 191, 0, 0, 0, 0, 0, + 0, 0, 21, 0, 0, 22, 23, 24, 0, 0, + 0, 25, 26, 27, 28, 29, 0, 0, 0, 0, + 0, 0, 0, 34, 35, 0, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, + 51, 52, 0, 53, 54, 55, 0, 0, 0, 69, + 0, 56, 0, 57, 58, 59, 60, 61, 62, 63, + 64, 65, 66, 0, 0, 67, 21, 0, 0, 22, + 23, 24, 70, 71, 68, 25, 26, 27, 28, 29, + 0, 72, 298, 0, 75, 0, 74, 34, 35, 0, + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, + 47, 48, 49, 50, 51, 52, 0, 53, 54, 55, + 0, 0, 0, 0, 0, 56, 0, 57, 58, 59, + 60, 61, 62, 63, 64, 65, 66, 0, 0, 67, + 0, 0, 0, 0, 0, 0, 70, 71, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 68, 0, + 0, 0, 0, 0, 0, 72, 331, 0, 75, 0, + 74, 0, 0, 0, 0, 0, 0, 69, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 21, 0, 0, 22, 23, 24, 0, 0, 0, 25, + 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, + 0, 34, 35, 0, 37, 38, 39, 40, 41, 42, + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, + 0, 53, 54, 55, 0, 0, 0, 0, 0, 56, + 0, 57, 58, 59, 60, 61, 62, 63, 64, 65, + 66, 69, 0, 67, 0, 68, 0, 0, 0, 0, + 70, 71, 72, 333, 0, 75, 0, 74, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 21, 0, + 0, 22, 23, 24, 0, 0, 0, 25, 26, 27, + 28, 29, 0, 0, 0, 0, 0, 0, 0, 34, + 35, 0, 37, 38, 39, 40, 41, 42, 43, 44, + 45, 46, 47, 48, 49, 50, 51, 52, 69, 53, + 54, 55, 0, 0, 0, 0, 0, 56, 0, 57, + 58, 59, 60, 61, 62, 63, 64, 65, 66, 0, + 0, 67, 0, 0, 186, 0, 0, 0, 70, 71, + 178, 0, 21, 0, 0, 22, 23, 24, 0, 0, + 0, 25, 26, 27, 28, 29, 0, 186, 0, 186, + 0, 0, 0, 34, 35, 0, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, + 51, 52, 0, 53, 54, 55, 0, 0, 0, 0, + 186, 56, 0, 57, 58, 59, 60, 61, 62, 63, + 64, 65, 66, 0, 0, 67, 0, 68, 0, 0, + 0, 0, 70, 71, 72, 340, 0, 75, 0, 74, + 186, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, + 0, 0, 22, 23, 24, 0, 0, 0, 25, 26, + 27, 28, 29, 0, 0, 0, 0, 0, 0, 0, + 34, 35, 0, 37, 38, 39, 40, 41, 42, 43, + 44, 45, 46, 47, 48, 49, 50, 51, 52, 0, + 53, 54, 55, 0, 0, 0, 50, 0, 56, 50, + 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, + 69, 68, 67, 50, 50, 0, 0, 0, 72, 70, + 71, 75, 0, 74, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 50, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 186, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 68, 0, + 0, 0, 0, 0, 0, 72, 0, 0, 75, 0, + 74, 0, 0, 0, 69, 0, 0, 186, 186, 186, + 186, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 186, 186, 0, 186, 186, 186, + 186, 0, 186, 186, 186, 0, 0, 0, 0, 0, + 0, 21, 0, 0, 22, 23, 24, 0, 0, 0, + 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, + 0, 0, 34, 35, 0, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, + 52, 69, 53, 54, 55, 0, 0, 0, 0, 0, + 56, 0, 57, 58, 59, 60, 61, 62, 63, 64, + 65, 66, 0, 68, 67, 0, 0, 0, 0, 0, + 72, 70, 71, 75, 0, 74, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 50, 50, 50, 50, + 0, 0, 0, 0, 0, 21, 0, 0, 22, 23, + 24, 0, 0, 0, 25, 26, 27, 28, 29, 0, + 0, 0, 0, 0, 0, 0, 34, 35, 0, 37, + 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 0, 53, 54, 55, 0, + 0, 0, 50, 50, 56, 0, 57, 58, 59, 60, + 61, 62, 63, 64, 65, 66, 69, 68, 67, 0, + 0, 0, 0, 0, 72, 70, 71, 75, 0, 74, + 0, 0, 140, 0, 0, 22, 23, 24, 0, 0, + 0, 25, 26, 27, 28, 29, 0, 0, 0, 0, + 0, 0, 0, 34, 35, 0, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, + 51, 52, 0, 53, 54, 55, 0, 0, 0, 0, + 0, 56, 0, 57, 58, 59, 60, 61, 62, 63, + 64, 65, 66, 0, 0, 67, 0, 0, 0, 0, + 0, 0, 70, 71, 0, 0, 126, 0, 0, 126, + 69, 0, 126, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 126, 126, 0, 126, + 0, 126, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 196, 0, 0, + 22, 23, 24, 0, 0, 0, 25, 26, 27, 28, + 29, 126, 126, 0, 0, 0, 0, 0, 34, 35, + 0, 37, 38, 39, 40, 41, 42, 43, 44, 45, + 46, 47, 48, 49, 50, 51, 52, 0, 53, 54, + 55, 0, 126, 0, 0, 0, 56, 0, 57, 58, + 59, 60, 61, 62, 63, 64, 65, 66, 0, 0, + 67, 0, 0, 0, 0, 0, 0, 70, 71, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 199, 0, 0, 22, 23, 24, 0, 0, 0, + 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, + 0, 0, 34, 35, 0, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, + 52, 0, 53, 54, 55, 0, 0, 0, 0, 0, + 56, 0, 57, 58, 59, 60, 61, 62, 63, 64, + 65, 66, 121, 0, 67, 121, 0, 0, 121, 0, + 0, 70, 71, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 121, 121, 0, 121, 67, 121, 0, 67, + 0, 126, 67, 0, 0, 0, 0, 0, 0, 126, + 126, 126, 126, 0, 0, 0, 67, 67, 0, 67, + 0, 67, 0, 0, 0, 0, 0, 121, 121, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 126, + 126, 126, 126, 0, 0, 0, 0, 148, 0, 0, + 148, 67, 67, 148, 0, 0, 126, 126, 121, 126, + 126, 126, 126, 0, 126, 126, 126, 148, 148, 0, + 148, 0, 148, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 67, 0, 149, 0, 0, 149, 0, 0, + 149, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 148, 148, 149, 149, 0, 149, 0, 149, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 137, 0, 0, 137, + 0, 0, 137, 148, 0, 0, 0, 0, 0, 149, + 149, 0, 0, 0, 0, 0, 137, 137, 0, 137, + 0, 137, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 157, 0, 0, 157, 0, 0, 157, + 149, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 137, 137, 157, 157, 0, 157, 0, 157, 0, + 0, 0, 0, 0, 0, 0, 0, 121, 0, 0, + 0, 0, 0, 0, 0, 121, 121, 121, 121, 0, + 0, 0, 137, 0, 0, 0, 0, 0, 157, 157, + 0, 67, 0, 0, 0, 0, 0, 0, 0, 67, + 67, 67, 67, 0, 0, 121, 121, 121, 121, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 94, 157, + 0, 94, 121, 121, 94, 121, 121, 121, 121, 0, + 121, 121, 121, 0, 0, 0, 0, 0, 94, 94, + 0, 94, 148, 94, 0, 0, 67, 67, 0, 0, + 148, 148, 148, 148, 0, 67, 67, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 94, 94, 0, 0, 0, 0, 149, + 148, 148, 148, 148, 0, 0, 0, 149, 149, 149, + 149, 0, 0, 49, 0, 0, 49, 148, 148, 0, + 148, 148, 148, 148, 94, 148, 148, 148, 0, 0, + 49, 49, 0, 0, 0, 0, 0, 149, 149, 149, + 149, 137, 0, 0, 0, 0, 0, 0, 0, 137, + 137, 137, 137, 0, 149, 149, 0, 149, 149, 149, + 149, 0, 149, 149, 149, 49, 0, 0, 0, 0, + 98, 0, 0, 98, 0, 0, 98, 0, 157, 137, + 137, 137, 137, 0, 0, 0, 157, 157, 157, 157, + 98, 98, 0, 98, 0, 98, 137, 137, 0, 137, + 137, 137, 137, 0, 137, 137, 137, 0, 0, 0, + 52, 0, 0, 52, 0, 0, 157, 157, 157, 157, + 0, 0, 0, 0, 0, 98, 98, 52, 52, 0, + 0, 0, 0, 157, 157, 0, 157, 157, 157, 157, + 0, 157, 157, 157, 186, 0, 0, 186, 0, 0, + 186, 0, 0, 0, 0, 0, 98, 0, 54, 0, + 0, 54, 52, 94, 186, 186, 0, 186, 0, 186, + 0, 94, 94, 94, 94, 54, 54, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 115, 0, 0, 115, + 0, 0, 115, 0, 0, 0, 0, 0, 0, 186, + 186, 94, 94, 94, 94, 0, 115, 115, 0, 115, + 54, 115, 0, 0, 0, 0, 0, 0, 94, 94, + 0, 94, 94, 94, 94, 0, 94, 94, 94, 120, + 186, 0, 120, 0, 0, 120, 0, 0, 0, 0, + 0, 115, 115, 49, 49, 49, 49, 0, 0, 120, + 120, 0, 120, 0, 120, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 91, 115, 0, 91, 0, 0, 91, 0, 0, + 0, 0, 0, 0, 120, 120, 0, 0, 0, 0, + 0, 91, 91, 0, 91, 98, 91, 0, 0, 49, + 49, 0, 0, 98, 98, 98, 98, 0, 0, 0, + 0, 0, 0, 0, 0, 120, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 91, 91, 0, 0, + 0, 0, 0, 98, 98, 98, 98, 0, 0, 0, + 52, 52, 52, 52, 0, 0, 0, 0, 0, 0, + 98, 98, 0, 98, 98, 98, 98, 91, 98, 98, + 98, 90, 0, 0, 90, 0, 0, 90, 0, 186, + 0, 0, 0, 0, 0, 0, 0, 186, 186, 186, + 186, 90, 90, 0, 90, 0, 90, 0, 54, 54, + 54, 54, 0, 0, 0, 0, 52, 52, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 186, 186, 186, + 186, 115, 0, 0, 0, 0, 90, 90, 0, 115, + 115, 115, 115, 0, 186, 186, 0, 186, 186, 186, + 186, 0, 186, 186, 186, 173, 0, 0, 173, 0, + 0, 0, 0, 0, 54, 54, 0, 90, 0, 115, + 115, 115, 115, 0, 120, 173, 173, 0, 173, 0, + 173, 0, 120, 120, 120, 120, 115, 115, 0, 115, + 115, 115, 115, 0, 115, 115, 115, 175, 0, 0, + 175, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 173, 173, 120, 120, 120, 120, 91, 175, 175, 0, + 175, 0, 175, 0, 91, 91, 91, 91, 0, 120, + 120, 0, 120, 120, 120, 120, 0, 120, 120, 120, + 176, 173, 0, 176, 0, 0, 0, 0, 0, 0, + 0, 0, 175, 175, 91, 91, 91, 91, 0, 0, + 176, 176, 0, 176, 0, 176, 0, 0, 0, 0, + 0, 91, 91, 0, 91, 91, 91, 91, 0, 91, + 91, 91, 177, 175, 0, 177, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 176, 176, 0, 0, 0, + 0, 0, 177, 177, 0, 177, 90, 177, 0, 0, + 0, 0, 0, 0, 90, 90, 90, 90, 0, 0, + 0, 0, 0, 0, 0, 0, 176, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 177, 177, 0, + 0, 0, 0, 0, 90, 90, 90, 90, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 90, 90, 0, 90, 90, 90, 90, 177, 90, + 90, 90, 75, 0, 0, 75, 0, 0, 75, 0, + 173, 0, 0, 0, 0, 0, 0, 0, 173, 173, + 173, 173, 75, 75, 0, 75, 0, 75, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 173, 173, + 173, 173, 175, 0, 0, 0, 0, 75, 75, 0, + 175, 175, 175, 175, 0, 173, 173, 0, 173, 173, + 173, 173, 0, 173, 173, 173, 76, 0, 0, 76, + 0, 0, 76, 0, 0, 0, 0, 0, 75, 0, + 175, 175, 175, 175, 0, 176, 76, 76, 0, 76, + 0, 76, 0, 176, 176, 176, 176, 175, 175, 0, + 175, 175, 175, 175, 0, 175, 175, 175, 61, 0, + 0, 61, 0, 0, 61, 0, 0, 0, 0, 0, + 0, 76, 76, 176, 176, 176, 176, 177, 61, 61, + 0, 61, 0, 61, 0, 177, 177, 177, 177, 0, + 176, 176, 0, 176, 176, 176, 176, 0, 176, 176, + 176, 62, 76, 0, 62, 0, 0, 62, 0, 0, + 0, 0, 0, 61, 61, 177, 177, 177, 177, 0, + 0, 62, 62, 0, 62, 0, 62, 0, 0, 0, + 0, 0, 177, 177, 0, 177, 177, 177, 177, 0, + 177, 177, 177, 63, 61, 0, 63, 0, 0, 63, + 0, 0, 0, 0, 0, 0, 62, 62, 0, 0, + 0, 0, 0, 63, 63, 0, 63, 75, 63, 0, + 0, 0, 0, 0, 0, 75, 75, 75, 75, 0, + 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 63, 63, + 0, 0, 0, 0, 0, 75, 75, 75, 75, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 75, 75, 0, 75, 75, 75, 75, 63, + 0, 75, 75, 64, 0, 0, 64, 0, 0, 64, + 0, 76, 0, 0, 0, 0, 0, 0, 0, 76, + 76, 76, 76, 64, 64, 0, 64, 0, 64, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 55, 0, + 0, 55, 0, 0, 0, 0, 0, 0, 0, 76, + 76, 76, 76, 61, 0, 55, 55, 0, 64, 64, + 0, 61, 61, 61, 61, 0, 76, 76, 0, 76, + 76, 76, 76, 0, 0, 76, 76, 65, 0, 0, + 65, 0, 0, 65, 0, 0, 0, 0, 0, 64, + 55, 61, 61, 61, 61, 0, 62, 65, 65, 0, + 65, 0, 65, 0, 62, 62, 62, 62, 61, 61, + 0, 61, 61, 61, 61, 0, 0, 61, 61, 92, + 0, 0, 92, 0, 0, 92, 0, 0, 0, 0, + 0, 0, 65, 65, 62, 62, 62, 62, 63, 92, + 92, 0, 92, 0, 92, 0, 63, 63, 63, 63, + 0, 62, 62, 0, 62, 62, 0, 0, 0, 0, + 62, 62, 87, 65, 0, 87, 0, 0, 87, 0, + 0, 0, 0, 0, 92, 92, 63, 63, 0, 63, + 0, 0, 87, 87, 0, 87, 125, 87, 0, 125, + 0, 0, 125, 63, 63, 0, 63, 63, 60, 0, + 0, 60, 63, 63, 0, 92, 125, 125, 0, 125, + 0, 125, 0, 0, 0, 60, 60, 87, 87, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 64, 0, + 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, + 0, 125, 125, 0, 0, 0, 0, 0, 87, 0, + 60, 0, 0, 66, 0, 0, 66, 0, 0, 66, + 0, 0, 0, 0, 0, 0, 64, 64, 55, 55, + 55, 55, 125, 66, 66, 0, 66, 0, 66, 0, + 0, 0, 0, 64, 64, 0, 64, 64, 0, 0, + 0, 0, 64, 64, 68, 0, 0, 68, 0, 0, + 68, 0, 65, 0, 0, 0, 0, 0, 66, 66, + 65, 65, 65, 65, 68, 68, 0, 68, 0, 68, + 0, 0, 0, 0, 55, 55, 0, 0, 0, 59, + 0, 0, 59, 0, 0, 0, 0, 0, 0, 66, + 65, 65, 0, 0, 92, 0, 59, 59, 0, 68, + 68, 0, 92, 92, 92, 92, 0, 65, 65, 0, + 65, 65, 0, 0, 0, 0, 65, 65, 156, 0, + 0, 156, 0, 0, 156, 0, 0, 0, 0, 0, + 68, 59, 92, 92, 0, 0, 0, 87, 156, 156, + 0, 156, 0, 156, 0, 87, 87, 87, 87, 92, + 92, 0, 0, 0, 0, 0, 0, 0, 92, 92, + 0, 125, 0, 0, 0, 0, 0, 0, 0, 125, + 125, 125, 125, 156, 156, 87, 87, 0, 60, 60, + 60, 60, 0, 0, 0, 88, 0, 0, 88, 0, + 0, 88, 87, 87, 58, 0, 0, 58, 0, 125, + 125, 87, 87, 0, 156, 88, 88, 0, 88, 0, + 88, 58, 58, 0, 0, 0, 125, 125, 0, 0, + 0, 0, 0, 0, 0, 125, 125, 0, 66, 0, + 0, 0, 0, 0, 60, 60, 66, 66, 66, 66, + 88, 88, 0, 0, 0, 0, 58, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 66, 0, 68, + 0, 88, 0, 0, 0, 0, 0, 68, 68, 68, + 68, 0, 172, 66, 66, 172, 0, 0, 172, 0, + 0, 0, 66, 66, 123, 0, 0, 123, 0, 0, + 123, 0, 172, 172, 0, 172, 0, 172, 0, 59, + 59, 59, 59, 0, 123, 123, 0, 123, 0, 123, + 0, 0, 0, 0, 68, 68, 0, 0, 0, 0, + 0, 0, 0, 68, 68, 0, 0, 172, 172, 0, + 0, 0, 0, 156, 0, 0, 0, 0, 0, 123, + 123, 156, 156, 156, 156, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 59, 59, 77, 172, 0, + 77, 0, 0, 77, 0, 0, 0, 0, 0, 0, + 123, 156, 156, 156, 156, 0, 0, 77, 77, 0, + 77, 0, 77, 0, 0, 0, 0, 0, 156, 156, + 0, 156, 156, 156, 156, 0, 156, 0, 0, 0, + 88, 0, 0, 0, 0, 0, 0, 0, 88, 88, + 88, 88, 77, 77, 58, 58, 58, 58, 0, 0, + 0, 0, 0, 0, 174, 0, 0, 174, 0, 0, + 174, 0, 0, 0, 0, 0, 0, 0, 88, 88, + 88, 88, 0, 77, 174, 174, 0, 174, 0, 174, + 56, 0, 0, 56, 0, 88, 88, 0, 88, 88, + 88, 88, 0, 88, 0, 0, 0, 56, 56, 0, + 58, 58, 0, 0, 0, 0, 0, 0, 0, 174, + 174, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 172, 0, 0, + 0, 0, 56, 0, 0, 172, 172, 172, 172, 123, + 174, 0, 0, 0, 0, 0, 0, 123, 123, 123, + 123, 80, 0, 0, 80, 0, 0, 80, 0, 0, + 0, 0, 0, 0, 0, 172, 172, 172, 172, 0, + 0, 80, 80, 0, 80, 0, 80, 123, 123, 123, + 123, 0, 172, 172, 0, 172, 172, 172, 172, 0, + 172, 0, 0, 0, 123, 123, 0, 123, 123, 123, + 123, 0, 123, 0, 0, 0, 80, 80, 81, 0, + 0, 81, 77, 0, 81, 0, 0, 0, 0, 0, + 77, 77, 77, 77, 0, 0, 0, 0, 81, 81, + 0, 81, 0, 81, 0, 186, 0, 80, 307, 0, + 0, 293, 0, 0, 0, 0, 0, 0, 0, 0, + 77, 77, 77, 77, 0, 0, 0, 0, 180, 0, + 181, 0, 0, 81, 81, 0, 0, 77, 77, 0, + 77, 77, 77, 77, 0, 77, 0, 78, 0, 174, + 78, 0, 0, 78, 0, 0, 0, 174, 174, 174, + 174, 185, 0, 0, 81, 0, 0, 78, 78, 0, + 78, 0, 78, 79, 0, 0, 79, 0, 0, 79, + 56, 56, 56, 56, 0, 0, 0, 174, 174, 174, + 174, 184, 0, 79, 79, 0, 79, 0, 79, 0, + 0, 0, 78, 78, 174, 174, 0, 174, 174, 174, + 174, 0, 174, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 186, 0, 0, 0, 79, 79, + 293, 0, 0, 78, 0, 186, 56, 56, 0, 0, + 0, 291, 0, 0, 0, 0, 80, 180, 57, 181, + 0, 57, 0, 0, 80, 80, 80, 80, 180, 79, + 181, 0, 0, 0, 0, 57, 57, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 185, 0, 0, 0, 80, 80, 80, 80, 0, 0, + 0, 185, 0, 0, 0, 0, 0, 0, 0, 0, + 57, 80, 80, 81, 80, 80, 80, 80, 0, 80, + 184, 81, 81, 81, 81, 0, 0, 0, 0, 0, + 0, 184, 0, 0, 0, 0, 68, 0, 0, 0, + 175, 0, 0, 72, 0, 0, 75, 0, 74, 0, + 0, 81, 81, 81, 81, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 81, 81, + 0, 81, 81, 81, 81, 0, 81, 0, 176, 177, + 178, 179, 78, 0, 0, 0, 0, 0, 0, 0, + 78, 78, 78, 78, 148, 182, 183, 0, 187, 188, + 189, 190, 0, 191, 0, 0, 0, 0, 79, 0, + 53, 0, 0, 53, 0, 0, 79, 79, 79, 79, + 78, 78, 78, 78, 0, 0, 147, 53, 53, 69, + 0, 0, 0, 70, 0, 0, 70, 78, 78, 0, + 78, 78, 78, 78, 0, 78, 79, 79, 79, 79, + 70, 70, 0, 70, 0, 70, 0, 0, 0, 175, + 0, 0, 53, 79, 79, 0, 79, 79, 79, 79, + 175, 79, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 69, 70, 70, 69, 57, 57, + 57, 57, 0, 0, 0, 0, 0, 176, 177, 178, + 179, 69, 69, 0, 69, 0, 69, 0, 176, 177, + 178, 179, 0, 0, 182, 183, 70, 187, 188, 189, + 190, 0, 191, 0, 0, 182, 183, 0, 187, 188, + 189, 190, 0, 191, 0, 0, 69, 69, 0, 0, + 0, 0, 0, 0, 57, 57, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 21, 0, 0, 22, 23, 24, 0, 69, 0, 25, + 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, + 0, 34, 35, 0, 37, 38, 39, 40, 41, 42, + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, + 0, 53, 54, 55, 0, 0, 0, 0, 0, 56, + 0, 57, 58, 59, 60, 61, 62, 63, 64, 65, + 66, 0, 0, 67, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 53, 53, 53, 53, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 70, 0, 0, 0, 0, + 0, 0, 0, 70, 70, 70, 70, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 154, 0, 0, 0, 0, 0, 162, 0, + 0, 0, 0, 0, 0, 0, 53, 53, 0, 0, + 0, 0, 0, 0, 0, 0, 69, 0, 0, 0, + 70, 70, 0, 0, 69, 69, 69, 69, 0, 70, + 70, 0, 0, 207, 0, 210, 0, 212, 0, 214, + 0, 0, 217, 0, 221, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 231, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 240, 0, + 0, 69, 69, 245, 246, 247, 248, 249, 250, 251, + 69, 69, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 259, 260, 261, 262, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 297, 299, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 310, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 329, 0, 332, + 334, 0, 0, 0, 0, 0, 0, 0, 339, 0, + 0, 0, 0, 342, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 352, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 358, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 207, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 382, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 388, +}; +short yycheck[] = { 17, + 0, 41, 40, 40, 44, 40, 61, 25, 44, 40, + 40, 125, 30, 31, 32, 33, 40, 40, 40, 257, + 108, 28, 110, 93, 112, 257, 114, 257, 257, 41, + 91, 44, 40, 33, 44, 40, 40, 40, 217, 136, + 40, 138, 221, 43, 257, 45, 44, 59, 66, 67, + 40, 121, 122, 123, 124, 125, 126, 44, 91, 59, + 91, 240, 123, 41, 258, 323, 324, 216, 326, 0, + 41, 265, 41, 311, 307, 44, 225, 226, 310, 308, + 93, 59, 61, 93, 233, 234, 235, 236, 59, 238, + 123, 123, 123, 123, 101, 93, 103, 104, 59, 123, + 123, 123, 33, 297, 41, 41, 93, 41, 44, 40, + 44, 305, 43, 301, 45, 303, 304, 44, 297, 41, + 299, 41, 59, 123, 257, 125, 126, 44, 59, 327, + 328, 310, 59, 321, 322, 323, 324, 59, 326, 59, + 303, 304, 59, 44, 258, 294, 40, 165, 40, 167, + 40, 265, 40, 332, 38, 334, 59, 44, 59, 308, + 323, 324, 40, 326, 303, 38, 41, 316, 41, 44, + 41, 44, 59, 44, 323, 324, 275, 276, 277, 358, + 303, 304, 40, 297, 323, 324, 41, 326, 61, 44, + 63, 305, 123, 41, 41, 126, 44, 44, 321, 322, + 323, 324, 257, 326, 41, 41, 355, 44, 44, 40, + 94, 40, 40, 40, 40, 303, 304, 305, 306, 257, + 257, 94, 257, 372, 312, 40, 40, 40, 40, 378, + 40, 271, 272, 273, 274, 271, 272, 273, 274, 40, + 124, 40, 307, 40, 40, 308, 41, 317, 318, 257, + 399, 124, 257, 123, 257, 40, 256, 257, 258, 40, + 260, 261, 262, 40, 44, 265, 266, 267, 268, 269, + 270, 271, 272, 273, 274, 38, 311, 365, 278, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, + 300, 389, 310, 308, 308, 305, 306, 310, 308, 309, + 310, 311, 312, 313, 314, 315, 316, 317, 308, 91, + 320, 41, 44, 41, 41, 256, 257, 327, 328, 260, + 261, 262, 44, 41, 41, 266, 267, 268, 269, 270, + 271, 272, 273, 274, 59, 41, 44, 278, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, 293, 294, 295, 296, 25, 298, 299, 300, + 29, 44, 44, 41, 123, 306, 326, 308, 309, 310, + 311, 312, 313, 314, 315, 316, 317, 91, 41, 320, + 263, 224, 41, 41, 53, 41, 327, 328, 416, 232, + 125, 125, 41, 59, 41, 41, 239, 41, 67, 41, + 41, 125, 41, 41, 41, 33, 125, 301, 302, 303, + 304, 41, 40, 89, 41, 43, 41, 45, 301, 302, + 303, 304, 91, 41, 93, 319, 41, 321, 322, 323, + 324, 59, 326, 59, 41, 318, 319, 59, 321, 322, + 323, 324, 59, 326, 327, 328, 115, 41, 41, 12, + 395, 311, 121, 122, 123, 124, 125, 126, -1, -1, + 129, 130, 131, 132, 133, -1, -1, -1, -1, -1, + 139, -1, 315, -1, 33, -1, -1, -1, 321, 322, + -1, 40, -1, 326, 43, -1, 45, 68, 69, 70, + 71, -1, -1, 74, 75, 123, -1, -1, 126, -1, + 59, 38, -1, -1, -1, 174, 175, 176, 177, 178, + 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, + 189, 190, 191, -1, -1, -1, -1, 370, 301, 302, + 303, 304, -1, -1, 377, -1, -1, -1, -1, 38, + -1, -1, -1, -1, -1, -1, -1, -1, 321, 322, + 323, 324, -1, 326, -1, -1, -1, 94, -1, -1, + 403, -1, -1, -1, 123, -1, -1, 126, -1, 412, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 33, 254, -1, 124, -1, -1, + -1, 40, -1, -1, 43, 94, 45, -1, 267, -1, + 269, -1, -1, -1, -1, -1, 275, -1, 277, -1, + 279, -1, 281, -1, 283, -1, -1, -1, 287, -1, + -1, -1, -1, -1, 293, 124, -1, -1, 256, 257, + -1, -1, 260, 261, 262, -1, -1, -1, 266, 267, + 268, 269, 270, 271, 272, 273, 274, -1, 317, 318, + 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, + 298, 299, 300, -1, 123, -1, 345, 126, 306, -1, + 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, + -1, -1, 320, -1, -1, -1, -1, 256, 257, 327, + 328, 260, 261, 262, -1, -1, -1, 266, 267, 268, + 269, 270, 271, 272, 273, 274, -1, -1, -1, 278, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, + 299, 300, -1, -1, -1, -1, -1, 306, -1, 308, + 309, 310, 311, 312, 313, 314, 315, 316, 317, -1, + -1, 320, -1, 33, 301, 302, 303, 304, 327, 328, + 40, -1, -1, 43, -1, 45, 301, 302, 303, 304, + -1, 318, 319, -1, 321, 322, 323, 324, -1, 326, + -1, -1, -1, -1, -1, -1, 321, 322, 323, 324, + -1, 326, 301, 302, 303, 304, -1, -1, 257, -1, + -1, 260, 261, 262, -1, -1, -1, 266, 267, 268, + 269, 270, 321, 322, 323, 324, -1, 326, -1, 278, + 279, -1, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, + 299, 300, -1, 123, -1, -1, 126, 306, -1, 308, + 309, 310, 311, 312, 313, 314, 315, 316, 317, -1, + 33, 320, -1, -1, -1, -1, -1, 40, 327, 328, + 43, -1, 45, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 33, -1, -1, -1, -1, -1, + -1, 40, 41, -1, 43, -1, 45, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 123, -1, -1, 126, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 38, -1, -1, -1, -1, -1, 257, -1, -1, + 260, 261, 262, -1, -1, -1, 266, 267, 268, 269, + 270, 58, -1, -1, 61, -1, 63, -1, 278, 279, + -1, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 126, 298, 299, + 300, -1, -1, -1, -1, -1, 306, 94, 308, 309, + 310, 311, 312, 313, 314, 315, 316, 317, -1, 33, + 320, -1, -1, -1, -1, -1, 40, 327, 328, 43, + 41, 45, -1, 44, -1, -1, -1, 124, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 58, 59, -1, + 61, -1, 63, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 257, -1, -1, 260, 261, 262, + -1, -1, -1, 266, 267, 268, 269, 270, -1, -1, + -1, -1, 93, -1, -1, 278, 279, -1, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + 293, 294, 295, 296, -1, 298, 299, 300, -1, -1, + -1, -1, 126, 306, -1, 308, 309, 310, 311, 312, + 313, 314, 315, 316, 317, -1, -1, 320, 257, -1, + -1, 260, 261, 262, 327, 328, 33, 266, 267, 268, + 269, 270, -1, 40, 41, -1, 43, -1, 45, 278, + 279, -1, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, -1, 298, + 299, 300, -1, -1, -1, -1, 263, 306, -1, 308, + 309, 310, 311, 312, 313, 314, 315, 316, 317, -1, + -1, 320, -1, -1, -1, -1, -1, -1, 327, 328, + 33, -1, -1, -1, -1, -1, -1, 40, 41, -1, + 43, -1, 45, -1, 301, 302, 303, 304, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 126, + -1, 318, 319, -1, 321, 322, 323, 324, -1, 326, + -1, -1, 256, 257, -1, -1, 260, 261, 262, -1, + -1, -1, 266, 267, 268, 269, 270, -1, -1, -1, + 271, 272, 273, 274, 278, 279, -1, 281, 282, 283, + 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, + 294, 295, 296, -1, 298, 299, 300, -1, -1, -1, + -1, -1, 306, 126, 308, 309, 310, 311, 312, 313, + 314, 315, 316, 317, -1, -1, 320, -1, -1, -1, + -1, 33, -1, 327, 328, -1, 327, 328, 40, -1, + -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 61, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 257, -1, -1, 260, 261, 262, -1, -1, -1, 266, + 267, 268, 269, 270, -1, -1, -1, -1, -1, -1, + -1, 278, 279, -1, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, + -1, 298, 299, 300, 126, -1, -1, -1, -1, 306, + -1, 308, 309, 310, 311, 312, 313, 314, 315, 316, + 317, -1, 41, 320, 257, 44, -1, 260, 261, 262, + 327, 328, -1, 266, 267, 268, 269, 270, -1, 58, + 59, -1, 61, -1, 63, 278, 279, -1, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + 293, 294, 295, 296, -1, 298, 299, 300, -1, -1, + -1, -1, -1, 306, 93, 308, 309, 310, 311, 312, + 313, 314, 315, 316, 317, -1, 33, 320, -1, -1, + -1, -1, -1, 40, 327, 328, 43, -1, 45, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 61, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 257, -1, -1, 260, 261, + 262, -1, -1, -1, 266, 267, 268, 269, 270, -1, + -1, -1, -1, -1, -1, -1, 278, 279, -1, 281, + 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, + 292, 293, 294, 295, 296, -1, 298, 299, 300, 126, + -1, -1, 41, -1, 306, 44, 308, 309, 310, 311, + 312, 313, 314, 315, 316, 317, -1, 33, 320, 58, + 59, -1, 61, -1, 40, 327, 328, 43, -1, 45, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 61, -1, -1, -1, -1, + -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 263, -1, -1, -1, -1, -1, + -1, -1, 271, 272, 273, 274, -1, -1, -1, -1, + -1, 33, -1, -1, -1, -1, -1, -1, 40, -1, + -1, 43, -1, 45, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 61, + 126, -1, -1, -1, -1, -1, -1, -1, -1, 318, + 319, -1, -1, -1, 38, -1, -1, -1, 327, 328, + 257, -1, -1, 260, 261, 262, -1, -1, -1, 266, + 267, 268, 269, 270, -1, -1, -1, 61, -1, 63, + -1, 278, 279, -1, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, + -1, 298, 299, 300, 126, -1, -1, -1, -1, 306, + 94, 308, 309, 310, 311, 312, 313, 314, 315, 316, + 317, -1, 33, 320, -1, -1, -1, -1, -1, 40, + 327, 328, 43, -1, 45, -1, -1, -1, -1, -1, + 124, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 61, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 271, 272, 273, 274, -1, -1, -1, -1, + -1, 257, -1, -1, 260, 261, 262, -1, -1, -1, + 266, 267, 268, 269, 270, -1, -1, -1, -1, -1, + -1, -1, 278, 279, -1, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, -1, 298, 299, 300, 126, -1, -1, 327, 328, + 306, -1, 308, 309, 310, 311, 312, 313, 314, 315, + 316, 317, -1, 41, 320, 257, 44, -1, 260, 261, + 262, 327, 328, -1, 266, 267, 268, 269, 270, -1, + 58, 59, -1, 61, -1, 63, 278, 279, -1, 281, + 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, + 292, 293, 294, 295, 296, -1, 298, 299, 300, 263, + -1, -1, -1, -1, 306, 93, 308, 309, 310, 311, + 312, 313, 314, 315, 316, 317, -1, 33, 320, -1, + -1, -1, -1, -1, 40, 327, 328, 43, -1, 45, + -1, -1, -1, -1, -1, -1, -1, 301, 302, 303, + 304, -1, -1, -1, -1, 61, -1, -1, -1, -1, + -1, -1, -1, -1, 318, 319, 38, 321, 322, 323, + 324, -1, 326, -1, -1, -1, 257, -1, -1, 260, + 261, 262, -1, -1, -1, 266, 267, 268, 269, 270, + -1, 63, -1, -1, -1, -1, -1, 278, 279, -1, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, 293, 294, 295, 296, -1, 298, 299, 300, + 126, -1, 94, -1, -1, 306, -1, 308, 309, 310, + 311, 312, 313, 314, 315, 316, 317, -1, 33, 320, + -1, -1, -1, -1, -1, 40, 327, 328, 43, -1, + 45, -1, 124, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 61, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 263, -1, -1, -1, -1, + -1, -1, -1, 271, 272, 273, 274, -1, -1, -1, + -1, -1, 33, -1, -1, -1, -1, -1, -1, 40, + -1, -1, 43, -1, 45, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 61, 126, -1, -1, -1, -1, -1, -1, -1, -1, + 318, -1, -1, -1, -1, -1, -1, -1, -1, 327, + 328, 257, -1, -1, 260, 261, 262, -1, -1, -1, + 266, 267, 268, 269, 270, -1, -1, -1, -1, -1, + -1, -1, 278, 279, -1, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 263, 298, 299, 300, 126, -1, -1, -1, -1, + 306, -1, 308, 309, 310, 311, 312, 313, 314, 315, + 316, 317, -1, -1, 320, -1, 33, -1, -1, -1, + -1, 327, 328, 40, 41, -1, 43, -1, 45, 301, + 302, 303, 304, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 318, 319, -1, 321, + 322, 323, 324, -1, 326, -1, -1, -1, -1, -1, + -1, -1, 257, -1, -1, 260, 261, 262, -1, -1, + -1, 266, 267, 268, 269, 270, -1, -1, -1, -1, + -1, -1, -1, 278, 279, -1, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, -1, 298, 299, 300, -1, -1, -1, 126, + -1, 306, -1, 308, 309, 310, 311, 312, 313, 314, + 315, 316, 317, -1, -1, 320, 257, -1, -1, 260, + 261, 262, 327, 328, 33, 266, 267, 268, 269, 270, + -1, 40, 41, -1, 43, -1, 45, 278, 279, -1, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, 293, 294, 295, 296, -1, 298, 299, 300, + -1, -1, -1, -1, -1, 306, -1, 308, 309, 310, + 311, 312, 313, 314, 315, 316, 317, -1, -1, 320, + -1, -1, -1, -1, -1, -1, 327, 328, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, + -1, -1, -1, -1, -1, 40, 41, -1, 43, -1, + 45, -1, -1, -1, -1, -1, -1, 126, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 257, -1, -1, 260, 261, 262, -1, -1, -1, 266, + 267, 268, 269, 270, -1, -1, -1, -1, -1, -1, + -1, 278, 279, -1, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, + -1, 298, 299, 300, -1, -1, -1, -1, -1, 306, + -1, 308, 309, 310, 311, 312, 313, 314, 315, 316, + 317, 126, -1, 320, -1, 33, -1, -1, -1, -1, + 327, 328, 40, 41, -1, 43, -1, 45, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 257, -1, + -1, 260, 261, 262, -1, -1, -1, 266, 267, 268, + 269, 270, -1, -1, -1, -1, -1, -1, -1, 278, + 279, -1, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, 126, 298, + 299, 300, -1, -1, -1, -1, -1, 306, -1, 308, + 309, 310, 311, 312, 313, 314, 315, 316, 317, -1, + -1, 320, -1, -1, 38, -1, -1, -1, 327, 328, + 44, -1, 257, -1, -1, 260, 261, 262, -1, -1, + -1, 266, 267, 268, 269, 270, -1, 61, -1, 63, + -1, -1, -1, 278, 279, -1, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, -1, 298, 299, 300, -1, -1, -1, -1, + 94, 306, -1, 308, 309, 310, 311, 312, 313, 314, + 315, 316, 317, -1, -1, 320, -1, 33, -1, -1, + -1, -1, 327, 328, 40, 41, -1, 43, -1, 45, + 124, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, + -1, -1, 260, 261, 262, -1, -1, -1, 266, 267, + 268, 269, 270, -1, -1, -1, -1, -1, -1, -1, + 278, 279, -1, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, 293, 294, 295, 296, -1, + 298, 299, 300, -1, -1, -1, 41, -1, 306, 44, + 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, + 126, 33, 320, 58, 59, -1, -1, -1, 40, 327, + 328, 43, -1, 45, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 93, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 263, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, + -1, -1, -1, -1, -1, 40, -1, -1, 43, -1, + 45, -1, -1, -1, 126, -1, -1, 301, 302, 303, + 304, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 318, 319, -1, 321, 322, 323, + 324, -1, 326, 327, 328, -1, -1, -1, -1, -1, + -1, 257, -1, -1, 260, 261, 262, -1, -1, -1, + 266, 267, 268, 269, 270, -1, -1, -1, -1, -1, + -1, -1, 278, 279, -1, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 126, 298, 299, 300, -1, -1, -1, -1, -1, + 306, -1, 308, 309, 310, 311, 312, 313, 314, 315, + 316, 317, -1, 33, 320, -1, -1, -1, -1, -1, + 40, 327, 328, 43, -1, 45, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 271, 272, 273, 274, + -1, -1, -1, -1, -1, 257, -1, -1, 260, 261, + 262, -1, -1, -1, 266, 267, 268, 269, 270, -1, + -1, -1, -1, -1, -1, -1, 278, 279, -1, 281, + 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, + 292, 293, 294, 295, 296, -1, 298, 299, 300, -1, + -1, -1, 327, 328, 306, -1, 308, 309, 310, 311, + 312, 313, 314, 315, 316, 317, 126, 33, 320, -1, + -1, -1, -1, -1, 40, 327, 328, 43, -1, 45, + -1, -1, 257, -1, -1, 260, 261, 262, -1, -1, + -1, 266, 267, 268, 269, 270, -1, -1, -1, -1, + -1, -1, -1, 278, 279, -1, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, -1, 298, 299, 300, -1, -1, -1, -1, + -1, 306, -1, 308, 309, 310, 311, 312, 313, 314, + 315, 316, 317, -1, -1, 320, -1, -1, -1, -1, + -1, -1, 327, 328, -1, -1, 38, -1, -1, 41, + 126, -1, 44, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 58, 59, -1, 61, + -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 257, -1, -1, + 260, 261, 262, -1, -1, -1, 266, 267, 268, 269, + 270, 93, 94, -1, -1, -1, -1, -1, 278, 279, + -1, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, -1, 298, 299, + 300, -1, 124, -1, -1, -1, 306, -1, 308, 309, + 310, 311, 312, 313, 314, 315, 316, 317, -1, -1, + 320, -1, -1, -1, -1, -1, -1, 327, 328, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 257, -1, -1, 260, 261, 262, -1, -1, -1, + 266, 267, 268, 269, 270, -1, -1, -1, -1, -1, + -1, -1, 278, 279, -1, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, -1, 298, 299, 300, -1, -1, -1, -1, -1, + 306, -1, 308, 309, 310, 311, 312, 313, 314, 315, + 316, 317, 38, -1, 320, 41, -1, -1, 44, -1, + -1, 327, 328, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 58, 59, -1, 61, 38, 63, -1, 41, + -1, 263, 44, -1, -1, -1, -1, -1, -1, 271, + 272, 273, 274, -1, -1, -1, 58, 59, -1, 61, + -1, 63, -1, -1, -1, -1, -1, 93, 94, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 301, + 302, 303, 304, -1, -1, -1, -1, 38, -1, -1, + 41, 93, 94, 44, -1, -1, 318, 319, 124, 321, + 322, 323, 324, -1, 326, 327, 328, 58, 59, -1, + 61, -1, 63, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 124, -1, 38, -1, -1, 41, -1, -1, + 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 93, 94, 58, 59, -1, 61, -1, 63, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 38, -1, -1, 41, + -1, -1, 44, 124, -1, -1, -1, -1, -1, 93, + 94, -1, -1, -1, -1, -1, 58, 59, -1, 61, + -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 38, -1, -1, 41, -1, -1, 44, + 124, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 93, 94, 58, 59, -1, 61, -1, 63, -1, + -1, -1, -1, -1, -1, -1, -1, 263, -1, -1, + -1, -1, -1, -1, -1, 271, 272, 273, 274, -1, + -1, -1, 124, -1, -1, -1, -1, -1, 93, 94, + -1, 263, -1, -1, -1, -1, -1, -1, -1, 271, + 272, 273, 274, -1, -1, 301, 302, 303, 304, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 38, 124, + -1, 41, 318, 319, 44, 321, 322, 323, 324, -1, + 326, 327, 328, -1, -1, -1, -1, -1, 58, 59, + -1, 61, 263, 63, -1, -1, 318, 319, -1, -1, + 271, 272, 273, 274, -1, 327, 328, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 93, 94, -1, -1, -1, -1, 263, + 301, 302, 303, 304, -1, -1, -1, 271, 272, 273, + 274, -1, -1, 41, -1, -1, 44, 318, 319, -1, + 321, 322, 323, 324, 124, 326, 327, 328, -1, -1, + 58, 59, -1, -1, -1, -1, -1, 301, 302, 303, + 304, 263, -1, -1, -1, -1, -1, -1, -1, 271, + 272, 273, 274, -1, 318, 319, -1, 321, 322, 323, + 324, -1, 326, 327, 328, 93, -1, -1, -1, -1, + 38, -1, -1, 41, -1, -1, 44, -1, 263, 301, + 302, 303, 304, -1, -1, -1, 271, 272, 273, 274, + 58, 59, -1, 61, -1, 63, 318, 319, -1, 321, + 322, 323, 324, -1, 326, 327, 328, -1, -1, -1, + 41, -1, -1, 44, -1, -1, 301, 302, 303, 304, + -1, -1, -1, -1, -1, 93, 94, 58, 59, -1, + -1, -1, -1, 318, 319, -1, 321, 322, 323, 324, + -1, 326, 327, 328, 38, -1, -1, 41, -1, -1, + 44, -1, -1, -1, -1, -1, 124, -1, 41, -1, + -1, 44, 93, 263, 58, 59, -1, 61, -1, 63, + -1, 271, 272, 273, 274, 58, 59, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 38, -1, -1, 41, + -1, -1, 44, -1, -1, -1, -1, -1, -1, 93, + 94, 301, 302, 303, 304, -1, 58, 59, -1, 61, + 93, 63, -1, -1, -1, -1, -1, -1, 318, 319, + -1, 321, 322, 323, 324, -1, 326, 327, 328, 38, + 124, -1, 41, -1, -1, 44, -1, -1, -1, -1, + -1, 93, 94, 271, 272, 273, 274, -1, -1, 58, + 59, -1, 61, -1, 63, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 38, 124, -1, 41, -1, -1, 44, -1, -1, + -1, -1, -1, -1, 93, 94, -1, -1, -1, -1, + -1, 58, 59, -1, 61, 263, 63, -1, -1, 327, + 328, -1, -1, 271, 272, 273, 274, -1, -1, -1, + -1, -1, -1, -1, -1, 124, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 93, 94, -1, -1, + -1, -1, -1, 301, 302, 303, 304, -1, -1, -1, + 271, 272, 273, 274, -1, -1, -1, -1, -1, -1, + 318, 319, -1, 321, 322, 323, 324, 124, 326, 327, + 328, 38, -1, -1, 41, -1, -1, 44, -1, 263, + -1, -1, -1, -1, -1, -1, -1, 271, 272, 273, + 274, 58, 59, -1, 61, -1, 63, -1, 271, 272, + 273, 274, -1, -1, -1, -1, 327, 328, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 301, 302, 303, + 304, 263, -1, -1, -1, -1, 93, 94, -1, 271, + 272, 273, 274, -1, 318, 319, -1, 321, 322, 323, + 324, -1, 326, 327, 328, 38, -1, -1, 41, -1, + -1, -1, -1, -1, 327, 328, -1, 124, -1, 301, + 302, 303, 304, -1, 263, 58, 59, -1, 61, -1, + 63, -1, 271, 272, 273, 274, 318, 319, -1, 321, + 322, 323, 324, -1, 326, 327, 328, 38, -1, -1, + 41, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 93, 94, 301, 302, 303, 304, 263, 58, 59, -1, + 61, -1, 63, -1, 271, 272, 273, 274, -1, 318, + 319, -1, 321, 322, 323, 324, -1, 326, 327, 328, + 38, 124, -1, 41, -1, -1, -1, -1, -1, -1, + -1, -1, 93, 94, 301, 302, 303, 304, -1, -1, + 58, 59, -1, 61, -1, 63, -1, -1, -1, -1, + -1, 318, 319, -1, 321, 322, 323, 324, -1, 326, + 327, 328, 38, 124, -1, 41, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 93, 94, -1, -1, -1, + -1, -1, 58, 59, -1, 61, 263, 63, -1, -1, + -1, -1, -1, -1, 271, 272, 273, 274, -1, -1, + -1, -1, -1, -1, -1, -1, 124, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 93, 94, -1, + -1, -1, -1, -1, 301, 302, 303, 304, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 318, 319, -1, 321, 322, 323, 324, 124, 326, + 327, 328, 38, -1, -1, 41, -1, -1, 44, -1, + 263, -1, -1, -1, -1, -1, -1, -1, 271, 272, + 273, 274, 58, 59, -1, 61, -1, 63, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 301, 302, + 303, 304, 263, -1, -1, -1, -1, 93, 94, -1, + 271, 272, 273, 274, -1, 318, 319, -1, 321, 322, + 323, 324, -1, 326, 327, 328, 38, -1, -1, 41, + -1, -1, 44, -1, -1, -1, -1, -1, 124, -1, + 301, 302, 303, 304, -1, 263, 58, 59, -1, 61, + -1, 63, -1, 271, 272, 273, 274, 318, 319, -1, + 321, 322, 323, 324, -1, 326, 327, 328, 38, -1, + -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, + -1, 93, 94, 301, 302, 303, 304, 263, 58, 59, + -1, 61, -1, 63, -1, 271, 272, 273, 274, -1, + 318, 319, -1, 321, 322, 323, 324, -1, 326, 327, + 328, 38, 124, -1, 41, -1, -1, 44, -1, -1, + -1, -1, -1, 93, 94, 301, 302, 303, 304, -1, + -1, 58, 59, -1, 61, -1, 63, -1, -1, -1, + -1, -1, 318, 319, -1, 321, 322, 323, 324, -1, + 326, 327, 328, 38, 124, -1, 41, -1, -1, 44, + -1, -1, -1, -1, -1, -1, 93, 94, -1, -1, + -1, -1, -1, 58, 59, -1, 61, 263, 63, -1, + -1, -1, -1, -1, -1, 271, 272, 273, 274, -1, + -1, -1, -1, -1, -1, -1, -1, 124, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 93, 94, + -1, -1, -1, -1, -1, 301, 302, 303, 304, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 318, 319, -1, 321, 322, 323, 324, 124, + -1, 327, 328, 38, -1, -1, 41, -1, -1, 44, + -1, 263, -1, -1, -1, -1, -1, -1, -1, 271, + 272, 273, 274, 58, 59, -1, 61, -1, 63, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, + -1, 44, -1, -1, -1, -1, -1, -1, -1, 301, + 302, 303, 304, 263, -1, 58, 59, -1, 93, 94, + -1, 271, 272, 273, 274, -1, 318, 319, -1, 321, + 322, 323, 324, -1, -1, 327, 328, 38, -1, -1, + 41, -1, -1, 44, -1, -1, -1, -1, -1, 124, + 93, 301, 302, 303, 304, -1, 263, 58, 59, -1, + 61, -1, 63, -1, 271, 272, 273, 274, 318, 319, + -1, 321, 322, 323, 324, -1, -1, 327, 328, 38, + -1, -1, 41, -1, -1, 44, -1, -1, -1, -1, + -1, -1, 93, 94, 301, 302, 303, 304, 263, 58, + 59, -1, 61, -1, 63, -1, 271, 272, 273, 274, + -1, 318, 319, -1, 321, 322, -1, -1, -1, -1, + 327, 328, 38, 124, -1, 41, -1, -1, 44, -1, + -1, -1, -1, -1, 93, 94, 301, 302, -1, 304, + -1, -1, 58, 59, -1, 61, 38, 63, -1, 41, + -1, -1, 44, 318, 319, -1, 321, 322, 41, -1, + -1, 44, 327, 328, -1, 124, 58, 59, -1, 61, + -1, 63, -1, -1, -1, 58, 59, 93, 94, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 263, -1, + -1, -1, -1, -1, -1, -1, 271, 272, 273, 274, + -1, 93, 94, -1, -1, -1, -1, -1, 124, -1, + 93, -1, -1, 38, -1, -1, 41, -1, -1, 44, + -1, -1, -1, -1, -1, -1, 301, 302, 271, 272, + 273, 274, 124, 58, 59, -1, 61, -1, 63, -1, + -1, -1, -1, 318, 319, -1, 321, 322, -1, -1, + -1, -1, 327, 328, 38, -1, -1, 41, -1, -1, + 44, -1, 263, -1, -1, -1, -1, -1, 93, 94, + 271, 272, 273, 274, 58, 59, -1, 61, -1, 63, + -1, -1, -1, -1, 327, 328, -1, -1, -1, 41, + -1, -1, 44, -1, -1, -1, -1, -1, -1, 124, + 301, 302, -1, -1, 263, -1, 58, 59, -1, 93, + 94, -1, 271, 272, 273, 274, -1, 318, 319, -1, + 321, 322, -1, -1, -1, -1, 327, 328, 38, -1, + -1, 41, -1, -1, 44, -1, -1, -1, -1, -1, + 124, 93, 301, 302, -1, -1, -1, 263, 58, 59, + -1, 61, -1, 63, -1, 271, 272, 273, 274, 318, + 319, -1, -1, -1, -1, -1, -1, -1, 327, 328, + -1, 263, -1, -1, -1, -1, -1, -1, -1, 271, + 272, 273, 274, 93, 94, 301, 302, -1, 271, 272, + 273, 274, -1, -1, -1, 38, -1, -1, 41, -1, + -1, 44, 318, 319, 41, -1, -1, 44, -1, 301, + 302, 327, 328, -1, 124, 58, 59, -1, 61, -1, + 63, 58, 59, -1, -1, -1, 318, 319, -1, -1, + -1, -1, -1, -1, -1, 327, 328, -1, 263, -1, + -1, -1, -1, -1, 327, 328, 271, 272, 273, 274, + 93, 94, -1, -1, -1, -1, 93, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 302, -1, 263, + -1, 124, -1, -1, -1, -1, -1, 271, 272, 273, + 274, -1, 38, 318, 319, 41, -1, -1, 44, -1, + -1, -1, 327, 328, 38, -1, -1, 41, -1, -1, + 44, -1, 58, 59, -1, 61, -1, 63, -1, 271, + 272, 273, 274, -1, 58, 59, -1, 61, -1, 63, + -1, -1, -1, -1, 318, 319, -1, -1, -1, -1, + -1, -1, -1, 327, 328, -1, -1, 93, 94, -1, + -1, -1, -1, 263, -1, -1, -1, -1, -1, 93, + 94, 271, 272, 273, 274, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 327, 328, 38, 124, -1, + 41, -1, -1, 44, -1, -1, -1, -1, -1, -1, + 124, 301, 302, 303, 304, -1, -1, 58, 59, -1, + 61, -1, 63, -1, -1, -1, -1, -1, 318, 319, + -1, 321, 322, 323, 324, -1, 326, -1, -1, -1, + 263, -1, -1, -1, -1, -1, -1, -1, 271, 272, + 273, 274, 93, 94, 271, 272, 273, 274, -1, -1, + -1, -1, -1, -1, 38, -1, -1, 41, -1, -1, + 44, -1, -1, -1, -1, -1, -1, -1, 301, 302, + 303, 304, -1, 124, 58, 59, -1, 61, -1, 63, + 41, -1, -1, 44, -1, 318, 319, -1, 321, 322, + 323, 324, -1, 326, -1, -1, -1, 58, 59, -1, + 327, 328, -1, -1, -1, -1, -1, -1, -1, 93, + 94, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 263, -1, -1, + -1, -1, 93, -1, -1, 271, 272, 273, 274, 263, + 124, -1, -1, -1, -1, -1, -1, 271, 272, 273, + 274, 38, -1, -1, 41, -1, -1, 44, -1, -1, + -1, -1, -1, -1, -1, 301, 302, 303, 304, -1, + -1, 58, 59, -1, 61, -1, 63, 301, 302, 303, + 304, -1, 318, 319, -1, 321, 322, 323, 324, -1, + 326, -1, -1, -1, 318, 319, -1, 321, 322, 323, + 324, -1, 326, -1, -1, -1, 93, 94, 38, -1, + -1, 41, 263, -1, 44, -1, -1, -1, -1, -1, + 271, 272, 273, 274, -1, -1, -1, -1, 58, 59, + -1, 61, -1, 63, -1, 38, -1, 124, 41, -1, + -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, + 301, 302, 303, 304, -1, -1, -1, -1, 61, -1, + 63, -1, -1, 93, 94, -1, -1, 318, 319, -1, + 321, 322, 323, 324, -1, 326, -1, 38, -1, 263, + 41, -1, -1, 44, -1, -1, -1, 271, 272, 273, + 274, 94, -1, -1, 124, -1, -1, 58, 59, -1, + 61, -1, 63, 38, -1, -1, 41, -1, -1, 44, + 271, 272, 273, 274, -1, -1, -1, 301, 302, 303, + 304, 124, -1, 58, 59, -1, 61, -1, 63, -1, + -1, -1, 93, 94, 318, 319, -1, 321, 322, 323, + 324, -1, 326, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 38, -1, -1, -1, 93, 94, + 44, -1, -1, 124, -1, 38, 327, 328, -1, -1, + -1, 44, -1, -1, -1, -1, 263, 61, 41, 63, + -1, 44, -1, -1, 271, 272, 273, 274, 61, 124, + 63, -1, -1, -1, -1, 58, 59, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 94, -1, -1, -1, 301, 302, 303, 304, -1, -1, + -1, 94, -1, -1, -1, -1, -1, -1, -1, -1, + 93, 318, 319, 263, 321, 322, 323, 324, -1, 326, + 124, 271, 272, 273, 274, -1, -1, -1, -1, -1, + -1, 124, -1, -1, -1, -1, 33, -1, -1, -1, + 263, -1, -1, 40, -1, -1, 43, -1, 45, -1, + -1, 301, 302, 303, 304, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 318, 319, + -1, 321, 322, 323, 324, -1, 326, -1, 301, 302, + 303, 304, 263, -1, -1, -1, -1, -1, -1, -1, + 271, 272, 273, 274, 91, 318, 319, -1, 321, 322, + 323, 324, -1, 326, -1, -1, -1, -1, 263, -1, + 41, -1, -1, 44, -1, -1, 271, 272, 273, 274, + 301, 302, 303, 304, -1, -1, 123, 58, 59, 126, + -1, -1, -1, 41, -1, -1, 44, 318, 319, -1, + 321, 322, 323, 324, -1, 326, 301, 302, 303, 304, + 58, 59, -1, 61, -1, 63, -1, -1, -1, 263, + -1, -1, 93, 318, 319, -1, 321, 322, 323, 324, + 263, 326, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 41, 93, 94, 44, 271, 272, + 273, 274, -1, -1, -1, -1, -1, 301, 302, 303, + 304, 58, 59, -1, 61, -1, 63, -1, 301, 302, + 303, 304, -1, -1, 318, 319, 124, 321, 322, 323, + 324, -1, 326, -1, -1, 318, 319, -1, 321, 322, + 323, 324, -1, 326, -1, -1, 93, 94, -1, -1, + -1, -1, -1, -1, 327, 328, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 257, -1, -1, 260, 261, 262, -1, 124, -1, 266, + 267, 268, 269, 270, -1, -1, -1, -1, -1, -1, + -1, 278, 279, -1, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, + -1, 298, 299, 300, -1, -1, -1, -1, -1, 306, + -1, 308, 309, 310, 311, 312, 313, 314, 315, 316, + 317, -1, -1, 320, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 271, 272, 273, 274, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 263, -1, -1, -1, -1, + -1, -1, -1, 271, 272, 273, 274, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 66, -1, -1, -1, -1, -1, 72, -1, + -1, -1, -1, -1, -1, -1, 327, 328, -1, -1, + -1, -1, -1, -1, -1, -1, 263, -1, -1, -1, + 318, 319, -1, -1, 271, 272, 273, 274, -1, 327, + 328, -1, -1, 107, -1, 109, -1, 111, -1, 113, + -1, -1, 116, -1, 118, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 128, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 142, -1, + -1, 318, 319, 147, 148, 149, 150, 151, 152, 153, + 327, 328, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 170, 171, 172, 173, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 202, 203, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 218, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 241, -1, 243, + 244, -1, -1, -1, -1, -1, -1, -1, 252, -1, + -1, -1, -1, 257, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 291, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 301, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 311, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 330, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 341, +}; +#define YYFINAL 1 +#ifndef YYDEBUG +#define YYDEBUG 0 +#endif +#define YYMAXTOKEN 328 +#if YYDEBUG +char *yyname[] = { +"end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +"'!'",0,0,0,0,"'&'",0,"'('","')'",0,"'+'","','","'-'",0,0,0,0,0,0,0,0,0,0,0,0, +"':'","';'",0,"'='",0,"'?'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,"'['",0,"']'","'^'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +"'{'","'|'","'}'","'~'",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"WORD","LABEL","APPEND","OPEN", +"SSELECT","LOOPEX","DOTDOT","USING","FORMAT","DO","SHIFT","PUSH","POP", +"LVALFUN","WHILE","UNTIL","IF","UNLESS","ELSE","ELSIF","CONTINUE","SPLIT", +"FLIST","FOR","FILOP","FILOP2","FILOP3","FILOP4","FILOP22","FILOP25","FUNC0", +"FUNC1","FUNC2","FUNC2x","FUNC3","FUNC4","FUNC5","HSHFUN","HSHFUN3","FLIST2", +"SUB","FILETEST","LOCAL","DELETE","RELOP","EQOP","MULOP","ADDOP","PACKAGE", +"AMPER","FORMLIST","REG","ARYLEN","ARY","HSH","STAR","SUBST","PATTERN", +"RSTRING","TRANS","LISTOP","OROR","ANDAND","UNIOP","LS","RS","MATCH","NMATCH", +"UMINUS","POW","INC","DEC", +}; +char *yyrule[] = { +"$accept : prog", +"$$1 :", +"prog : $$1 lineseq", +"compblock : block CONTINUE block", +"compblock : block else", +"else :", +"else : ELSE block", +"else : ELSIF '(' expr ')' compblock", +"block : '{' remember lineseq '}'", +"remember :", +"lineseq :", +"lineseq : lineseq line", +"line : decl", +"line : label cond", +"line : loop", +"line : label ';'", +"line : label sideff ';'", +"sideff : error", +"sideff : expr", +"sideff : expr IF expr", +"sideff : expr UNLESS expr", +"sideff : expr WHILE expr", +"sideff : expr UNTIL expr", +"cond : IF '(' expr ')' compblock", +"cond : UNLESS '(' expr ')' compblock", +"cond : IF block compblock", +"cond : UNLESS block compblock", +"loop : label WHILE '(' texpr ')' compblock", +"loop : label UNTIL '(' expr ')' compblock", +"loop : label WHILE block compblock", +"loop : label UNTIL block compblock", +"loop : label FOR REG '(' expr crp compblock", +"loop : label FOR '(' expr crp compblock", +"loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' block", +"loop : label compblock", +"nexpr :", +"nexpr : sideff", +"texpr :", +"texpr : expr", +"label :", +"label : LABEL", +"decl : format", +"decl : subrout", +"decl : package", +"format : FORMAT WORD '=' FORMLIST", +"format : FORMAT '=' FORMLIST", +"subrout : SUB WORD block", +"package : PACKAGE WORD ';'", +"cexpr : ',' expr", +"expr : expr ',' sexpr", +"expr : sexpr", +"csexpr : ',' sexpr", +"sexpr : sexpr '=' sexpr", +"sexpr : sexpr POW '=' sexpr", +"sexpr : sexpr MULOP '=' sexpr", +"sexpr : sexpr ADDOP '=' sexpr", +"sexpr : sexpr LS '=' sexpr", +"sexpr : sexpr RS '=' sexpr", +"sexpr : sexpr '&' '=' sexpr", +"sexpr : sexpr '^' '=' sexpr", +"sexpr : sexpr '|' '=' sexpr", +"sexpr : sexpr POW sexpr", +"sexpr : sexpr MULOP sexpr", +"sexpr : sexpr ADDOP sexpr", +"sexpr : sexpr LS sexpr", +"sexpr : sexpr RS sexpr", +"sexpr : sexpr RELOP sexpr", +"sexpr : sexpr EQOP sexpr", +"sexpr : sexpr '&' sexpr", +"sexpr : sexpr '^' sexpr", +"sexpr : sexpr '|' sexpr", +"sexpr : sexpr DOTDOT sexpr", +"sexpr : sexpr ANDAND sexpr", +"sexpr : sexpr OROR sexpr", +"sexpr : sexpr '?' sexpr ':' sexpr", +"sexpr : sexpr MATCH sexpr", +"sexpr : sexpr NMATCH sexpr", +"sexpr : term", +"term : '-' term", +"term : '+' term", +"term : '!' term", +"term : '~' term", +"term : term INC", +"term : term DEC", +"term : INC term", +"term : DEC term", +"term : FILETEST WORD", +"term : FILETEST sexpr", +"term : FILETEST", +"term : LOCAL '(' expr crp", +"term : '(' expr crp", +"term : '(' ')'", +"term : DO sexpr", +"term : DO block", +"term : REG", +"term : STAR", +"term : REG '[' expr ']'", +"term : HSH", +"term : ARY", +"term : REG '{' expr ';' '}'", +"term : '(' expr crp '[' expr ']'", +"term : '(' ')' '[' expr ']'", +"term : ARY '[' expr ']'", +"term : ARY '{' expr ';' '}'", +"term : DELETE REG '{' expr ';' '}'", +"term : DELETE '(' REG '{' expr ';' '}' ')'", +"term : ARYLEN", +"term : RSTRING", +"term : PATTERN", +"term : SUBST", +"term : TRANS", +"term : DO WORD '(' expr crp", +"term : AMPER WORD '(' expr crp", +"term : DO WORD '(' ')'", +"term : AMPER WORD '(' ')'", +"term : AMPER WORD", +"term : DO REG '(' expr crp", +"term : AMPER REG '(' expr crp", +"term : DO REG '(' ')'", +"term : AMPER REG '(' ')'", +"term : AMPER REG", +"term : LOOPEX", +"term : LOOPEX WORD", +"term : UNIOP", +"term : UNIOP block", +"term : UNIOP sexpr", +"term : SSELECT", +"term : SSELECT WORD", +"term : SSELECT '(' handle ')'", +"term : SSELECT '(' sexpr csexpr csexpr csexpr ')'", +"term : OPEN WORD", +"term : OPEN '(' WORD ')'", +"term : OPEN '(' handle cexpr ')'", +"term : FILOP '(' handle ')'", +"term : FILOP WORD", +"term : FILOP REG", +"term : FILOP '(' ')'", +"term : FILOP", +"term : FILOP2 '(' handle cexpr ')'", +"term : FILOP3 '(' handle csexpr cexpr ')'", +"term : FILOP22 '(' handle ',' handle ')'", +"term : FILOP4 '(' handle csexpr csexpr cexpr ')'", +"term : FILOP25 '(' handle ',' handle csexpr csexpr cexpr ')'", +"term : PUSH '(' aryword ',' expr crp", +"term : POP aryword", +"term : POP '(' aryword ')'", +"term : SHIFT aryword", +"term : SHIFT '(' aryword ')'", +"term : SHIFT", +"term : SPLIT", +"term : SPLIT '(' sexpr csexpr csexpr ')'", +"term : SPLIT '(' sexpr csexpr ')'", +"term : SPLIT '(' sexpr ')'", +"term : FLIST2 '(' sexpr cexpr ')'", +"term : FLIST '(' expr crp", +"term : LVALFUN sexpr", +"term : LVALFUN", +"term : FUNC0", +"term : FUNC0 '(' ')'", +"term : FUNC1 '(' ')'", +"term : FUNC1 '(' expr ')'", +"term : FUNC2 '(' sexpr cexpr ')'", +"term : FUNC2x '(' sexpr csexpr ')'", +"term : FUNC2x '(' sexpr csexpr cexpr ')'", +"term : FUNC3 '(' sexpr csexpr cexpr ')'", +"term : FUNC4 '(' sexpr csexpr csexpr cexpr ')'", +"term : FUNC5 '(' sexpr csexpr csexpr csexpr cexpr ')'", +"term : HSHFUN '(' hshword ')'", +"term : HSHFUN hshword", +"term : HSHFUN3 '(' hshword csexpr cexpr ')'", +"term : bareword", +"term : listop", +"listop : LISTOP", +"listop : LISTOP expr", +"listop : LISTOP WORD", +"listop : LISTOP WORD expr", +"listop : LISTOP REG expr", +"listop : LISTOP block expr", +"handle : WORD", +"handle : sexpr", +"aryword : WORD", +"aryword : ARY", +"hshword : WORD", +"hshword : HSH", +"crp : ',' ')'", +"crp : ')'", +"bareword : WORD", +}; +#endif +#ifdef YYSTACKSIZE +#undef YYMAXDEPTH +#define YYMAXDEPTH YYSTACKSIZE +#else +#ifdef YYMAXDEPTH +#define YYSTACKSIZE YYMAXDEPTH +#else +#define YYSTACKSIZE 500 +#define YYMAXDEPTH 500 +#endif +#endif +int yydebug; +int yynerrs; +int yyerrflag; +int yychar; +short *yyssp; +YYSTYPE *yyvsp; +YYSTYPE yyval; +YYSTYPE yylval; +short yyss[YYSTACKSIZE]; +YYSTYPE yyvs[YYSTACKSIZE]; +#define yystacksize YYSTACKSIZE +#line 876 "perly.y" + /* PROGRAM */ +#line 1820 "y.tab.c" +#define YYABORT goto yyabort +#define YYREJECT goto yyabort +#define YYACCEPT goto yyaccept +#define YYERROR goto yyerrlab +int +yyparse() +{ + register int yym, yyn, yystate; +#if YYDEBUG + register char *yys; + extern char *getenv(); + + if (yys = getenv("YYDEBUG")) + { + yyn = *yys; + if (yyn >= '0' && yyn <= '9') + yydebug = yyn - '0'; + } +#endif + + yynerrs = 0; + yyerrflag = 0; + yychar = (-1); + + yyssp = yyss; + yyvsp = yyvs; + *yyssp = yystate = 0; + +yyloop: + if (yyn = yydefred[yystate]) goto yyreduce; + if (yychar < 0) + { + if ((yychar = yylex()) < 0) yychar = 0; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + printf("%sdebug: state %d, reading %d (%s)\n", + YYPREFIX, yystate, yychar, yys); + } +#endif + } + if ((yyn = yysindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, shifting to state %d\n", + YYPREFIX, yystate, yytable[yyn]); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + goto yyoverflow; + } + *++yyssp = yystate = yytable[yyn]; + *++yyvsp = yylval; + yychar = (-1); + if (yyerrflag > 0) --yyerrflag; + goto yyloop; + } + if ((yyn = yyrindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { + yyn = yytable[yyn]; + goto yyreduce; + } + if (yyerrflag) goto yyinrecovery; +#ifdef lint + goto yynewerror; +#endif +yynewerror: + yyerror("syntax error"); +#ifdef lint + goto yyerrlab; +#endif +yyerrlab: + ++yynerrs; +yyinrecovery: + if (yyerrflag < 3) + { + yyerrflag = 3; + for (;;) + { + if ((yyn = yysindex[*yyssp]) && (yyn += YYERRCODE) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == YYERRCODE) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, error recovery shifting\ + to state %d\n", YYPREFIX, *yyssp, yytable[yyn]); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + goto yyoverflow; + } + *++yyssp = yystate = yytable[yyn]; + *++yyvsp = yylval; + goto yyloop; + } + else + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: error recovery discarding state %d\n", + YYPREFIX, *yyssp); +#endif + if (yyssp <= yyss) goto yyabort; + --yyssp; + --yyvsp; + } + } + } + else + { + if (yychar == 0) goto yyabort; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + printf("%sdebug: state %d, error recovery discards token %d (%s)\n", + YYPREFIX, yystate, yychar, yys); + } +#endif + yychar = (-1); + goto yyloop; + } +yyreduce: +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, reducing by rule %d (%s)\n", + YYPREFIX, yystate, yyn, yyrule[yyn]); +#endif + yym = yylen[yyn]; + yyval = yyvsp[1-yym]; + switch (yyn) + { +case 1: +#line 115 "perly.y" +{ +#if defined(YYDEBUG) && defined(DEBUGGING) + yydebug = (debug & 1); +#endif + expectterm = 2; + } +break; +case 2: +#line 122 "perly.y" +{ if (in_eval) + eval_root = block_head(yyvsp[0].cmdval); + else + main_root = block_head(yyvsp[0].cmdval); } +break; +case 3: +#line 129 "perly.y" +{ yyval.compval.comp_true = yyvsp[-2].cmdval; yyval.compval.comp_alt = yyvsp[0].cmdval; } +break; +case 4: +#line 131 "perly.y" +{ yyval.compval.comp_true = yyvsp[-1].cmdval; yyval.compval.comp_alt = yyvsp[0].cmdval; } +break; +case 5: +#line 135 "perly.y" +{ yyval.cmdval = Nullcmd; } +break; +case 6: +#line 137 "perly.y" +{ yyval.cmdval = yyvsp[0].cmdval; } +break; +case 7: +#line 139 "perly.y" +{ cmdline = yyvsp[-4].ival; + yyval.cmdval = make_ccmd(C_ELSIF,1,yyvsp[-2].arg,yyvsp[0].compval); } +break; +case 8: +#line 144 "perly.y" +{ yyval.cmdval = block_head(yyvsp[-1].cmdval); + if (cmdline > (line_t)yyvsp[-3].ival) + cmdline = yyvsp[-3].ival; + if (savestack->ary_fill > yyvsp[-2].ival) + restorelist(yyvsp[-2].ival); + expectterm = 2; } +break; +case 9: +#line 153 "perly.y" +{ yyval.ival = savestack->ary_fill; } +break; +case 10: +#line 157 "perly.y" +{ yyval.cmdval = Nullcmd; } +break; +case 11: +#line 159 "perly.y" +{ yyval.cmdval = append_line(yyvsp[-1].cmdval,yyvsp[0].cmdval); } +break; +case 12: +#line 163 "perly.y" +{ yyval.cmdval = Nullcmd; } +break; +case 13: +#line 165 "perly.y" +{ yyval.cmdval = add_label(yyvsp[-1].cval,yyvsp[0].cmdval); } +break; +case 15: +#line 168 "perly.y" +{ if (yyvsp[-1].cval != Nullch) { + yyval.cmdval = add_label(yyvsp[-1].cval, make_acmd(C_EXPR, Nullstab, + Nullarg, Nullarg) ); + } + else { + yyval.cmdval = Nullcmd; + cmdline = NOLINE; + } + expectterm = 2; } +break; +case 16: +#line 178 "perly.y" +{ yyval.cmdval = add_label(yyvsp[-2].cval,yyvsp[-1].cmdval); + expectterm = 2; } +break; +case 17: +#line 183 "perly.y" +{ yyval.cmdval = Nullcmd; } +break; +case 18: +#line 185 "perly.y" +{ yyval.cmdval = make_acmd(C_EXPR, Nullstab, yyvsp[0].arg, Nullarg); } +break; +case 19: +#line 187 "perly.y" +{ yyval.cmdval = addcond( + make_acmd(C_EXPR, Nullstab, Nullarg, yyvsp[-2].arg), yyvsp[0].arg); } +break; +case 20: +#line 190 "perly.y" +{ yyval.cmdval = addcond(invert( + make_acmd(C_EXPR, Nullstab, Nullarg, yyvsp[-2].arg)), yyvsp[0].arg); } +break; +case 21: +#line 193 "perly.y" +{ yyval.cmdval = addloop( + make_acmd(C_EXPR, Nullstab, Nullarg, yyvsp[-2].arg), yyvsp[0].arg); } +break; +case 22: +#line 196 "perly.y" +{ yyval.cmdval = addloop(invert( + make_acmd(C_EXPR, Nullstab, Nullarg, yyvsp[-2].arg)), yyvsp[0].arg); } +break; +case 23: +#line 201 "perly.y" +{ cmdline = yyvsp[-4].ival; + yyval.cmdval = make_icmd(C_IF,yyvsp[-2].arg,yyvsp[0].compval); } +break; +case 24: +#line 204 "perly.y" +{ cmdline = yyvsp[-4].ival; + yyval.cmdval = invert(make_icmd(C_IF,yyvsp[-2].arg,yyvsp[0].compval)); } +break; +case 25: +#line 207 "perly.y" +{ cmdline = yyvsp[-2].ival; + yyval.cmdval = make_icmd(C_IF,cmd_to_arg(yyvsp[-1].cmdval),yyvsp[0].compval); } +break; +case 26: +#line 210 "perly.y" +{ cmdline = yyvsp[-2].ival; + yyval.cmdval = invert(make_icmd(C_IF,cmd_to_arg(yyvsp[-1].cmdval),yyvsp[0].compval)); } +break; +case 27: +#line 215 "perly.y" +{ cmdline = yyvsp[-4].ival; + yyval.cmdval = wopt(add_label(yyvsp[-5].cval, + make_ccmd(C_WHILE,1,yyvsp[-2].arg,yyvsp[0].compval) )); } +break; +case 28: +#line 219 "perly.y" +{ cmdline = yyvsp[-4].ival; + yyval.cmdval = wopt(add_label(yyvsp[-5].cval, + invert(make_ccmd(C_WHILE,1,yyvsp[-2].arg,yyvsp[0].compval)) )); } +break; +case 29: +#line 223 "perly.y" +{ cmdline = yyvsp[-2].ival; + yyval.cmdval = wopt(add_label(yyvsp[-3].cval, + make_ccmd(C_WHILE, 1, cmd_to_arg(yyvsp[-1].cmdval),yyvsp[0].compval) )); } +break; +case 30: +#line 227 "perly.y" +{ cmdline = yyvsp[-2].ival; + yyval.cmdval = wopt(add_label(yyvsp[-3].cval, + invert(make_ccmd(C_WHILE,1,cmd_to_arg(yyvsp[-1].cmdval),yyvsp[0].compval)) )); } +break; +case 31: +#line 231 "perly.y" +{ cmdline = yyvsp[-5].ival; + /* + * The following gobbledygook catches EXPRs that + * aren't explicit array refs and translates + * foreach VAR (EXPR) { + * into + * @ary = EXPR; + * foreach VAR (@ary) { + * where @ary is a hidden array made by genstab(). + * (Note that @ary may become a local array if + * it is determined that it might be called + * recursively. See cmd_tosave().) + */ + if (yyvsp[-2].arg->arg_type != O_ARRAY) { + scrstab = aadd(genstab()); + yyval.cmdval = append_line( + make_acmd(C_EXPR, Nullstab, + l(make_op(O_ASSIGN,2, + listish(make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg )), + listish(make_list(yyvsp[-2].arg)), + Nullarg)), + Nullarg), + wopt(over(yyvsp[-4].stabval,add_label(yyvsp[-6].cval, + make_ccmd(C_WHILE, 0, + make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg ), + yyvsp[0].compval))))); + yyval.cmdval->c_line = yyvsp[-5].ival; + yyval.cmdval->c_head->c_line = yyvsp[-5].ival; + } + else { + yyval.cmdval = wopt(over(yyvsp[-4].stabval,add_label(yyvsp[-6].cval, + make_ccmd(C_WHILE,1,yyvsp[-2].arg,yyvsp[0].compval) ))); + } + } +break; +case 32: +#line 270 "perly.y" +{ cmdline = yyvsp[-4].ival; + if (yyvsp[-2].arg->arg_type != O_ARRAY) { + scrstab = aadd(genstab()); + yyval.cmdval = append_line( + make_acmd(C_EXPR, Nullstab, + l(make_op(O_ASSIGN,2, + listish(make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg )), + listish(make_list(yyvsp[-2].arg)), + Nullarg)), + Nullarg), + wopt(over(defstab,add_label(yyvsp[-5].cval, + make_ccmd(C_WHILE, 0, + make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg ), + yyvsp[0].compval))))); + yyval.cmdval->c_line = yyvsp[-4].ival; + yyval.cmdval->c_head->c_line = yyvsp[-4].ival; + } + else { /* lisp, anyone? */ + yyval.cmdval = wopt(over(defstab,add_label(yyvsp[-5].cval, + make_ccmd(C_WHILE,1,yyvsp[-2].arg,yyvsp[0].compval) ))); + } + } +break; +case 33: +#line 298 "perly.y" +{ yyval.compval.comp_true = yyvsp[0].cmdval; + yyval.compval.comp_alt = yyvsp[-2].cmdval; + cmdline = yyvsp[-8].ival; + yyval.cmdval = append_line(yyvsp[-6].cmdval,wopt(add_label(yyvsp[-9].cval, + make_ccmd(C_WHILE,1,yyvsp[-4].arg,yyval.compval) ))); } +break; +case 34: +#line 304 "perly.y" +{ yyval.cmdval = add_label(yyvsp[-1].cval,make_ccmd(C_BLOCK,1,Nullarg,yyvsp[0].compval)); } +break; +case 35: +#line 308 "perly.y" +{ yyval.cmdval = Nullcmd; } +break; +case 37: +#line 313 "perly.y" +{ (void)scanstr("1",SCAN_DEF); yyval.arg = yylval.arg; } +break; +case 39: +#line 318 "perly.y" +{ yyval.cval = Nullch; } +break; +case 41: +#line 323 "perly.y" +{ yyval.ival = 0; } +break; +case 42: +#line 325 "perly.y" +{ yyval.ival = 0; } +break; +case 43: +#line 327 "perly.y" +{ yyval.ival = 0; } +break; +case 44: +#line 331 "perly.y" +{ if (strEQ(yyvsp[-2].cval,"stdout")) + make_form(stabent("STDOUT",TRUE),yyvsp[0].formval); + else if (strEQ(yyvsp[-2].cval,"stderr")) + make_form(stabent("STDERR",TRUE),yyvsp[0].formval); + else + make_form(stabent(yyvsp[-2].cval,TRUE),yyvsp[0].formval); + Safefree(yyvsp[-2].cval); yyvsp[-2].cval = Nullch; } +break; +case 45: +#line 339 "perly.y" +{ make_form(stabent("STDOUT",TRUE),yyvsp[0].formval); } +break; +case 46: +#line 343 "perly.y" +{ make_sub(yyvsp[-1].cval,yyvsp[0].cmdval); + cmdline = NOLINE; + if (savestack->ary_fill > yyvsp[-2].ival) + restorelist(yyvsp[-2].ival); } +break; +case 47: +#line 350 "perly.y" +{ char tmpbuf[256]; + STAB *tmpstab; + + savehptr(&curstash); + saveitem(curstname); + str_set(curstname,yyvsp[-1].cval); + sprintf(tmpbuf,"'_%s",yyvsp[-1].cval); + tmpstab = stabent(tmpbuf,TRUE); + if (!stab_xhash(tmpstab)) + stab_xhash(tmpstab) = hnew(0); + curstash = stab_xhash(tmpstab); + if (!curstash->tbl_name) + curstash->tbl_name = savestr(yyvsp[-1].cval); + curstash->tbl_coeffsize = 0; + Safefree(yyvsp[-1].cval); yyvsp[-1].cval = Nullch; + cmdline = NOLINE; + expectterm = 2; + } +break; +case 48: +#line 371 "perly.y" +{ yyval.arg = yyvsp[0].arg; } +break; +case 49: +#line 375 "perly.y" +{ yyval.arg = make_op(O_COMMA, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 51: +#line 380 "perly.y" +{ yyval.arg = yyvsp[0].arg; } +break; +case 52: +#line 384 "perly.y" +{ yyvsp[-2].arg = listish(yyvsp[-2].arg); + if (yyvsp[-2].arg->arg_type == O_ASSIGN && yyvsp[-2].arg->arg_len == 1) + yyvsp[-2].arg->arg_type = O_ITEM; /* a local() */ + if (yyvsp[-2].arg->arg_type == O_LIST) + yyvsp[0].arg = listish(yyvsp[0].arg); + yyval.arg = l(make_op(O_ASSIGN, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg)); } +break; +case 53: +#line 391 "perly.y" +{ yyval.arg = l(make_op(O_POW, 2, yyvsp[-3].arg, yyvsp[0].arg, Nullarg)); } +break; +case 54: +#line 393 "perly.y" +{ yyval.arg = l(make_op(yyvsp[-2].ival, 2, yyvsp[-3].arg, yyvsp[0].arg, Nullarg)); } +break; +case 55: +#line 395 "perly.y" +{ yyval.arg = rcatmaybe(l(make_op(yyvsp[-2].ival, 2, yyvsp[-3].arg, yyvsp[0].arg, Nullarg)));} +break; +case 56: +#line 397 "perly.y" +{ yyval.arg = l(make_op(O_LEFT_SHIFT, 2, yyvsp[-3].arg, yyvsp[0].arg, Nullarg)); } +break; +case 57: +#line 399 "perly.y" +{ yyval.arg = l(make_op(O_RIGHT_SHIFT, 2, yyvsp[-3].arg, yyvsp[0].arg, Nullarg)); } +break; +case 58: +#line 401 "perly.y" +{ yyval.arg = l(make_op(O_BIT_AND, 2, yyvsp[-3].arg, yyvsp[0].arg, Nullarg)); } +break; +case 59: +#line 403 "perly.y" +{ yyval.arg = l(make_op(O_XOR, 2, yyvsp[-3].arg, yyvsp[0].arg, Nullarg)); } +break; +case 60: +#line 405 "perly.y" +{ yyval.arg = l(make_op(O_BIT_OR, 2, yyvsp[-3].arg, yyvsp[0].arg, Nullarg)); } +break; +case 61: +#line 409 "perly.y" +{ yyval.arg = make_op(O_POW, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 62: +#line 411 "perly.y" +{ if (yyvsp[-1].ival == O_REPEAT) + yyvsp[-2].arg = listish(yyvsp[-2].arg); + yyval.arg = make_op(yyvsp[-1].ival, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); + if (yyvsp[-1].ival == O_REPEAT) { + if (yyval.arg[1].arg_type != A_EXPR || + yyval.arg[1].arg_ptr.arg_arg->arg_type != O_LIST) + yyval.arg[1].arg_flags &= ~AF_ARYOK; + } } +break; +case 63: +#line 420 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 64: +#line 422 "perly.y" +{ yyval.arg = make_op(O_LEFT_SHIFT, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 65: +#line 424 "perly.y" +{ yyval.arg = make_op(O_RIGHT_SHIFT, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 66: +#line 426 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 67: +#line 428 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 68: +#line 430 "perly.y" +{ yyval.arg = make_op(O_BIT_AND, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 69: +#line 432 "perly.y" +{ yyval.arg = make_op(O_XOR, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 70: +#line 434 "perly.y" +{ yyval.arg = make_op(O_BIT_OR, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 71: +#line 436 "perly.y" +{ arg4 = Nullarg; + yyval.arg = make_op(O_F_OR_R, 4, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); + yyval.arg[0].arg_flags |= yyvsp[-1].ival; } +break; +case 72: +#line 440 "perly.y" +{ yyval.arg = make_op(O_AND, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 73: +#line 442 "perly.y" +{ yyval.arg = make_op(O_OR, 2, yyvsp[-2].arg, yyvsp[0].arg, Nullarg); } +break; +case 74: +#line 444 "perly.y" +{ yyval.arg = make_op(O_COND_EXPR, 3, yyvsp[-4].arg, yyvsp[-2].arg, yyvsp[0].arg); } +break; +case 75: +#line 446 "perly.y" +{ yyval.arg = mod_match(O_MATCH, yyvsp[-2].arg, yyvsp[0].arg); } +break; +case 76: +#line 448 "perly.y" +{ yyval.arg = mod_match(O_NMATCH, yyvsp[-2].arg, yyvsp[0].arg); } +break; +case 77: +#line 450 "perly.y" +{ yyval.arg = yyvsp[0].arg; } +break; +case 78: +#line 454 "perly.y" +{ yyval.arg = make_op(O_NEGATE, 1, yyvsp[0].arg, Nullarg, Nullarg); } +break; +case 79: +#line 456 "perly.y" +{ yyval.arg = yyvsp[0].arg; } +break; +case 80: +#line 458 "perly.y" +{ yyval.arg = make_op(O_NOT, 1, yyvsp[0].arg, Nullarg, Nullarg); } +break; +case 81: +#line 460 "perly.y" +{ yyval.arg = make_op(O_COMPLEMENT, 1, yyvsp[0].arg, Nullarg, Nullarg);} +break; +case 82: +#line 462 "perly.y" +{ yyval.arg = addflags(1, AF_POST|AF_UP, + l(make_op(O_ITEM,1,yyvsp[-1].arg,Nullarg,Nullarg))); } +break; +case 83: +#line 465 "perly.y" +{ yyval.arg = addflags(1, AF_POST, + l(make_op(O_ITEM,1,yyvsp[-1].arg,Nullarg,Nullarg))); } +break; +case 84: +#line 468 "perly.y" +{ yyval.arg = addflags(1, AF_PRE|AF_UP, + l(make_op(O_ITEM,1,yyvsp[0].arg,Nullarg,Nullarg))); } +break; +case 85: +#line 471 "perly.y" +{ yyval.arg = addflags(1, AF_PRE, + l(make_op(O_ITEM,1,yyvsp[0].arg,Nullarg,Nullarg))); } +break; +case 86: +#line 474 "perly.y" +{ opargs[yyvsp[-1].ival] = 0; /* force it special */ + yyval.arg = make_op(yyvsp[-1].ival, 1, + stab2arg(A_STAB,stabent(yyvsp[0].cval,TRUE)), + Nullarg, Nullarg); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch; + } +break; +case 87: +#line 481 "perly.y" +{ opargs[yyvsp[-1].ival] = 1; + yyval.arg = make_op(yyvsp[-1].ival, 1, yyvsp[0].arg, Nullarg, Nullarg); } +break; +case 88: +#line 484 "perly.y" +{ opargs[yyvsp[0].ival] = (yyvsp[0].ival != O_FTTTY); + yyval.arg = make_op(yyvsp[0].ival, 1, + stab2arg(A_STAB, + yyvsp[0].ival == O_FTTTY?stabent("STDIN",TRUE):defstab), + Nullarg, Nullarg); } +break; +case 89: +#line 490 "perly.y" +{ yyval.arg = l(localize(make_op(O_ASSIGN, 1, + localize(listish(make_list(yyvsp[-1].arg))), + Nullarg,Nullarg))); } +break; +case 90: +#line 494 "perly.y" +{ yyval.arg = make_list(yyvsp[-1].arg); } +break; +case 91: +#line 496 "perly.y" +{ yyval.arg = make_list(Nullarg); } +break; +case 92: +#line 498 "perly.y" +{ yyval.arg = make_op(O_DOFILE,2,yyvsp[0].arg,Nullarg,Nullarg); + allstabs = TRUE;} +break; +case 93: +#line 501 "perly.y" +{ yyval.arg = cmd_to_arg(yyvsp[0].cmdval); } +break; +case 94: +#line 503 "perly.y" +{ yyval.arg = stab2arg(A_STAB,yyvsp[0].stabval); } +break; +case 95: +#line 505 "perly.y" +{ yyval.arg = stab2arg(A_STAR,yyvsp[0].stabval); } +break; +case 96: +#line 507 "perly.y" +{ yyval.arg = make_op(O_AELEM, 2, + stab2arg(A_STAB,aadd(yyvsp[-3].stabval)), yyvsp[-1].arg, Nullarg); } +break; +case 97: +#line 510 "perly.y" +{ yyval.arg = make_op(O_HASH, 1, + stab2arg(A_STAB,yyvsp[0].stabval), + Nullarg, Nullarg); } +break; +case 98: +#line 514 "perly.y" +{ yyval.arg = make_op(O_ARRAY, 1, + stab2arg(A_STAB,yyvsp[0].stabval), + Nullarg, Nullarg); } +break; +case 99: +#line 518 "perly.y" +{ yyval.arg = make_op(O_HELEM, 2, + stab2arg(A_STAB,hadd(yyvsp[-4].stabval)), + jmaybe(yyvsp[-2].arg), + Nullarg); + expectterm = FALSE; } +break; +case 100: +#line 524 "perly.y" +{ yyval.arg = make_op(O_LSLICE, 3, + Nullarg, + listish(make_list(yyvsp[-1].arg)), + listish(make_list(yyvsp[-4].arg))); } +break; +case 101: +#line 529 "perly.y" +{ yyval.arg = make_op(O_LSLICE, 3, + Nullarg, + listish(make_list(yyvsp[-1].arg)), + Nullarg); } +break; +case 102: +#line 534 "perly.y" +{ yyval.arg = make_op(O_ASLICE, 2, + stab2arg(A_STAB,aadd(yyvsp[-3].stabval)), + listish(make_list(yyvsp[-1].arg)), + Nullarg); } +break; +case 103: +#line 539 "perly.y" +{ yyval.arg = make_op(O_HSLICE, 2, + stab2arg(A_STAB,hadd(yyvsp[-4].stabval)), + listish(make_list(yyvsp[-2].arg)), + Nullarg); + expectterm = FALSE; } +break; +case 104: +#line 545 "perly.y" +{ yyval.arg = make_op(O_DELETE, 2, + stab2arg(A_STAB,hadd(yyvsp[-4].stabval)), + jmaybe(yyvsp[-2].arg), + Nullarg); + expectterm = FALSE; } +break; +case 105: +#line 551 "perly.y" +{ yyval.arg = make_op(O_DELETE, 2, + stab2arg(A_STAB,hadd(yyvsp[-5].stabval)), + jmaybe(yyvsp[-3].arg), + Nullarg); + expectterm = FALSE; } +break; +case 106: +#line 557 "perly.y" +{ yyval.arg = stab2arg(A_ARYLEN,yyvsp[0].stabval); } +break; +case 107: +#line 559 "perly.y" +{ yyval.arg = yyvsp[0].arg; } +break; +case 108: +#line 561 "perly.y" +{ yyval.arg = yyvsp[0].arg; } +break; +case 109: +#line 563 "perly.y" +{ yyval.arg = yyvsp[0].arg; } +break; +case 110: +#line 565 "perly.y" +{ yyval.arg = yyvsp[0].arg; } +break; +case 111: +#line 567 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent(yyvsp[-3].cval,MULTI)), + make_list(yyvsp[-1].arg), + Nullarg); Safefree(yyvsp[-3].cval); yyvsp[-3].cval = Nullch; + yyval.arg->arg_flags |= AF_DEPR; } +break; +case 112: +#line 573 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent(yyvsp[-3].cval,MULTI)), + make_list(yyvsp[-1].arg), + Nullarg); Safefree(yyvsp[-3].cval); yyvsp[-3].cval = Nullch; } +break; +case 113: +#line 578 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent(yyvsp[-2].cval,MULTI)), + make_list(Nullarg), + Nullarg); + Safefree(yyvsp[-2].cval); yyvsp[-2].cval = Nullch; + yyval.arg->arg_flags |= AF_DEPR; } +break; +case 114: +#line 585 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent(yyvsp[-2].cval,MULTI)), + make_list(Nullarg), + Nullarg); + Safefree(yyvsp[-2].cval); yyvsp[-2].cval = Nullch; + } +break; +case 115: +#line 592 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent(yyvsp[0].cval,MULTI)), + Nullarg, + Nullarg); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch; + } +break; +case 116: +#line 599 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,yyvsp[-3].stabval), + make_list(yyvsp[-1].arg), + Nullarg); + yyval.arg->arg_flags |= AF_DEPR; } +break; +case 117: +#line 605 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,yyvsp[-3].stabval), + make_list(yyvsp[-1].arg), + Nullarg); } +break; +case 118: +#line 610 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,yyvsp[-2].stabval), + make_list(Nullarg), + Nullarg); + yyval.arg->arg_flags |= AF_DEPR; } +break; +case 119: +#line 616 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,yyvsp[-2].stabval), + make_list(Nullarg), + Nullarg); } +break; +case 120: +#line 621 "perly.y" +{ yyval.arg = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,yyvsp[0].stabval), + Nullarg, + Nullarg); } +break; +case 121: +#line 626 "perly.y" +{ yyval.arg = make_op(yyvsp[0].ival,0,Nullarg,Nullarg,Nullarg); } +break; +case 122: +#line 628 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival,1,cval_to_arg(yyvsp[0].cval), + Nullarg,Nullarg); } +break; +case 123: +#line 631 "perly.y" +{ yyval.arg = make_op(yyvsp[0].ival,0,Nullarg,Nullarg,Nullarg); } +break; +case 124: +#line 633 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival,1,cmd_to_arg(yyvsp[0].cmdval),Nullarg,Nullarg); } +break; +case 125: +#line 635 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival,1,yyvsp[0].arg,Nullarg,Nullarg); } +break; +case 126: +#line 637 "perly.y" +{ yyval.arg = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);} +break; +case 127: +#line 639 "perly.y" +{ yyval.arg = make_op(O_SELECT, 1, + stab2arg(A_WORD,stabent(yyvsp[0].cval,TRUE)), + Nullarg, + Nullarg); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch; } +break; +case 128: +#line 645 "perly.y" +{ yyval.arg = make_op(O_SELECT, 1, yyvsp[-1].arg, Nullarg, Nullarg); } +break; +case 129: +#line 647 "perly.y" +{ arg4 = yyvsp[-1].arg; + yyval.arg = make_op(O_SSELECT, 4, yyvsp[-4].arg, yyvsp[-3].arg, yyvsp[-2].arg); } +break; +case 130: +#line 650 "perly.y" +{ yyval.arg = make_op(O_OPEN, 2, + stab2arg(A_WORD,stabent(yyvsp[0].cval,TRUE)), + stab2arg(A_STAB,stabent(yyvsp[0].cval,TRUE)), + Nullarg); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch; + } +break; +case 131: +#line 657 "perly.y" +{ yyval.arg = make_op(O_OPEN, 2, + stab2arg(A_WORD,stabent(yyvsp[-1].cval,TRUE)), + stab2arg(A_STAB,stabent(yyvsp[-1].cval,TRUE)), + Nullarg); + Safefree(yyvsp[-1].cval); yyvsp[-1].cval = Nullch; + } +break; +case 132: +#line 664 "perly.y" +{ yyval.arg = make_op(O_OPEN, 2, + yyvsp[-2].arg, + yyvsp[-1].arg, Nullarg); } +break; +case 133: +#line 668 "perly.y" +{ yyval.arg = make_op(yyvsp[-3].ival, 1, + yyvsp[-1].arg, + Nullarg, Nullarg); } +break; +case 134: +#line 672 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival, 1, + stab2arg(A_WORD,stabent(yyvsp[0].cval,TRUE)), + Nullarg, Nullarg); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch; } +break; +case 135: +#line 677 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival, 1, + stab2arg(A_STAB,yyvsp[0].stabval), + Nullarg, Nullarg); } +break; +case 136: +#line 681 "perly.y" +{ yyval.arg = make_op(yyvsp[-2].ival, 1, + stab2arg(A_WORD,Nullstab), + Nullarg, Nullarg); } +break; +case 137: +#line 685 "perly.y" +{ yyval.arg = make_op(yyvsp[0].ival, 0, + Nullarg, Nullarg, Nullarg); } +break; +case 138: +#line 688 "perly.y" +{ yyval.arg = make_op(yyvsp[-4].ival, 2, yyvsp[-2].arg, yyvsp[-1].arg, Nullarg); } +break; +case 139: +#line 690 "perly.y" +{ yyval.arg = make_op(yyvsp[-5].ival, 3, yyvsp[-3].arg, yyvsp[-2].arg, make_list(yyvsp[-1].arg)); } +break; +case 140: +#line 692 "perly.y" +{ yyval.arg = make_op(yyvsp[-5].ival, 2, yyvsp[-3].arg, yyvsp[-1].arg, Nullarg); } +break; +case 141: +#line 694 "perly.y" +{ arg4 = yyvsp[-1].arg; yyval.arg = make_op(yyvsp[-6].ival, 4, yyvsp[-4].arg, yyvsp[-3].arg, yyvsp[-2].arg); } +break; +case 142: +#line 696 "perly.y" +{ arg4 = yyvsp[-2].arg; arg5 = yyvsp[-1].arg; + yyval.arg = make_op(yyvsp[-8].ival, 5, yyvsp[-6].arg, yyvsp[-4].arg, yyvsp[-3].arg); } +break; +case 143: +#line 699 "perly.y" +{ yyval.arg = make_op(yyvsp[-5].ival, 2, + yyvsp[-3].arg, + make_list(yyvsp[-1].arg), + Nullarg); } +break; +case 144: +#line 704 "perly.y" +{ yyval.arg = make_op(O_POP, 1, yyvsp[0].arg, Nullarg, Nullarg); } +break; +case 145: +#line 706 "perly.y" +{ yyval.arg = make_op(O_POP, 1, yyvsp[-1].arg, Nullarg, Nullarg); } +break; +case 146: +#line 708 "perly.y" +{ yyval.arg = make_op(O_SHIFT, 1, yyvsp[0].arg, Nullarg, Nullarg); } +break; +case 147: +#line 710 "perly.y" +{ yyval.arg = make_op(O_SHIFT, 1, yyvsp[-1].arg, Nullarg, Nullarg); } +break; +case 148: +#line 712 "perly.y" +{ yyval.arg = make_op(O_SHIFT, 1, + stab2arg(A_STAB, + aadd(stabent(subline ? "_" : "ARGV", TRUE))), + Nullarg, Nullarg); } +break; +case 149: +#line 717 "perly.y" +{ static char p[]="/\\s+/"; + char *oldend = bufend; + ARG *oldarg = yylval.arg; + + bufend=p+5; + (void)scanpat(p); + bufend=oldend; + yyval.arg = make_split(defstab,yylval.arg,Nullarg); + yylval.arg = oldarg; } +break; +case 150: +#line 727 "perly.y" +{ yyval.arg = mod_match(O_MATCH, yyvsp[-2].arg, + make_split(defstab,yyvsp[-3].arg,yyvsp[-1].arg));} +break; +case 151: +#line 730 "perly.y" +{ yyval.arg = mod_match(O_MATCH, yyvsp[-1].arg, + make_split(defstab,yyvsp[-2].arg,Nullarg) ); } +break; +case 152: +#line 733 "perly.y" +{ yyval.arg = mod_match(O_MATCH, + stab2arg(A_STAB,defstab), + make_split(defstab,yyvsp[-1].arg,Nullarg) ); } +break; +case 153: +#line 737 "perly.y" +{ yyval.arg = make_op(yyvsp[-4].ival, 2, + yyvsp[-2].arg, + listish(make_list(yyvsp[-1].arg)), + Nullarg); } +break; +case 154: +#line 742 "perly.y" +{ yyval.arg = make_op(yyvsp[-3].ival, 1, + make_list(yyvsp[-1].arg), + Nullarg, + Nullarg); } +break; +case 155: +#line 747 "perly.y" +{ yyval.arg = l(make_op(yyvsp[-1].ival, 1, fixl(yyvsp[-1].ival,yyvsp[0].arg), + Nullarg, Nullarg)); } +break; +case 156: +#line 750 "perly.y" +{ yyval.arg = l(make_op(yyvsp[0].ival, 1, + stab2arg(A_STAB,defstab), + Nullarg, Nullarg)); } +break; +case 157: +#line 754 "perly.y" +{ yyval.arg = make_op(yyvsp[0].ival, 0, Nullarg, Nullarg, Nullarg); } +break; +case 158: +#line 756 "perly.y" +{ yyval.arg = make_op(yyvsp[-2].ival, 0, Nullarg, Nullarg, Nullarg); } +break; +case 159: +#line 758 "perly.y" +{ yyval.arg = make_op(yyvsp[-2].ival, 0, Nullarg, Nullarg, Nullarg); } +break; +case 160: +#line 760 "perly.y" +{ yyval.arg = make_op(yyvsp[-3].ival, 1, yyvsp[-1].arg, Nullarg, Nullarg); } +break; +case 161: +#line 762 "perly.y" +{ yyval.arg = make_op(yyvsp[-4].ival, 2, yyvsp[-2].arg, yyvsp[-1].arg, Nullarg); + if (yyvsp[-4].ival == O_INDEX && yyval.arg[2].arg_type == A_SINGLE) + fbmcompile(yyval.arg[2].arg_ptr.arg_str,0); } +break; +case 162: +#line 766 "perly.y" +{ yyval.arg = make_op(yyvsp[-4].ival, 2, yyvsp[-2].arg, yyvsp[-1].arg, Nullarg); + if (yyvsp[-4].ival == O_INDEX && yyval.arg[2].arg_type == A_SINGLE) + fbmcompile(yyval.arg[2].arg_ptr.arg_str,0); } +break; +case 163: +#line 770 "perly.y" +{ yyval.arg = make_op(yyvsp[-5].ival, 3, yyvsp[-3].arg, yyvsp[-2].arg, yyvsp[-1].arg); + if (yyvsp[-5].ival == O_INDEX && yyval.arg[2].arg_type == A_SINGLE) + fbmcompile(yyval.arg[2].arg_ptr.arg_str,0); } +break; +case 164: +#line 774 "perly.y" +{ yyval.arg = make_op(yyvsp[-5].ival, 3, yyvsp[-3].arg, yyvsp[-2].arg, yyvsp[-1].arg); } +break; +case 165: +#line 776 "perly.y" +{ arg4 = yyvsp[-1].arg; + yyval.arg = make_op(yyvsp[-6].ival, 4, yyvsp[-4].arg, yyvsp[-3].arg, yyvsp[-2].arg); } +break; +case 166: +#line 779 "perly.y" +{ arg4 = yyvsp[-2].arg; arg5 = yyvsp[-1].arg; + yyval.arg = make_op(yyvsp[-7].ival, 5, yyvsp[-5].arg, yyvsp[-4].arg, yyvsp[-3].arg); } +break; +case 167: +#line 782 "perly.y" +{ yyval.arg = make_op(yyvsp[-3].ival, 1, + yyvsp[-1].arg, + Nullarg, + Nullarg); } +break; +case 168: +#line 787 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival, 1, + yyvsp[0].arg, + Nullarg, + Nullarg); } +break; +case 169: +#line 792 "perly.y" +{ yyval.arg = make_op(yyvsp[-5].ival, 3, yyvsp[-3].arg, yyvsp[-2].arg, yyvsp[-1].arg); } +break; +case 172: +#line 798 "perly.y" +{ yyval.arg = make_op(yyvsp[0].ival,2, + stab2arg(A_WORD,Nullstab), + stab2arg(A_STAB,defstab), + Nullarg); } +break; +case 173: +#line 803 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival,2, + stab2arg(A_WORD,Nullstab), + maybelistish(yyvsp[-1].ival,make_list(yyvsp[0].arg)), + Nullarg); } +break; +case 174: +#line 808 "perly.y" +{ yyval.arg = make_op(yyvsp[-1].ival,2, + stab2arg(A_WORD,stabent(yyvsp[0].cval,TRUE)), + stab2arg(A_STAB,defstab), + Nullarg); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch; + } +break; +case 175: +#line 815 "perly.y" +{ yyval.arg = make_op(yyvsp[-2].ival,2, + stab2arg(A_WORD,stabent(yyvsp[-1].cval,TRUE)), + maybelistish(yyvsp[-2].ival,make_list(yyvsp[0].arg)), + Nullarg); Safefree(yyvsp[-1].cval); yyvsp[-1].cval = Nullch; } +break; +case 176: +#line 820 "perly.y" +{ yyval.arg = make_op(yyvsp[-2].ival,2, + stab2arg(A_STAB,yyvsp[-1].stabval), + maybelistish(yyvsp[-2].ival,make_list(yyvsp[0].arg)), + Nullarg); } +break; +case 177: +#line 825 "perly.y" +{ yyval.arg = make_op(yyvsp[-2].ival,2, + cmd_to_arg(yyvsp[-1].cmdval), + maybelistish(yyvsp[-2].ival,make_list(yyvsp[0].arg)), + Nullarg); } +break; +case 178: +#line 832 "perly.y" +{ yyval.arg = stab2arg(A_WORD,stabent(yyvsp[0].cval,TRUE)); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch;} +break; +case 180: +#line 838 "perly.y" +{ yyval.arg = stab2arg(A_WORD,aadd(stabent(yyvsp[0].cval,TRUE))); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch; } +break; +case 181: +#line 841 "perly.y" +{ yyval.arg = stab2arg(A_STAB,yyvsp[0].stabval); } +break; +case 182: +#line 845 "perly.y" +{ yyval.arg = stab2arg(A_WORD,hadd(stabent(yyvsp[0].cval,TRUE))); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch; } +break; +case 183: +#line 848 "perly.y" +{ yyval.arg = stab2arg(A_STAB,yyvsp[0].stabval); } +break; +case 184: +#line 852 "perly.y" +{ yyval.ival = 1; } +break; +case 185: +#line 854 "perly.y" +{ yyval.ival = 0; } +break; +case 186: +#line 863 "perly.y" +{ char *s; + yyval.arg = op_new(1); + yyval.arg->arg_type = O_ITEM; + yyval.arg[1].arg_type = A_SINGLE; + yyval.arg[1].arg_ptr.arg_str = str_make(yyvsp[0].cval,0); + for (s = yyvsp[0].cval; *s && isLOWER(*s); s++) ; + if (dowarn && !*s) + warn( + "\"%s\" may clash with future reserved word", + yyvsp[0].cval ); + Safefree(yyvsp[0].cval); yyvsp[0].cval = Nullch; + } +break; +#line 3008 "y.tab.c" + } + yyssp -= yym; + yystate = *yyssp; + yyvsp -= yym; + yym = yylhs[yyn]; + if (yystate == 0 && yym == 0) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: after reduction, shifting from state 0 to\ + state %d\n", YYPREFIX, YYFINAL); +#endif + yystate = YYFINAL; + *++yyssp = YYFINAL; + *++yyvsp = yyval; + if (yychar < 0) + { + if ((yychar = yylex()) < 0) yychar = 0; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + printf("%sdebug: state %d, reading %d (%s)\n", + YYPREFIX, YYFINAL, yychar, yys); + } +#endif + } + if (yychar == 0) goto yyaccept; + goto yyloop; + } + if ((yyn = yygindex[yym]) && (yyn += yystate) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yystate) + yystate = yytable[yyn]; + else + yystate = yydgoto[yym]; +#if YYDEBUG + if (yydebug) + printf("%sdebug: after reduction, shifting from state %d \ +to state %d\n", YYPREFIX, *yyssp, yystate); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + goto yyoverflow; + } + *++yyssp = yystate; + *++yyvsp = yyval; + goto yyloop; +yyoverflow: + yyerror("yacc stack overflow"); +yyabort: + return (1); +yyaccept: + return (0); +} diff --git a/gnu/usr.bin/perl/perl/perly.h b/gnu/usr.bin/perl/perl/perly.h new file mode 100644 index 0000000..c6f13d1 --- /dev/null +++ b/gnu/usr.bin/perl/perl/perly.h @@ -0,0 +1,83 @@ +#define WORD 257 +#define LABEL 258 +#define APPEND 259 +#define OPEN 260 +#define SSELECT 261 +#define LOOPEX 262 +#define DOTDOT 263 +#define USING 264 +#define FORMAT 265 +#define DO 266 +#define SHIFT 267 +#define PUSH 268 +#define POP 269 +#define LVALFUN 270 +#define WHILE 271 +#define UNTIL 272 +#define IF 273 +#define UNLESS 274 +#define ELSE 275 +#define ELSIF 276 +#define CONTINUE 277 +#define SPLIT 278 +#define FLIST 279 +#define FOR 280 +#define FILOP 281 +#define FILOP2 282 +#define FILOP3 283 +#define FILOP4 284 +#define FILOP22 285 +#define FILOP25 286 +#define FUNC0 287 +#define FUNC1 288 +#define FUNC2 289 +#define FUNC2x 290 +#define FUNC3 291 +#define FUNC4 292 +#define FUNC5 293 +#define HSHFUN 294 +#define HSHFUN3 295 +#define FLIST2 296 +#define SUB 297 +#define FILETEST 298 +#define LOCAL 299 +#define DELETE 300 +#define RELOP 301 +#define EQOP 302 +#define MULOP 303 +#define ADDOP 304 +#define PACKAGE 305 +#define AMPER 306 +#define FORMLIST 307 +#define REG 308 +#define ARYLEN 309 +#define ARY 310 +#define HSH 311 +#define STAR 312 +#define SUBST 313 +#define PATTERN 314 +#define RSTRING 315 +#define TRANS 316 +#define LISTOP 317 +#define OROR 318 +#define ANDAND 319 +#define UNIOP 320 +#define LS 321 +#define RS 322 +#define MATCH 323 +#define NMATCH 324 +#define UMINUS 325 +#define POW 326 +#define INC 327 +#define DEC 328 +typedef union { + int ival; + char *cval; + ARG *arg; + CMD *cmdval; + struct compcmd compval; + STAB *stabval; + FCMD *formval; +} YYSTYPE; +extern YYSTYPE yylval; +extern YYSTYPE yylval; diff --git a/gnu/usr.bin/perl/perl/regcomp.c b/gnu/usr.bin/perl/perl/regcomp.c new file mode 100644 index 0000000..8337e9c --- /dev/null +++ b/gnu/usr.bin/perl/perl/regcomp.c @@ -0,0 +1,1478 @@ +/* NOTE: this is derived from Henry Spencer's regexp code, and should not + * confused with the original package (see point 3 below). Thanks, Henry! + */ + +/* Additional note: this code is very heavily munged from Henry's version + * in places. In some spots I've traded clarity for efficiency, so don't + * blame Henry for some of the lack of readability. + */ + +/* $RCSfile: regcomp.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:39 $ + * + * $Log: regcomp.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:39 nate + * PERL! + * + * Revision 4.0.1.5 92/06/08 15:23:36 lwall + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: /^stuff/ wrongly assumed an implicit $* == 1 + * patch20: /x{0}/ was wrongly interpreted as /x{0,}/ + * patch20: added \W, \S and \D inside /[...]/ + * + * Revision 4.0.1.4 91/11/05 22:55:14 lwall + * patch11: Erratum + * + * Revision 4.0.1.3 91/11/05 18:22:28 lwall + * patch11: minimum match length calculation in regexp is now cumulative + * patch11: initial .* in pattern had dependency on value of $* + * patch11: certain patterns made use of garbage pointers from uncleared memory + * patch11: prepared for ctype implementations that don't define isascii() + * + * Revision 4.0.1.2 91/06/07 11:48:24 lwall + * patch4: new copyright notice + * patch4: /(x+) \1/ incorrectly optimized to not match "xxx xx" + * patch4: // wouldn't use previous pattern if it started with a null character + * + * Revision 4.0.1.1 91/04/12 09:04:45 lwall + * patch1: random cleanup in cpp namespace + * + * Revision 4.0 91/03/20 01:39:01 lwall + * 4.0 baseline. + * + */ +/*SUPPRESS 112*/ +/* + * regcomp and regexec -- regsub and regerror are not used in perl + * + * Copyright (c) 1986 by University of Toronto. + * Written by Henry Spencer. Not derived from licensed software. + * + * Permission is granted to anyone to use this software for any + * purpose on any computer system, and to redistribute it freely, + * subject to the following restrictions: + * + * 1. The author is not responsible for the consequences of use of + * this software, no matter how awful, even if they arise + * from defects in it. + * + * 2. The origin of this software must not be misrepresented, either + * by explicit claim or by omission. + * + * 3. Altered versions must be plainly marked as such, and must not + * be misrepresented as being the original software. + * + * + **** Alterations to Henry's code are... + **** + **** Copyright (c) 1991, Larry Wall + **** + **** You may distribute under the terms of either the GNU General Public + **** License or the Artistic License, as specified in the README file. + + * + * Beware that some of this code is subtly aware of the way operator + * precedence is structured in regular expressions. Serious changes in + * regular-expression syntax might require a total rethink. + */ +#include "EXTERN.h" +#include "perl.h" +#include "INTERN.h" +#include "regcomp.h" + +#ifdef MSDOS +# if defined(BUGGY_MSC6) + /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */ + # pragma optimize("a",off) + /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/ + # pragma optimize("w",on ) +# endif /* BUGGY_MSC6 */ +#endif /* MSDOS */ + +#ifndef STATIC +#define STATIC static +#endif + +#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?') +#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \ + ((*s) == '{' && regcurly(s))) +#ifdef atarist +#define PERL_META "^$.[()|?+*\\" +#else +#define META "^$.[()|?+*\\" +#endif + +#ifdef SPSTART +#undef SPSTART /* dratted cpp namespace... */ +#endif +/* + * Flags to be passed up and down. + */ +#define HASWIDTH 01 /* Known never to match null string. */ +#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ +#define SPSTART 04 /* Starts with * or +. */ +#define WORST 0 /* Worst case. */ + +/* + * Global work variables for regcomp(). + */ +static char *regprecomp; /* uncompiled string. */ +static char *regparse; /* Input-scan pointer. */ +static char *regxend; /* End of input for compile */ +static int regnpar; /* () count. */ +static char *regcode; /* Code-emit pointer; ®dummy = don't. */ +static long regsize; /* Code size. */ +static int regfold; +static int regsawbracket; /* Did we do {d,d} trick? */ +static int regsawback; /* Did we see \1, ...? */ + +/* + * Forward declarations for regcomp()'s friends. + */ +STATIC int regcurly(); +STATIC char *reg(); +STATIC char *regbranch(); +STATIC char *regpiece(); +STATIC char *regatom(); +STATIC char *regclass(); +STATIC char *regnode(); +STATIC char *reganode(); +STATIC void regc(); +STATIC void reginsert(); +STATIC void regtail(); +STATIC void regoptail(); + +/* + - regcomp - compile a regular expression into internal code + * + * We can't allocate space until we know how big the compiled form will be, + * but we can't compile it (and thus know how big it is) until we've got a + * place to put the code. So we cheat: we compile it twice, once with code + * generation turned off and size counting turned on, and once "for real". + * This also means that we don't allocate space until we are sure that the + * thing really will compile successfully, and we never have to move the + * code and thus invalidate pointers into it. (Note that it has to be in + * one piece because free() must be able to free it all.) [NB: not true in perl] + * + * Beware that the optimization-preparation code in here knows about some + * of the structure of the compiled regexp. [I'll say.] + */ +regexp * +regcomp(exp,xend,fold) +char *exp; +char *xend; +int fold; +{ + register regexp *r; + register char *scan; + register STR *longish; + STR *longest; + register int len; + register char *first; + int flags; + int backish; + int backest; + int curback; + int minlen; + int sawplus = 0; + int sawopen = 0; + + if (exp == NULL) + fatal("NULL regexp argument"); + + /* First pass: determine size, legality. */ + regfold = fold; + regparse = exp; + regxend = xend; + regprecomp = nsavestr(exp,xend-exp); + regsawbracket = 0; + regsawback = 0; + regnpar = 1; + regsize = 0L; + regcode = ®dummy; + regc((char)MAGIC); + if (reg(0, &flags) == NULL) { + Safefree(regprecomp); + regprecomp = Nullch; + return(NULL); + } + + /* Small enough for pointer-storage convention? */ + if (regsize >= 32767L) /* Probably could be 65535L. */ + FAIL("regexp too big"); + + /* Allocate space. */ + Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp); + if (r == NULL) + FAIL("regexp out of space"); + + /* Second pass: emit code. */ + if (regsawbracket) + Copy(regprecomp,exp,xend-exp,char); + r->prelen = xend-exp; + r->precomp = regprecomp; + r->subbeg = r->subbase = NULL; + regparse = exp; + regnpar = 1; + regcode = r->program; + regc((char)MAGIC); + if (reg(0, &flags) == NULL) + return(NULL); + + /* Dig out information for optimizations. */ + r->regstart = Nullstr; /* Worst-case defaults. */ + r->reganch = 0; + r->regmust = Nullstr; + r->regback = -1; + r->regstclass = Nullch; + scan = r->program+1; /* First BRANCH. */ + if (OP(regnext(scan)) == END) {/* Only one top-level choice. */ + scan = NEXTOPER(scan); + + first = scan; + while ((OP(first) == OPEN && (sawopen = 1)) || + (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) || + (OP(first) == PLUS) || + (OP(first) == CURLY && ARG1(first) > 0) ) { + if (OP(first) == PLUS) + sawplus = 1; + else + first += regarglen[OP(first)]; + first = NEXTOPER(first); + } + + /* Starting-point info. */ + again: + if (OP(first) == EXACTLY) { + r->regstart = + str_make(OPERAND(first)+1,*OPERAND(first)); + if (r->regstart->str_cur > !(sawstudy|fold)) + fbmcompile(r->regstart,fold); + } + else if ((exp = index(simple,OP(first))) && exp > simple) + r->regstclass = first; + else if (OP(first) == BOUND || OP(first) == NBOUND) + r->regstclass = first; + else if (OP(first) == BOL) { + r->reganch = ROPT_ANCH; + first = NEXTOPER(first); + goto again; + } + else if ((OP(first) == STAR && OP(NEXTOPER(first)) == ANY) && + !(r->reganch & ROPT_ANCH) ) { + /* turn .* into ^.* with an implied $*=1 */ + r->reganch = ROPT_ANCH | ROPT_IMPLICIT; + first = NEXTOPER(first); + goto again; + } + if (sawplus && (!sawopen || !regsawback)) + r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */ + +#ifdef DEBUGGING + if (debug & 512) + fprintf(stderr,"first %d next %d offset %d\n", + OP(first), OP(NEXTOPER(first)), first - scan); +#endif + /* + * If there's something expensive in the r.e., find the + * longest literal string that must appear and make it the + * regmust. Resolve ties in favor of later strings, since + * the regstart check works with the beginning of the r.e. + * and avoiding duplication strengthens checking. Not a + * strong reason, but sufficient in the absence of others. + * [Now we resolve ties in favor of the earlier string if + * it happens that curback has been invalidated, since the + * earlier string may buy us something the later one won't.] + */ + longish = str_make("",0); + longest = str_make("",0); + len = 0; + minlen = 0; + curback = 0; + backish = 0; + backest = 0; + while (OP(scan) != END) { + if (OP(scan) == BRANCH) { + if (OP(regnext(scan)) == BRANCH) { + curback = -30000; + while (OP(scan) == BRANCH) + scan = regnext(scan); + } + else /* single branch is ok */ + scan = NEXTOPER(scan); + } + if (OP(scan) == EXACTLY) { + char *t; + + first = scan; + while (OP(t = regnext(scan)) == CLOSE) + scan = t; + minlen += *OPERAND(first); + if (curback - backish == len) { + str_ncat(longish, OPERAND(first)+1, + *OPERAND(first)); + len += *OPERAND(first); + curback += *OPERAND(first); + first = regnext(scan); + } + else if (*OPERAND(first) >= len + (curback >= 0)) { + len = *OPERAND(first); + str_nset(longish, OPERAND(first)+1,len); + backish = curback; + curback += len; + first = regnext(scan); + } + else + curback += *OPERAND(first); + } + else if (index(varies,OP(scan))) { + curback = -30000; + len = 0; + if (longish->str_cur > longest->str_cur) { + str_sset(longest,longish); + backest = backish; + } + str_nset(longish,"",0); + if (OP(scan) == PLUS && + index(simple,OP(NEXTOPER(scan)))) + minlen++; + else if (OP(scan) == CURLY && + index(simple,OP(NEXTOPER(scan)+4))) + minlen += ARG1(scan); + } + else if (index(simple,OP(scan))) { + curback++; + minlen++; + len = 0; + if (longish->str_cur > longest->str_cur) { + str_sset(longest,longish); + backest = backish; + } + str_nset(longish,"",0); + } + scan = regnext(scan); + } + + /* Prefer earlier on tie, unless we can tail match latter */ + + if (longish->str_cur + (OP(first) == EOL) > longest->str_cur) { + str_sset(longest,longish); + backest = backish; + } + else + str_nset(longish,"",0); + if (longest->str_cur + && + (!r->regstart + || + !fbminstr((unsigned char*) r->regstart->str_ptr, + (unsigned char *) r->regstart->str_ptr + + r->regstart->str_cur, + longest) + ) + ) + { + r->regmust = longest; + if (backest < 0) + backest = -1; + r->regback = backest; + if (longest->str_cur + > !(sawstudy || fold || OP(first) == EOL) ) + fbmcompile(r->regmust,fold); + r->regmust->str_u.str_useful = 100; + if (OP(first) == EOL && longish->str_cur) + r->regmust->str_pok |= SP_TAIL; + } + else { + str_free(longest); + longest = Nullstr; + } + str_free(longish); + } + + r->do_folding = fold; + r->nparens = regnpar - 1; + r->minlen = minlen; + Newz(1002, r->startp, regnpar, char*); + Newz(1002, r->endp, regnpar, char*); +#ifdef DEBUGGING + if (debug & 512) + regdump(r); +#endif + return(r); +} + +/* + - reg - regular expression, i.e. main body or parenthesized thing + * + * Caller must absorb opening parenthesis. + * + * Combining parenthesis handling with the base level of regular expression + * is a trifle forced, but the need to tie the tails of the branches to what + * follows makes it hard to avoid. + */ +static char * +reg(paren, flagp) +int paren; /* Parenthesized? */ +int *flagp; +{ + register char *ret; + register char *br; + register char *ender; + register int parno; + int flags; + + *flagp = HASWIDTH; /* Tentatively. */ + + /* Make an OPEN node, if parenthesized. */ + if (paren) { + parno = regnpar; + regnpar++; + ret = reganode(OPEN, parno); + } else + ret = NULL; + + /* Pick up the branches, linking them together. */ + br = regbranch(&flags); + if (br == NULL) + return(NULL); + if (ret != NULL) + regtail(ret, br); /* OPEN -> first. */ + else + ret = br; + if (!(flags&HASWIDTH)) + *flagp &= ~HASWIDTH; + *flagp |= flags&SPSTART; + while (*regparse == '|') { + regparse++; + br = regbranch(&flags); + if (br == NULL) + return(NULL); + regtail(ret, br); /* BRANCH -> BRANCH. */ + if (!(flags&HASWIDTH)) + *flagp &= ~HASWIDTH; + *flagp |= flags&SPSTART; + } + + /* Make a closing node, and hook it on the end. */ + if (paren) + ender = reganode(CLOSE, parno); + else + ender = regnode(END); + regtail(ret, ender); + + /* Hook the tails of the branches to the closing node. */ + for (br = ret; br != NULL; br = regnext(br)) + regoptail(br, ender); + + /* Check for proper termination. */ + if (paren && *regparse++ != ')') { + FAIL("unmatched () in regexp"); + } else if (!paren && regparse < regxend) { + if (*regparse == ')') { + FAIL("unmatched () in regexp"); + } else + FAIL("junk on end of regexp"); /* "Can't happen". */ + /* NOTREACHED */ + } + + return(ret); +} + +/* + - regbranch - one alternative of an | operator + * + * Implements the concatenation operator. + */ +static char * +regbranch(flagp) +int *flagp; +{ + register char *ret; + register char *chain; + register char *latest; + int flags; + + *flagp = WORST; /* Tentatively. */ + + ret = regnode(BRANCH); + chain = NULL; + while (regparse < regxend && *regparse != '|' && *regparse != ')') { + latest = regpiece(&flags); + if (latest == NULL) + return(NULL); + *flagp |= flags&HASWIDTH; + if (chain == NULL) /* First piece. */ + *flagp |= flags&SPSTART; + else + regtail(chain, latest); + chain = latest; + } + if (chain == NULL) /* Loop ran zero times. */ + (void) regnode(NOTHING); + + return(ret); +} + +/* + - regpiece - something followed by possible [*+?] + * + * Note that the branching code sequences used for ? and the general cases + * of * and + are somewhat optimized: they use the same NOTHING node as + * both the endmarker for their branch list and the body of the last branch. + * It might seem that this node could be dispensed with entirely, but the + * endmarker role is not redundant. + */ +static char * +regpiece(flagp) +int *flagp; +{ + register char *ret; + register char op; + register char *next; + int flags; + char *origparse = regparse; + int orignpar = regnpar; + char *max; + int iter; + char ch; + + ret = regatom(&flags); + if (ret == NULL) + return(NULL); + + op = *regparse; + + /* Here's a total kludge: if after the atom there's a {\d+,?\d*} + * then we decrement the first number by one and reset our + * parsing back to the beginning of the same atom. If the first number + * is down to 0, decrement the second number instead and fake up + * a ? after it. Given the way this compiler doesn't keep track + * of offsets on the first pass, this is the only way to replicate + * a piece of code. Sigh. + */ + if (op == '{' && regcurly(regparse)) { + next = regparse + 1; + max = Nullch; + while (isDIGIT(*next) || *next == ',') { + if (*next == ',') { + if (max) + break; + else + max = next; + } + next++; + } + if (*next == '}') { /* got one */ + if (!max) + max = next; + regparse++; + iter = atoi(regparse); + if (flags&SIMPLE) { /* we can do it right after all */ + int tmp; + + reginsert(CURLY, ret); + if (iter > 0) + *flagp = (WORST|HASWIDTH); + if (*max == ',') + max++; + else + max = regparse; + tmp = atoi(max); + if (!tmp && *max != '0') + tmp = 32767; /* meaning "infinity" */ + if (tmp && tmp < iter) + fatal("Can't do {n,m} with n > m"); + if (regcode != ®dummy) { +#ifdef REGALIGN + *(unsigned short *)(ret+3) = iter; + *(unsigned short *)(ret+5) = tmp; +#else + ret[3] = iter >> 8; ret[4] = iter & 0377; + ret[5] = tmp >> 8; ret[6] = tmp & 0377; +#endif + } + regparse = next; + goto nest_check; + } + regsawbracket++; /* remember we clobbered exp */ + if (iter > 0) { + ch = *max; + sprintf(regparse,"%.*d", max-regparse, iter - 1); + *max = ch; + if (*max == ',' && max[1] != '}') { + if (atoi(max+1) <= 0) + fatal("Can't do {n,m} with n > m"); + ch = *next; + sprintf(max+1,"%.*d", next-(max+1), atoi(max+1) - 1); + *next = ch; + } + if (iter != 1 || *max == ',') { + regparse = origparse; /* back up input pointer */ + regnpar = orignpar; /* don't make more parens */ + } + else { + regparse = next; + goto nest_check; + } + *flagp = flags; + return ret; + } + if (*max == ',') { + max++; + iter = atoi(max); + if (max == next) { /* any number more? */ + regparse = next; + op = '*'; /* fake up one with a star */ + } + else if (iter > 0) { + op = '?'; /* fake up optional atom */ + ch = *next; + sprintf(max,"%.*d", next-max, iter - 1); + *next = ch; + if (iter == 1) + regparse = next; + else { + regparse = origparse - 1; /* offset ++ below */ + regnpar = orignpar; + } + } + else + fatal("Can't do {n,0}"); + } + else + fatal("Can't do {0}"); + } + } + + if (!ISMULT1(op)) { + *flagp = flags; + return(ret); + } + + if (!(flags&HASWIDTH) && op != '?') + FAIL("regexp *+ operand could be empty"); + *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); + + if (op == '*' && (flags&SIMPLE)) + reginsert(STAR, ret); + else if (op == '*') { + /* Emit x* as (x&|), where & means "self". */ + reginsert(BRANCH, ret); /* Either x */ + regoptail(ret, regnode(BACK)); /* and loop */ + regoptail(ret, ret); /* back */ + regtail(ret, regnode(BRANCH)); /* or */ + regtail(ret, regnode(NOTHING)); /* null. */ + } else if (op == '+' && (flags&SIMPLE)) + reginsert(PLUS, ret); + else if (op == '+') { + /* Emit x+ as x(&|), where & means "self". */ + next = regnode(BRANCH); /* Either */ + regtail(ret, next); + regtail(regnode(BACK), ret); /* loop back */ + regtail(next, regnode(BRANCH)); /* or */ + regtail(ret, regnode(NOTHING)); /* null. */ + } else if (op == '?') { + /* Emit x? as (x|) */ + reginsert(BRANCH, ret); /* Either x */ + regtail(ret, regnode(BRANCH)); /* or */ + next = regnode(NOTHING); /* null. */ + regtail(ret, next); + regoptail(ret, next); + } + nest_check: + regparse++; + if (ISMULT2(regparse)) + FAIL("nested *?+ in regexp"); + + return(ret); +} + +/* + - regatom - the lowest level + * + * Optimization: gobbles an entire sequence of ordinary characters so that + * it can turn them into a single node, which is smaller to store and + * faster to run. Backslashed characters are exceptions, each becoming a + * separate node; the code is simpler that way and it's not worth fixing. + * + * [Yes, it is worth fixing, some scripts can run twice the speed.] + */ +static char * +regatom(flagp) +int *flagp; +{ + register char *ret; + int flags; + + *flagp = WORST; /* Tentatively. */ + + switch (*regparse++) { + case '^': + ret = regnode(BOL); + break; + case '$': + ret = regnode(EOL); + break; + case '.': + ret = regnode(ANY); + *flagp |= HASWIDTH|SIMPLE; + break; + case '[': + ret = regclass(); + *flagp |= HASWIDTH|SIMPLE; + break; + case '(': + ret = reg(1, &flags); + if (ret == NULL) + return(NULL); + *flagp |= flags&(HASWIDTH|SPSTART); + break; + case '|': + case ')': + FAIL("internal urp in regexp"); /* Supposed to be caught earlier. */ + break; + case '?': + case '+': + case '*': + FAIL("?+* follows nothing in regexp"); + break; + case '\\': + switch (*regparse) { + case 'w': + ret = regnode(ALNUM); + *flagp |= HASWIDTH|SIMPLE; + regparse++; + break; + case 'W': + ret = regnode(NALNUM); + *flagp |= HASWIDTH|SIMPLE; + regparse++; + break; + case 'b': + ret = regnode(BOUND); + *flagp |= SIMPLE; + regparse++; + break; + case 'B': + ret = regnode(NBOUND); + *flagp |= SIMPLE; + regparse++; + break; + case 's': + ret = regnode(SPACE); + *flagp |= HASWIDTH|SIMPLE; + regparse++; + break; + case 'S': + ret = regnode(NSPACE); + *flagp |= HASWIDTH|SIMPLE; + regparse++; + break; + case 'd': + ret = regnode(DIGIT); + *flagp |= HASWIDTH|SIMPLE; + regparse++; + break; + case 'D': + ret = regnode(NDIGIT); + *flagp |= HASWIDTH|SIMPLE; + regparse++; + break; + case 'n': + case 'r': + case 't': + case 'f': + case 'e': + case 'a': + case 'x': + case 'c': + case '0': + goto defchar; + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + { + int num = atoi(regparse); + + if (num > 9 && num >= regnpar) + goto defchar; + else { + regsawback = 1; + ret = reganode(REF, num); + while (isDIGIT(*regparse)) + regparse++; + *flagp |= SIMPLE; + } + } + break; + case '\0': + if (regparse >= regxend) + FAIL("trailing \\ in regexp"); + /* FALL THROUGH */ + default: + goto defchar; + } + break; + default: { + register int len; + register char ender; + register char *p; + char *oldp; + int numlen; + + defchar: + ret = regnode(EXACTLY); + regc(0); /* save spot for len */ + for (len=0, p=regparse-1; + len < 127 && p < regxend; + len++) + { + oldp = p; + switch (*p) { + case '^': + case '$': + case '.': + case '[': + case '(': + case ')': + case '|': + goto loopdone; + case '\\': + switch (*++p) { + case 'w': + case 'W': + case 'b': + case 'B': + case 's': + case 'S': + case 'd': + case 'D': + --p; + goto loopdone; + case 'n': + ender = '\n'; + p++; + break; + case 'r': + ender = '\r'; + p++; + break; + case 't': + ender = '\t'; + p++; + break; + case 'f': + ender = '\f'; + p++; + break; + case 'e': + ender = '\033'; + p++; + break; + case 'a': + ender = '\007'; + p++; + break; + case 'x': + ender = scanhex(++p, 2, &numlen); + p += numlen; + break; + case 'c': + p++; + ender = *p++; + if (isLOWER(ender)) + ender = toupper(ender); + ender ^= 64; + break; + case '0': case '1': case '2': case '3':case '4': + case '5': case '6': case '7': case '8':case '9': + if (*p == '0' || + (isDIGIT(p[1]) && atoi(p) >= regnpar) ) { + ender = scanoct(p, 3, &numlen); + p += numlen; + } + else { + --p; + goto loopdone; + } + break; + case '\0': + if (p >= regxend) + FAIL("trailing \\ in regexp"); + /* FALL THROUGH */ + default: + ender = *p++; + break; + } + break; + default: + ender = *p++; + break; + } + if (regfold && isUPPER(ender)) + ender = tolower(ender); + if (ISMULT2(p)) { /* Back off on ?+*. */ + if (len) + p = oldp; + else { + len++; + regc(ender); + } + break; + } + regc(ender); + } + loopdone: + regparse = p; + if (len <= 0) + FAIL("internal disaster in regexp"); + *flagp |= HASWIDTH; + if (len == 1) + *flagp |= SIMPLE; + if (regcode != ®dummy) + *OPERAND(ret) = len; + regc('\0'); + } + break; + } + + return(ret); +} + +static void +regset(bits,def,c) +char *bits; +int def; +register int c; +{ + if (regcode == ®dummy) + return; + c &= 255; + if (def) + bits[c >> 3] &= ~(1 << (c & 7)); + else + bits[c >> 3] |= (1 << (c & 7)); +} + +static char * +regclass() +{ + register char *bits; + register int class; + register int lastclass; + register int range = 0; + register char *ret; + register int def; + int numlen; + + ret = regnode(ANYOF); + if (*regparse == '^') { /* Complement of range. */ + regparse++; + def = 0; + } else { + def = 255; + } + bits = regcode; + for (class = 0; class < 32; class++) + regc(def); + if (*regparse == ']' || *regparse == '-') + goto skipcond; /* allow 1st char to be ] or - */ + while (regparse < regxend && *regparse != ']') { + skipcond: + class = UCHARAT(regparse++); + if (class == '\\') { + class = UCHARAT(regparse++); + switch (class) { + case 'w': + for (class = 0; class < 256; class++) + if (isALNUM(class)) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'W': + for (class = 0; class < 256; class++) + if (!isALNUM(class)) + regset(bits,def,class); + lastclass = 1234; + continue; + case 's': + for (class = 0; class < 256; class++) + if (isSPACE(class)) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'S': + for (class = 0; class < 256; class++) + if (!isSPACE(class)) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'd': + for (class = '0'; class <= '9'; class++) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'D': + for (class = 0; class < '0'; class++) + regset(bits,def,class); + for (class = '9' + 1; class < 256; class++) + regset(bits,def,class); + lastclass = 1234; + continue; + case 'n': + class = '\n'; + break; + case 'r': + class = '\r'; + break; + case 't': + class = '\t'; + break; + case 'f': + class = '\f'; + break; + case 'b': + class = '\b'; + break; + case 'e': + class = '\033'; + break; + case 'a': + class = '\007'; + break; + case 'x': + class = scanhex(regparse, 2, &numlen); + regparse += numlen; + break; + case 'c': + class = *regparse++; + if (isLOWER(class)) + class = toupper(class); + class ^= 64; + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + class = scanoct(--regparse, 3, &numlen); + regparse += numlen; + break; + } + } + if (range) { + if (lastclass > class) + FAIL("invalid [] range in regexp"); + range = 0; + } + else { + lastclass = class; + if (*regparse == '-' && regparse+1 < regxend && + regparse[1] != ']') { + regparse++; + range = 1; + continue; /* do it next time */ + } + } + for ( ; lastclass <= class; lastclass++) { + regset(bits,def,lastclass); + if (regfold && isUPPER(lastclass)) + regset(bits,def,tolower(lastclass)); + } + lastclass = class; + } + if (*regparse != ']') + FAIL("unmatched [] in regexp"); + regparse++; + return ret; +} + +/* + - regnode - emit a node + */ +static char * /* Location. */ +regnode(op) +char op; +{ + register char *ret; + register char *ptr; + + ret = regcode; + if (ret == ®dummy) { +#ifdef REGALIGN + if (!(regsize & 1)) + regsize++; +#endif + regsize += 3; + return(ret); + } + +#ifdef REGALIGN +#ifndef lint + if (!((long)ret & 1)) + *ret++ = 127; +#endif +#endif + ptr = ret; + *ptr++ = op; + *ptr++ = '\0'; /* Null "next" pointer. */ + *ptr++ = '\0'; + regcode = ptr; + + return(ret); +} + +/* + - reganode - emit a node with an argument + */ +static char * /* Location. */ +reganode(op, arg) +char op; +unsigned short arg; +{ + register char *ret; + register char *ptr; + + ret = regcode; + if (ret == ®dummy) { +#ifdef REGALIGN + if (!(regsize & 1)) + regsize++; +#endif + regsize += 5; + return(ret); + } + +#ifdef REGALIGN +#ifndef lint + if (!((long)ret & 1)) + *ret++ = 127; +#endif +#endif + ptr = ret; + *ptr++ = op; + *ptr++ = '\0'; /* Null "next" pointer. */ + *ptr++ = '\0'; +#ifdef REGALIGN + *(unsigned short *)(ret+3) = arg; +#else + ret[3] = arg >> 8; ret[4] = arg & 0377; +#endif + ptr += 2; + regcode = ptr; + + return(ret); +} + +/* + - regc - emit (if appropriate) a byte of code + */ +static void +regc(b) +char b; +{ + if (regcode != ®dummy) + *regcode++ = b; + else + regsize++; +} + +/* + - reginsert - insert an operator in front of already-emitted operand + * + * Means relocating the operand. + */ +static void +reginsert(op, opnd) +char op; +char *opnd; +{ + register char *src; + register char *dst; + register char *place; + register offset = (op == CURLY ? 4 : 0); + + if (regcode == ®dummy) { +#ifdef REGALIGN + regsize += 4 + offset; +#else + regsize += 3 + offset; +#endif + return; + } + + src = regcode; +#ifdef REGALIGN + regcode += 4 + offset; +#else + regcode += 3 + offset; +#endif + dst = regcode; + while (src > opnd) + *--dst = *--src; + + place = opnd; /* Op node, where operand used to be. */ + *place++ = op; + *place++ = '\0'; + *place++ = '\0'; + while (offset-- > 0) + *place++ = '\0'; +#ifdef REGALIGN + *place++ = '\177'; +#endif +} + +/* + - regtail - set the next-pointer at the end of a node chain + */ +static void +regtail(p, val) +char *p; +char *val; +{ + register char *scan; + register char *temp; + register int offset; + + if (p == ®dummy) + return; + + /* Find last node. */ + scan = p; + for (;;) { + temp = regnext(scan); + if (temp == NULL) + break; + scan = temp; + } + +#ifdef REGALIGN + offset = val - scan; +#ifndef lint + *(short*)(scan+1) = offset; +#else + offset = offset; +#endif +#else + if (OP(scan) == BACK) + offset = scan - val; + else + offset = val - scan; + *(scan+1) = (offset>>8)&0377; + *(scan+2) = offset&0377; +#endif +} + +/* + - regoptail - regtail on operand of first argument; nop if operandless + */ +static void +regoptail(p, val) +char *p; +char *val; +{ + /* "Operandless" and "op != BRANCH" are synonymous in practice. */ + if (p == NULL || p == ®dummy || OP(p) != BRANCH) + return; + regtail(NEXTOPER(p), val); +} + +/* + - regcurly - a little FSA that accepts {\d+,?\d*} + */ +STATIC int +regcurly(s) +register char *s; +{ + if (*s++ != '{') + return FALSE; + if (!isDIGIT(*s)) + return FALSE; + while (isDIGIT(*s)) + s++; + if (*s == ',') + s++; + while (isDIGIT(*s)) + s++; + if (*s != '}') + return FALSE; + return TRUE; +} + +#ifdef DEBUGGING + +/* + - regdump - dump a regexp onto stderr in vaguely comprehensible form + */ +void +regdump(r) +regexp *r; +{ + register char *s; + register char op = EXACTLY; /* Arbitrary non-END op. */ + register char *next; + + + s = r->program + 1; + while (op != END) { /* While that wasn't END last time... */ +#ifdef REGALIGN + if (!((long)s & 1)) + s++; +#endif + op = OP(s); + fprintf(stderr,"%2d%s", s-r->program, regprop(s)); /* Where, what. */ + next = regnext(s); + s += regarglen[op]; + if (next == NULL) /* Next ptr. */ + fprintf(stderr,"(0)"); + else + fprintf(stderr,"(%d)", (s-r->program)+(next-s)); + s += 3; + if (op == ANYOF) { + s += 32; + } + if (op == EXACTLY) { + /* Literal string, where present. */ + s++; + while (*s != '\0') { + (void)putchar(*s); + s++; + } + s++; + } + (void)putchar('\n'); + } + + /* Header fields of interest. */ + if (r->regstart) + fprintf(stderr,"start `%s' ", r->regstart->str_ptr); + if (r->regstclass) + fprintf(stderr,"stclass `%s' ", regprop(r->regstclass)); + if (r->reganch & ROPT_ANCH) + fprintf(stderr,"anchored "); + if (r->reganch & ROPT_SKIP) + fprintf(stderr,"plus "); + if (r->reganch & ROPT_IMPLICIT) + fprintf(stderr,"implicit "); + if (r->regmust != NULL) + fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr, + r->regback); + fprintf(stderr, "minlen %d ", r->minlen); + fprintf(stderr,"\n"); +} + +/* + - regprop - printable representation of opcode + */ +char * +regprop(op) +char *op; +{ + register char *p; + + (void) strcpy(buf, ":"); + + switch (OP(op)) { + case BOL: + p = "BOL"; + break; + case EOL: + p = "EOL"; + break; + case ANY: + p = "ANY"; + break; + case ANYOF: + p = "ANYOF"; + break; + case BRANCH: + p = "BRANCH"; + break; + case EXACTLY: + p = "EXACTLY"; + break; + case NOTHING: + p = "NOTHING"; + break; + case BACK: + p = "BACK"; + break; + case END: + p = "END"; + break; + case ALNUM: + p = "ALNUM"; + break; + case NALNUM: + p = "NALNUM"; + break; + case BOUND: + p = "BOUND"; + break; + case NBOUND: + p = "NBOUND"; + break; + case SPACE: + p = "SPACE"; + break; + case NSPACE: + p = "NSPACE"; + break; + case DIGIT: + p = "DIGIT"; + break; + case NDIGIT: + p = "NDIGIT"; + break; + case CURLY: + (void)sprintf(buf+strlen(buf), "CURLY {%d,%d}", + ARG1(op),ARG2(op)); + p = NULL; + break; + case REF: + (void)sprintf(buf+strlen(buf), "REF%d", ARG1(op)); + p = NULL; + break; + case OPEN: + (void)sprintf(buf+strlen(buf), "OPEN%d", ARG1(op)); + p = NULL; + break; + case CLOSE: + (void)sprintf(buf+strlen(buf), "CLOSE%d", ARG1(op)); + p = NULL; + break; + case STAR: + p = "STAR"; + break; + case PLUS: + p = "PLUS"; + break; + default: + FAIL("corrupted regexp opcode"); + } + if (p != NULL) + (void) strcat(buf, p); + return(buf); +} +#endif /* DEBUGGING */ + +void +regfree(r) +struct regexp *r; +{ + if (r->precomp) { + Safefree(r->precomp); + r->precomp = Nullch; + } + if (r->subbase) { + Safefree(r->subbase); + r->subbase = Nullch; + } + if (r->regmust) { + str_free(r->regmust); + r->regmust = Nullstr; + } + if (r->regstart) { + str_free(r->regstart); + r->regstart = Nullstr; + } + Safefree(r->startp); + Safefree(r->endp); + Safefree(r); +} diff --git a/gnu/usr.bin/perl/perl/regcomp.h b/gnu/usr.bin/perl/perl/regcomp.h new file mode 100644 index 0000000..6dcd482 --- /dev/null +++ b/gnu/usr.bin/perl/perl/regcomp.h @@ -0,0 +1,200 @@ +/* $RCSfile: regcomp.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:39 $ + * + * $Log: regcomp.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:39 nate + * PERL! + * + * Revision 4.0.1.1 91/06/07 11:49:40 lwall + * patch4: no change + * + * Revision 4.0 91/03/20 01:39:09 lwall + * 4.0 baseline. + * + */ + +/* + * The "internal use only" fields in regexp.h are present to pass info from + * compile to execute that permits the execute phase to run lots faster on + * simple cases. They are: + * + * regstart str that must begin a match; Nullch if none obvious + * reganch is the match anchored (at beginning-of-line only)? + * regmust string (pointer into program) that match must include, or NULL + * [regmust changed to STR* for bminstr()--law] + * regmlen length of regmust string + * [regmlen not used currently] + * + * Regstart and reganch permit very fast decisions on suitable starting points + * for a match, cutting down the work a lot. Regmust permits fast rejection + * of lines that cannot possibly match. The regmust tests are costly enough + * that regcomp() supplies a regmust only if the r.e. contains something + * potentially expensive (at present, the only such thing detected is * or + + * at the start of the r.e., which can involve a lot of backup). Regmlen is + * supplied because the test in regexec() needs it and regcomp() is computing + * it anyway. + * [regmust is now supplied always. The tests that use regmust have a + * heuristic that disables the test if it usually matches.] + * + * [In fact, we now use regmust in many cases to locate where the search + * starts in the string, so if regback is >= 0, the regmust search is never + * wasted effort. The regback variable says how many characters back from + * where regmust matched is the earliest possible start of the match. + * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.] + */ + +/* + * Structure for regexp "program". This is essentially a linear encoding + * of a nondeterministic finite-state machine (aka syntax charts or + * "railroad normal form" in parsing technology). Each node is an opcode + * plus a "next" pointer, possibly plus an operand. "Next" pointers of + * all nodes except BRANCH implement concatenation; a "next" pointer with + * a BRANCH on both ends of it is connecting two alternatives. (Here we + * have one of the subtle syntax dependencies: an individual BRANCH (as + * opposed to a collection of them) is never concatenated with anything + * because of operator precedence.) The operand of some types of node is + * a literal string; for others, it is a node leading into a sub-FSM. In + * particular, the operand of a BRANCH node is the first node of the branch. + * (NB this is *not* a tree structure: the tail of the branch connects + * to the thing following the set of BRANCHes.) The opcodes are: + */ + +/* definition number opnd? meaning */ +#define END 0 /* no End of program. */ +#define BOL 1 /* no Match "" at beginning of line. */ +#define EOL 2 /* no Match "" at end of line. */ +#define ANY 3 /* no Match any one character. */ +#define ANYOF 4 /* str Match character in (or not in) this class. */ +#define CURLY 5 /* str Match this simple thing {n,m} times. */ +#define BRANCH 6 /* node Match this alternative, or the next... */ +#define BACK 7 /* no Match "", "next" ptr points backward. */ +#define EXACTLY 8 /* str Match this string (preceded by length). */ +#define NOTHING 9 /* no Match empty string. */ +#define STAR 10 /* node Match this (simple) thing 0 or more times. */ +#define PLUS 11 /* node Match this (simple) thing 1 or more times. */ +#define ALNUM 12 /* no Match any alphanumeric character */ +#define NALNUM 13 /* no Match any non-alphanumeric character */ +#define BOUND 14 /* no Match "" at any word boundary */ +#define NBOUND 15 /* no Match "" at any word non-boundary */ +#define SPACE 16 /* no Match any whitespace character */ +#define NSPACE 17 /* no Match any non-whitespace character */ +#define DIGIT 18 /* no Match any numeric character */ +#define NDIGIT 19 /* no Match any non-numeric character */ +#define REF 20 /* num Match some already matched string */ +#define OPEN 21 /* num Mark this point in input as start of #n. */ +#define CLOSE 22 /* num Analogous to OPEN. */ + +/* + * Opcode notes: + * + * BRANCH The set of branches constituting a single choice are hooked + * together with their "next" pointers, since precedence prevents + * anything being concatenated to any individual branch. The + * "next" pointer of the last BRANCH in a choice points to the + * thing following the whole choice. This is also where the + * final "next" pointer of each individual branch points; each + * branch starts with the operand node of a BRANCH node. + * + * BACK Normal "next" pointers all implicitly point forward; BACK + * exists to make loop structures possible. + * + * STAR,PLUS '?', and complex '*' and '+', are implemented as circular + * BRANCH structures using BACK. Simple cases (one character + * per match) are implemented with STAR and PLUS for speed + * and to minimize recursive plunges. + * + * OPEN,CLOSE ...are numbered at compile time. + */ + +#ifndef DOINIT +extern char regarglen[]; +#else +char regarglen[] = {0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,2,2}; +#endif + +/* The following have no fixed length. */ +#ifndef DOINIT +extern char varies[]; +#else +char varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,REF,0}; +#endif + +/* The following always have a length of 1. */ +#ifndef DOINIT +extern char simple[]; +#else +char simple[] = {ANY,ANYOF,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0}; +#endif + +EXT char regdummy; + +/* + * A node is one char of opcode followed by two chars of "next" pointer. + * "Next" pointers are stored as two 8-bit pieces, high order first. The + * value is a positive offset from the opcode of the node containing it. + * An operand, if any, simply follows the node. (Note that much of the + * code generation knows about this implicit relationship.) + * + * Using two bytes for the "next" pointer is vast overkill for most things, + * but allows patterns to get big without disasters. + * + * [If REGALIGN is defined, the "next" pointer is always aligned on an even + * boundary, and reads the offset directly as a short. Also, there is no + * special test to reverse the sign of BACK pointers since the offset is + * stored negative.] + */ + +#ifndef gould +#ifndef cray +#ifndef eta10 +#define REGALIGN +#endif +#endif +#endif + +#define OP(p) (*(p)) + +#ifndef lint +#ifdef REGALIGN +#define NEXT(p) (*(short*)(p+1)) +#define ARG1(p) (*(unsigned short*)(p+3)) +#define ARG2(p) (*(unsigned short*)(p+5)) +#else +#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) +#define ARG1(p) (((*((p)+3)&0377)<<8) + (*((p)+4)&0377)) +#define ARG2(p) (((*((p)+5)&0377)<<8) + (*((p)+6)&0377)) +#endif +#else /* lint */ +#define NEXT(p) 0 +#endif /* lint */ + +#define OPERAND(p) ((p) + 3) + +#ifdef REGALIGN +#define NEXTOPER(p) ((p) + 4) +#else +#define NEXTOPER(p) ((p) + 3) +#endif + +#define MAGIC 0234 + +/* + * Utility definitions. + */ +#ifndef lint +#ifndef CHARBITS +#define UCHARAT(p) ((int)*(unsigned char *)(p)) +#else +#define UCHARAT(p) ((int)*(p)&CHARBITS) +#endif +#else /* lint */ +#define UCHARAT(p) regdummy +#endif /* lint */ + +#define FAIL(m) fatal("/%s/: %s",regprecomp,m) + +char *regnext(); +#ifdef DEBUGGING +void regdump(); +char *regprop(); +#endif + diff --git a/gnu/usr.bin/perl/perl/regexec.c b/gnu/usr.bin/perl/perl/regexec.c new file mode 100644 index 0000000..7802465f --- /dev/null +++ b/gnu/usr.bin/perl/perl/regexec.c @@ -0,0 +1,910 @@ +/* NOTE: this is derived from Henry Spencer's regexp code, and should not + * confused with the original package (see point 3 below). Thanks, Henry! + */ + +/* Additional note: this code is very heavily munged from Henry's version + * in places. In some spots I've traded clarity for efficiency, so don't + * blame Henry for some of the lack of readability. + */ + +/* $RCSfile: regexec.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:39 $ + * + * $Log: regexec.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:39 nate + * PERL! + * + * Revision 4.0.1.4 92/06/08 15:25:50 lwall + * patch20: pattern modifiers i and g didn't interact right + * patch20: in some cases $` and $' didn't get set by match + * patch20: /x{0}/ was wrongly interpreted as /x{0,}/ + * + * Revision 4.0.1.3 91/11/05 18:23:55 lwall + * patch11: prepared for ctype implementations that don't define isascii() + * patch11: initial .* in pattern had dependency on value of $* + * + * Revision 4.0.1.2 91/06/07 11:50:33 lwall + * patch4: new copyright notice + * patch4: // wouldn't use previous pattern if it started with a null character + * + * Revision 4.0.1.1 91/04/12 09:07:39 lwall + * patch1: regexec only allocated space for 9 subexpresssions + * + * Revision 4.0 91/03/20 01:39:16 lwall + * 4.0 baseline. + * + */ +/*SUPPRESS 112*/ +/* + * regcomp and regexec -- regsub and regerror are not used in perl + * + * Copyright (c) 1986 by University of Toronto. + * Written by Henry Spencer. Not derived from licensed software. + * + * Permission is granted to anyone to use this software for any + * purpose on any computer system, and to redistribute it freely, + * subject to the following restrictions: + * + * 1. The author is not responsible for the consequences of use of + * this software, no matter how awful, even if they arise + * from defects in it. + * + * 2. The origin of this software must not be misrepresented, either + * by explicit claim or by omission. + * + * 3. Altered versions must be plainly marked as such, and must not + * be misrepresented as being the original software. + * + **** Alterations to Henry's code are... + **** + **** Copyright (c) 1991, Larry Wall + **** + **** You may distribute under the terms of either the GNU General Public + **** License or the Artistic License, as specified in the README file. + * + * Beware that some of this code is subtly aware of the way operator + * precedence is structured in regular expressions. Serious changes in + * regular-expression syntax might require a total rethink. + */ +#include "EXTERN.h" +#include "perl.h" +#include "regcomp.h" + +#ifndef STATIC +#define STATIC static +#endif + +#ifdef DEBUGGING +int regnarrate = 0; +#endif + +/* + * regexec and friends + */ + +/* + * Global work variables for regexec(). + */ +static char *regprecomp; +static char *reginput; /* String-input pointer. */ +static char regprev; /* char before regbol, \n if none */ +static char *regbol; /* Beginning of input, for ^ check. */ +static char *regeol; /* End of input, for $ check. */ +static char **regstartp; /* Pointer to startp array. */ +static char **regendp; /* Ditto for endp. */ +static char *reglastparen; /* Similarly for lastparen. */ +static char *regtill; + +static int regmyp_size = 0; +static char **regmystartp = Null(char**); +static char **regmyendp = Null(char**); + +/* + * Forwards. + */ +STATIC int regtry(); +STATIC int regmatch(); +STATIC int regrepeat(); + +extern int multiline; + +/* + - regexec - match a regexp against a string + */ +int +regexec(prog, stringarg, strend, strbeg, minend, screamer, safebase) +register regexp *prog; +char *stringarg; +register char *strend; /* pointer to null at end of string */ +char *strbeg; /* real beginning of string */ +int minend; /* end of match must be at least minend after stringarg */ +STR *screamer; +int safebase; /* no need to remember string in subbase */ +{ + register char *s; + register int i; + register char *c; + register char *string = stringarg; + register int tmp; + int minlen = 0; /* must match at least this many chars */ + int dontbother = 0; /* how many characters not to try at end */ + + /* Be paranoid... */ + if (prog == NULL || string == NULL) { + fatal("NULL regexp parameter"); + return(0); + } + + if (string == strbeg) /* is ^ valid at stringarg? */ + regprev = '\n'; + else { + regprev = stringarg[-1]; + if (!multiline && regprev == '\n') + regprev = '\0'; /* force ^ to NOT match */ + } + regprecomp = prog->precomp; + /* Check validity of program. */ + if (UCHARAT(prog->program) != MAGIC) { + FAIL("corrupted regexp program"); + } + + if (prog->do_folding) { + i = strend - string; + New(1101,c,i+1,char); + Copy(string, c, i+1, char); + string = c; + strend = string + i; + for (s = string; s < strend; s++) + if (isUPPER(*s)) + *s = tolower(*s); + } + + /* If there is a "must appear" string, look for it. */ + s = string; + if (prog->regmust != Nullstr && + (!(prog->reganch & ROPT_ANCH) + || (multiline && prog->regback >= 0)) ) { + if (stringarg == strbeg && screamer) { + if (screamfirst[prog->regmust->str_rare] >= 0) + s = screaminstr(screamer,prog->regmust); + else + s = Nullch; + } +#ifndef lint + else + s = fbminstr((unsigned char*)s, (unsigned char*)strend, + prog->regmust); +#endif + if (!s) { + ++prog->regmust->str_u.str_useful; /* hooray */ + goto phooey; /* not present */ + } + else if (prog->regback >= 0) { + s -= prog->regback; + if (s < string) + s = string; + minlen = prog->regback + prog->regmust->str_cur; + } + else if (--prog->regmust->str_u.str_useful < 0) { /* boo */ + str_free(prog->regmust); + prog->regmust = Nullstr; /* disable regmust */ + s = string; + } + else { + s = string; + minlen = prog->regmust->str_cur; + } + } + + /* Mark beginning of line for ^ . */ + regbol = string; + + /* Mark end of line for $ (and such) */ + regeol = strend; + + /* see how far we have to get to not match where we matched before */ + regtill = string+minend; + + /* Allocate our backreference arrays */ + if ( regmyp_size < prog->nparens + 1 ) { + /* Allocate or enlarge the arrays */ + regmyp_size = prog->nparens + 1; + if ( regmyp_size < 10 ) regmyp_size = 10; /* minimum */ + if ( regmystartp ) { + /* reallocate larger */ + Renew(regmystartp,regmyp_size,char*); + Renew(regmyendp, regmyp_size,char*); + } + else { + /* Initial allocation */ + New(1102,regmystartp,regmyp_size,char*); + New(1102,regmyendp, regmyp_size,char*); + } + + } + + /* Simplest case: anchored match need be tried only once. */ + /* [unless multiline is set] */ + if (prog->reganch & ROPT_ANCH) { + if (regtry(prog, string)) + goto got_it; + else if (multiline || (prog->reganch & ROPT_IMPLICIT)) { + if (minlen) + dontbother = minlen - 1; + strend -= dontbother; + /* for multiline we only have to try after newlines */ + if (s > string) + s--; + while (s < strend) { + if (*s++ == '\n') { + if (s < strend && regtry(prog, s)) + goto got_it; + } + } + } + goto phooey; + } + + /* Messy cases: unanchored match. */ + if (prog->regstart) { + if (prog->reganch & ROPT_SKIP) { /* we have /x+whatever/ */ + /* it must be a one character string */ + i = prog->regstart->str_ptr[0]; + while (s < strend) { + if (*s == i) { + if (regtry(prog, s)) + goto got_it; + s++; + while (s < strend && *s == i) + s++; + } + s++; + } + } + else if (prog->regstart->str_pok == 3) { + /* We know what string it must start with. */ +#ifndef lint + while ((s = fbminstr((unsigned char*)s, + (unsigned char*)strend, prog->regstart)) != NULL) +#else + while (s = Nullch) +#endif + { + if (regtry(prog, s)) + goto got_it; + s++; + } + } + else { + c = prog->regstart->str_ptr; + while ((s = ninstr(s, strend, + c, c + prog->regstart->str_cur )) != NULL) { + if (regtry(prog, s)) + goto got_it; + s++; + } + } + goto phooey; + } + /*SUPPRESS 560*/ + if (c = prog->regstclass) { + int doevery = (prog->reganch & ROPT_SKIP) == 0; + + if (minlen) + dontbother = minlen - 1; + strend -= dontbother; /* don't bother with what can't match */ + tmp = 1; + /* We know what class it must start with. */ + switch (OP(c)) { + case ANYOF: + c = OPERAND(c); + while (s < strend) { + i = UCHARAT(s); + if (!(c[i >> 3] & (1 << (i&7)))) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + case BOUND: + if (minlen) + dontbother++,strend--; + if (s != string) { + i = s[-1]; + tmp = isALNUM(i); + } + else + tmp = isALNUM(regprev); /* assume not alphanumeric */ + while (s < strend) { + i = *s; + if (tmp != isALNUM(i)) { + tmp = !tmp; + if (regtry(prog, s)) + goto got_it; + } + s++; + } + if ((minlen || tmp) && regtry(prog,s)) + goto got_it; + break; + case NBOUND: + if (minlen) + dontbother++,strend--; + if (s != string) { + i = s[-1]; + tmp = isALNUM(i); + } + else + tmp = isALNUM(regprev); /* assume not alphanumeric */ + while (s < strend) { + i = *s; + if (tmp != isALNUM(i)) + tmp = !tmp; + else if (regtry(prog, s)) + goto got_it; + s++; + } + if ((minlen || !tmp) && regtry(prog,s)) + goto got_it; + break; + case ALNUM: + while (s < strend) { + i = *s; + if (isALNUM(i)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + case NALNUM: + while (s < strend) { + i = *s; + if (!isALNUM(i)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + case SPACE: + while (s < strend) { + if (isSPACE(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + case NSPACE: + while (s < strend) { + if (!isSPACE(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + case DIGIT: + while (s < strend) { + if (isDIGIT(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + case NDIGIT: + while (s < strend) { + if (!isDIGIT(*s)) { + if (tmp && regtry(prog, s)) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s++; + } + break; + } + } + else { + if (minlen) + dontbother = minlen - 1; + strend -= dontbother; + /* We don't know much -- general case. */ + do { + if (regtry(prog, s)) + goto got_it; + } while (s++ < strend); + } + + /* Failure. */ + goto phooey; + + got_it: + prog->subbeg = strbeg; + prog->subend = strend; + if ((!safebase && (prog->nparens || sawampersand)) || prog->do_folding){ + strend += dontbother; /* uncheat */ + if (safebase) /* no need for $digit later */ + s = strbeg; + else if (strbeg != prog->subbase) { + i = strend - string + (stringarg - strbeg); + s = nsavestr(strbeg,i); /* so $digit will work later */ + if (prog->subbase) + Safefree(prog->subbase); + prog->subbeg = prog->subbase = s; + prog->subend = s+i; + } + else { + i = strend - string + (stringarg - strbeg); + prog->subbeg = s = prog->subbase; + prog->subend = s+i; + } + s += (stringarg - strbeg); + for (i = 0; i <= prog->nparens; i++) { + if (prog->endp[i]) { + prog->startp[i] = s + (prog->startp[i] - string); + prog->endp[i] = s + (prog->endp[i] - string); + } + } + if (prog->do_folding) + Safefree(string); + } + return(1); + + phooey: + if (prog->do_folding) + Safefree(string); + return(0); +} + +/* + - regtry - try match at specific point + */ +static int /* 0 failure, 1 success */ +regtry(prog, string) +regexp *prog; +char *string; +{ + register int i; + register char **sp; + register char **ep; + + reginput = string; + regstartp = prog->startp; + regendp = prog->endp; + reglastparen = &prog->lastparen; + prog->lastparen = 0; + + sp = prog->startp; + ep = prog->endp; + if (prog->nparens) { + for (i = prog->nparens; i >= 0; i--) { + *sp++ = NULL; + *ep++ = NULL; + } + } + if (regmatch(prog->program + 1) && reginput >= regtill) { + prog->startp[0] = string; + prog->endp[0] = reginput; + return(1); + } else + return(0); +} + +/* + - regmatch - main matching routine + * + * Conceptually the strategy is simple: check to see whether the current + * node matches, call self recursively to see whether the rest matches, + * and then act accordingly. In practice we make some effort to avoid + * recursion, in particular by going through "ordinary" nodes (that don't + * need to know whether the rest of the match failed) by a loop instead of + * by recursion. + */ +/* [lwall] I've hoisted the register declarations to the outer block in order to + * maybe save a little bit of pushing and popping on the stack. It also takes + * advantage of machines that use a register save mask on subroutine entry. + */ +static int /* 0 failure, 1 success */ +regmatch(prog) +char *prog; +{ + register char *scan; /* Current node. */ + char *next; /* Next node. */ + register int nextchar; + register int n; /* no or next */ + register int ln; /* len or last */ + register char *s; /* operand or save */ + register char *locinput = reginput; + + nextchar = *locinput; + scan = prog; +#ifdef DEBUGGING + if (scan != NULL && regnarrate) + fprintf(stderr, "%s(\n", regprop(scan)); +#endif + while (scan != NULL) { +#ifdef DEBUGGING + if (regnarrate) + fprintf(stderr, "%s...\n", regprop(scan)); +#endif + +#ifdef REGALIGN + next = scan + NEXT(scan); + if (next == scan) + next = NULL; +#else + next = regnext(scan); +#endif + + switch (OP(scan)) { + case BOL: + if (locinput == regbol ? regprev == '\n' : + ((nextchar || locinput < regeol) && + locinput[-1] == '\n') ) + { + /* regtill = regbol; */ + break; + } + return(0); + case EOL: + if ((nextchar || locinput < regeol) && nextchar != '\n') + return(0); + if (!multiline && regeol - locinput > 1) + return 0; + /* regtill = regbol; */ + break; + case ANY: + if ((nextchar == '\0' && locinput >= regeol) || + nextchar == '\n') + return(0); + nextchar = *++locinput; + break; + case EXACTLY: + s = OPERAND(scan); + ln = *s++; + /* Inline the first character, for speed. */ + if (*s != nextchar) + return(0); + if (regeol - locinput < ln) + return 0; + if (ln > 1 && bcmp(s, locinput, ln) != 0) + return(0); + locinput += ln; + nextchar = *locinput; + break; + case ANYOF: + s = OPERAND(scan); + if (nextchar < 0) + nextchar = UCHARAT(locinput); + if (s[nextchar >> 3] & (1 << (nextchar&7))) + return(0); + if (!nextchar && locinput >= regeol) + return 0; + nextchar = *++locinput; + break; + case ALNUM: + if (!nextchar) + return(0); + if (!isALNUM(nextchar)) + return(0); + nextchar = *++locinput; + break; + case NALNUM: + if (!nextchar && locinput >= regeol) + return(0); + if (isALNUM(nextchar)) + return(0); + nextchar = *++locinput; + break; + case NBOUND: + case BOUND: + if (locinput == regbol) /* was last char in word? */ + ln = isALNUM(regprev); + else + ln = isALNUM(locinput[-1]); + n = isALNUM(nextchar); /* is next char in word? */ + if ((ln == n) == (OP(scan) == BOUND)) + return(0); + break; + case SPACE: + if (!nextchar && locinput >= regeol) + return(0); + if (!isSPACE(nextchar)) + return(0); + nextchar = *++locinput; + break; + case NSPACE: + if (!nextchar) + return(0); + if (isSPACE(nextchar)) + return(0); + nextchar = *++locinput; + break; + case DIGIT: + if (!isDIGIT(nextchar)) + return(0); + nextchar = *++locinput; + break; + case NDIGIT: + if (!nextchar && locinput >= regeol) + return(0); + if (isDIGIT(nextchar)) + return(0); + nextchar = *++locinput; + break; + case REF: + n = ARG1(scan); /* which paren pair */ + s = regmystartp[n]; + if (!s) + return(0); + if (!regmyendp[n]) + return(0); + if (s == regmyendp[n]) + break; + /* Inline the first character, for speed. */ + if (*s != nextchar) + return(0); + ln = regmyendp[n] - s; + if (locinput + ln > regeol) + return 0; + if (ln > 1 && bcmp(s, locinput, ln) != 0) + return(0); + locinput += ln; + nextchar = *locinput; + break; + + case NOTHING: + break; + case BACK: + break; + case OPEN: + n = ARG1(scan); /* which paren pair */ + reginput = locinput; + + regmystartp[n] = locinput; /* for REF */ + if (regmatch(next)) { + /* + * Don't set startp if some later + * invocation of the same parentheses + * already has. + */ + if (regstartp[n] == NULL) + regstartp[n] = locinput; + return(1); + } else + return(0); + /* NOTREACHED */ + case CLOSE: { + n = ARG1(scan); /* which paren pair */ + reginput = locinput; + + regmyendp[n] = locinput; /* for REF */ + if (regmatch(next)) { + /* + * Don't set endp if some later + * invocation of the same parentheses + * already has. + */ + if (regendp[n] == NULL) { + regendp[n] = locinput; + if (n > *reglastparen) + *reglastparen = n; + } + return(1); + } else + return(0); + } + /*NOTREACHED*/ + case BRANCH: { + if (OP(next) != BRANCH) /* No choice. */ + next = NEXTOPER(scan); /* Avoid recursion. */ + else { + do { + reginput = locinput; + if (regmatch(NEXTOPER(scan))) + return(1); +#ifdef REGALIGN + /*SUPPRESS 560*/ + if (n = NEXT(scan)) + scan += n; + else + scan = NULL; +#else + scan = regnext(scan); +#endif + } while (scan != NULL && OP(scan) == BRANCH); + return(0); + /* NOTREACHED */ + } + } + break; + case CURLY: + ln = ARG1(scan); /* min to match */ + n = ARG2(scan); /* max to match */ + scan = NEXTOPER(scan) + 4; + goto repeat; + case STAR: + ln = 0; + n = 32767; + scan = NEXTOPER(scan); + goto repeat; + case PLUS: + /* + * Lookahead to avoid useless match attempts + * when we know what character comes next. + */ + ln = 1; + n = 32767; + scan = NEXTOPER(scan); + repeat: + if (OP(next) == EXACTLY) + nextchar = *(OPERAND(next)+1); + else + nextchar = -1000; + reginput = locinput; + n = regrepeat(scan, n); + if (!multiline && OP(next) == EOL && ln < n) + ln = n; /* why back off? */ + while (n >= ln) { + /* If it could work, try it. */ + if (nextchar == -1000 || *reginput == nextchar) + if (regmatch(next)) + return(1); + /* Couldn't or didn't -- back up. */ + n--; + reginput = locinput + n; + } + return(0); + case END: + reginput = locinput; /* put where regtry can find it */ + return(1); /* Success! */ + default: + printf("%x %d\n",scan,scan[1]); + FAIL("regexp memory corruption"); + } + + scan = next; + } + + /* + * We get here only if there's trouble -- normally "case END" is + * the terminating point. + */ + FAIL("corrupted regexp pointers"); + /*NOTREACHED*/ +#ifdef lint + return 0; +#endif +} + +/* + - regrepeat - repeatedly match something simple, report how many + */ +/* + * [This routine now assumes that it will only match on things of length 1. + * That was true before, but now we assume scan - reginput is the count, + * rather than incrementing count on every character.] + */ +static int +regrepeat(p, max) +char *p; +int max; +{ + register char *scan; + register char *opnd; + register int c; + register char *loceol = regeol; + + scan = reginput; + if (max != 32767 && max < loceol - scan) + loceol = scan + max; + opnd = OPERAND(p); + switch (OP(p)) { + case ANY: + while (scan < loceol && *scan != '\n') + scan++; + break; + case EXACTLY: /* length of string is 1 */ + opnd++; + while (scan < loceol && *opnd == *scan) + scan++; + break; + case ANYOF: + c = UCHARAT(scan); + while (scan < loceol && !(opnd[c >> 3] & (1 << (c & 7)))) { + scan++; + c = UCHARAT(scan); + } + break; + case ALNUM: + while (scan < loceol && isALNUM(*scan)) + scan++; + break; + case NALNUM: + while (scan < loceol && !isALNUM(*scan)) + scan++; + break; + case SPACE: + while (scan < loceol && isSPACE(*scan)) + scan++; + break; + case NSPACE: + while (scan < loceol && !isSPACE(*scan)) + scan++; + break; + case DIGIT: + while (scan < loceol && isDIGIT(*scan)) + scan++; + break; + case NDIGIT: + while (scan < loceol && !isDIGIT(*scan)) + scan++; + break; + default: /* Oh dear. Called inappropriately. */ + FAIL("internal regexp foulup"); + /* NOTREACHED */ + } + + c = scan - reginput; + reginput = scan; + + return(c); +} + +/* + - regnext - dig the "next" pointer out of a node + * + * [Note, when REGALIGN is defined there are two places in regmatch() + * that bypass this code for speed.] + */ +char * +regnext(p) +register char *p; +{ + register int offset; + + if (p == ®dummy) + return(NULL); + + offset = NEXT(p); + if (offset == 0) + return(NULL); + +#ifdef REGALIGN + return(p+offset); +#else + if (OP(p) == BACK) + return(p-offset); + else + return(p+offset); +#endif +} diff --git a/gnu/usr.bin/perl/perl/regexp.h b/gnu/usr.bin/perl/perl/regexp.h new file mode 100644 index 0000000..66a1b88 --- /dev/null +++ b/gnu/usr.bin/perl/perl/regexp.h @@ -0,0 +1,53 @@ +/* + * Definitions etc. for regexp(3) routines. + * + * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], + * not the System V one. + */ + +/* $RCSfile: regexp.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:39 $ + * + * $Log: regexp.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:39 nate + * PERL! + * + * Revision 4.0.1.2 91/11/05 18:24:31 lwall + * patch11: minimum match length calculation in regexp is now cumulative + * patch11: initial .* in pattern had dependency on value of $* + * + * Revision 4.0.1.1 91/06/07 11:51:18 lwall + * patch4: new copyright notice + * patch4: // wouldn't use previous pattern if it started with a null character + * patch4: $` was busted inside s/// + * + * Revision 4.0 91/03/20 01:39:23 lwall + * 4.0 baseline. + * + */ + +typedef struct regexp { + char **startp; + char **endp; + STR *regstart; /* Internal use only. */ + char *regstclass; + STR *regmust; /* Internal use only. */ + int regback; /* Can regmust locate first try? */ + int minlen; /* mininum possible length of $& */ + int prelen; /* length of precomp */ + char *precomp; /* pre-compilation regular expression */ + char *subbase; /* saved string so \digit works forever */ + char *subbeg; /* same, but not responsible for allocation */ + char *subend; /* end of subbase */ + char reganch; /* Internal use only. */ + char do_folding; /* do case-insensitive match? */ + char lastparen; /* last paren matched */ + char nparens; /* number of parentheses */ + char program[1]; /* Unwarranted chumminess with compiler. */ +} regexp; + +#define ROPT_ANCH 1 +#define ROPT_SKIP 2 +#define ROPT_IMPLICIT 4 + +regexp *regcomp(); +int regexec(); diff --git a/gnu/usr.bin/perl/perl/spat.h b/gnu/usr.bin/perl/perl/spat.h new file mode 100644 index 0000000..2a840e2 --- /dev/null +++ b/gnu/usr.bin/perl/perl/spat.h @@ -0,0 +1,46 @@ +/* $RCSfile: spat.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:39 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: spat.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:39 nate + * PERL! + * + * Revision 4.0.1.1 91/06/07 11:51:59 lwall + * patch4: new copyright notice + * patch4: added global modifier for pattern matches + * + * Revision 4.0 91/03/20 01:39:36 lwall + * 4.0 baseline. + * + */ + +struct scanpat { + SPAT *spat_next; /* list of all scanpats */ + REGEXP *spat_regexp; /* compiled expression */ + ARG *spat_repl; /* replacement string for subst */ + ARG *spat_runtime; /* compile pattern at runtime */ + STR *spat_short; /* for a fast bypass of execute() */ + short spat_flags; + char spat_slen; +}; + +#define SPAT_USED 1 /* spat has been used once already */ +#define SPAT_ONCE 2 /* use pattern only once per reset */ +#define SPAT_SCANFIRST 4 /* initial constant not anchored */ +#define SPAT_ALL 8 /* initial constant is whole pat */ +#define SPAT_SKIPWHITE 16 /* skip leading whitespace for split */ +#define SPAT_FOLD 32 /* case insensitivity */ +#define SPAT_CONST 64 /* subst replacement is constant */ +#define SPAT_KEEP 128 /* keep 1st runtime pattern forever */ +#define SPAT_GLOBAL 256 /* pattern had a g modifier */ + +EXT SPAT *curspat; /* what to do \ interps from */ +EXT SPAT *lastspat; /* what to use in place of null pattern */ + +EXT char *hint INIT(Nullch); /* hint from cmd_exec to do_match et al */ + +#define Nullspat Null(SPAT*) diff --git a/gnu/usr.bin/perl/perl/stab.c b/gnu/usr.bin/perl/perl/stab.c new file mode 100644 index 0000000..7082725 --- /dev/null +++ b/gnu/usr.bin/perl/perl/stab.c @@ -0,0 +1,1055 @@ +/* $RCSfile: stab.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:39 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: stab.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:39 nate + * PERL! + * + * Revision 4.0.1.5 1993/02/05 19:42:47 lwall + * patch36: length returned wrong value on certain semi-magical variables + * + * Revision 4.0.1.4 92/06/08 15:32:19 lwall + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: the debugger now warns you on lines that can't set a breakpoint + * patch20: the debugger made perl forget the last pattern used by // + * patch20: paragraph mode now skips extra newlines automatically + * patch20: ($<,$>) = ... didn't work on some architectures + * + * Revision 4.0.1.3 91/11/05 18:35:33 lwall + * patch11: length($x) was sometimes wrong for numeric $x + * patch11: perl now issues warning if $SIG{'ALARM'} is referenced + * patch11: *foo = undef coredumped + * patch11: solitary subroutine references no longer trigger typo warnings + * patch11: local(*FILEHANDLE) had a memory leak + * + * Revision 4.0.1.2 91/06/07 11:55:53 lwall + * patch4: new copyright notice + * patch4: added $^P variable to control calling of perldb routines + * patch4: added $^F variable to specify maximum system fd, default 2 + * patch4: $` was busted inside s/// + * patch4: default top-of-form format is now FILEHANDLE_TOP + * patch4: length($`), length($&), length($') now optimized to avoid string copy + * patch4: $^D |= 1024 now does syntax tree dump at run-time + * + * Revision 4.0.1.1 91/04/12 09:10:24 lwall + * patch1: Configure now differentiates getgroups() type from getgid() type + * patch1: you may now use "die" and "caller" in a signal handler + * + * Revision 4.0 91/03/20 01:39:41 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +#include +#endif + +static char *sig_name[] = { + SIG_NAME,0 +}; + +#ifdef VOIDSIG +#define handlertype void +#else +#define handlertype int +#endif + +static handlertype sighandler(); + +static int origalen = 0; + +STR * +stab_str(str) +STR *str; +{ + STAB *stab = str->str_u.str_stab; + register int paren; + register char *s; + register int i; + + if (str->str_rare) + return stab_val(stab); + + switch (*stab->str_magic->str_ptr) { + case '\004': /* ^D */ +#ifdef DEBUGGING + str_numset(stab_val(stab),(double)(debug & 32767)); +#endif + break; + case '\006': /* ^F */ + str_numset(stab_val(stab),(double)maxsysfd); + break; + case '\t': /* ^I */ + if (inplace) + str_set(stab_val(stab), inplace); + else + str_sset(stab_val(stab),&str_undef); + break; + case '\020': /* ^P */ + str_numset(stab_val(stab),(double)perldb); + break; + case '\024': /* ^T */ + str_numset(stab_val(stab),(double)basetime); + break; + case '\027': /* ^W */ + str_numset(stab_val(stab),(double)dowarn); + break; + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': case '&': + if (curspat) { + paren = atoi(stab_ename(stab)); + getparen: + if (curspat->spat_regexp && + paren <= curspat->spat_regexp->nparens && + (s = curspat->spat_regexp->startp[paren]) ) { + i = curspat->spat_regexp->endp[paren] - s; + if (i >= 0) + str_nset(stab_val(stab),s,i); + else + str_sset(stab_val(stab),&str_undef); + } + else + str_sset(stab_val(stab),&str_undef); + } + break; + case '+': + if (curspat) { + paren = curspat->spat_regexp->lastparen; + goto getparen; + } + break; + case '`': + if (curspat) { + if (curspat->spat_regexp && + (s = curspat->spat_regexp->subbeg) ) { + i = curspat->spat_regexp->startp[0] - s; + if (i >= 0) + str_nset(stab_val(stab),s,i); + else + str_nset(stab_val(stab),"",0); + } + else + str_nset(stab_val(stab),"",0); + } + break; + case '\'': + if (curspat) { + if (curspat->spat_regexp && + (s = curspat->spat_regexp->endp[0]) ) { + str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s); + } + else + str_nset(stab_val(stab),"",0); + } + break; + case '.': +#ifndef lint + if (last_in_stab && stab_io(last_in_stab)) { + str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines); + } +#endif + break; + case '?': + str_numset(stab_val(stab),(double)statusvalue); + break; + case '^': + s = stab_io(curoutstab)->top_name; + if (s) + str_set(stab_val(stab),s); + else { + str_set(stab_val(stab),stab_ename(curoutstab)); + str_cat(stab_val(stab),"_TOP"); + } + break; + case '~': + s = stab_io(curoutstab)->fmt_name; + if (!s) + s = stab_ename(curoutstab); + str_set(stab_val(stab),s); + break; +#ifndef lint + case '=': + str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len); + break; + case '-': + str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left); + break; + case '%': + str_numset(stab_val(stab),(double)stab_io(curoutstab)->page); + break; +#endif + case ':': + break; + case '/': + break; + case '[': + str_numset(stab_val(stab),(double)arybase); + break; + case '|': + if (!stab_io(curoutstab)) + stab_io(curoutstab) = stio_new(); + str_numset(stab_val(stab), + (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) ); + break; + case ',': + str_nset(stab_val(stab),ofs,ofslen); + break; + case '\\': + str_nset(stab_val(stab),ors,orslen); + break; + case '#': + str_set(stab_val(stab),ofmt); + break; + case '!': + str_numset(stab_val(stab), (double)errno); + str_set(stab_val(stab), errno ? strerror(errno) : ""); + stab_val(stab)->str_nok = 1; /* what a wonderful hack! */ + break; + case '<': + str_numset(stab_val(stab),(double)uid); + break; + case '>': + str_numset(stab_val(stab),(double)euid); + break; + case '(': + s = buf; + (void)sprintf(s,"%d",(int)gid); + goto add_groups; + case ')': + s = buf; + (void)sprintf(s,"%d",(int)egid); + add_groups: + while (*s) s++; +#ifdef HAS_GETGROUPS +#ifndef NGROUPS +#define NGROUPS 32 +#endif + { + GROUPSTYPE gary[NGROUPS]; + + i = getgroups(NGROUPS,gary); + while (--i >= 0) { + (void)sprintf(s," %ld", (long)gary[i]); + while (*s) s++; + } + } +#endif + str_set(stab_val(stab),buf); + break; + case '*': + break; + case '0': + break; + default: + { + struct ufuncs *uf = (struct ufuncs *)str->str_ptr; + + if (uf && uf->uf_val) + (*uf->uf_val)(uf->uf_index, stab_val(stab)); + } + break; + } + return stab_val(stab); +} + +STRLEN +stab_len(str) +STR *str; +{ + STAB *stab = str->str_u.str_stab; + int paren; + int i; + char *s; + + if (str->str_rare) + return str_len(stab_val(stab)); + + switch (*stab->str_magic->str_ptr) { + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': case '&': + if (curspat) { + paren = atoi(stab_ename(stab)); + getparen: + if (curspat->spat_regexp && + paren <= curspat->spat_regexp->nparens && + (s = curspat->spat_regexp->startp[paren]) ) { + i = curspat->spat_regexp->endp[paren] - s; + if (i >= 0) + return i; + else + return 0; + } + else + return 0; + } + break; + case '+': + if (curspat) { + paren = curspat->spat_regexp->lastparen; + goto getparen; + } + break; + case '`': + if (curspat) { + if (curspat->spat_regexp && + (s = curspat->spat_regexp->subbeg) ) { + i = curspat->spat_regexp->startp[0] - s; + if (i >= 0) + return i; + else + return 0; + } + else + return 0; + } + break; + case '\'': + if (curspat) { + if (curspat->spat_regexp && + (s = curspat->spat_regexp->endp[0]) ) { + return (STRLEN) (curspat->spat_regexp->subend - s); + } + else + return 0; + } + break; + case ',': + return (STRLEN)ofslen; + case '\\': + return (STRLEN)orslen; + } + return str_len(stab_str(str)); +} + +void +stabset(mstr,str) +register STR *mstr; +STR *str; +{ + STAB *stab; + register char *s; + int i; + + switch (mstr->str_rare) { + case 'E': + my_setenv(mstr->str_ptr,str_get(str)); + /* And you'll never guess what the dog had */ + /* in its mouth... */ +#ifdef TAINT + if (strEQ(mstr->str_ptr,"PATH")) { + char *strend = str->str_ptr + str->str_cur; + + s = str->str_ptr; + while (s < strend) { + s = cpytill(tokenbuf,s,strend,':',&i); + s++; + if (*tokenbuf != '/' + || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) ) + str->str_tainted = 2; + } + } +#endif + break; + case 'S': + s = str_get(str); + i = whichsig(mstr->str_ptr); /* ...no, a brick */ + if (!i && (dowarn || strEQ(mstr->str_ptr,"ALARM"))) + warn("No such signal: SIG%s", mstr->str_ptr); + if (strEQ(s,"IGNORE")) +#ifndef lint + (void)signal(i,SIG_IGN); +#else + ; +#endif + else if (strEQ(s,"DEFAULT") || !*s) + (void)signal(i,SIG_DFL); + else { + (void)signal(i,sighandler); + if (!index(s,'\'')) { + sprintf(tokenbuf, "main'%s",s); + str_set(str,tokenbuf); + } + } + break; +#ifdef SOME_DBM + case 'D': + stab = mstr->str_u.str_stab; + hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str); + break; +#endif + case 'L': + { + CMD *cmd; + + stab = mstr->str_u.str_stab; + i = str_true(str); + str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE); + if (str->str_magic && (cmd = str->str_magic->str_u.str_cmd)) { + cmd->c_flags &= ~CF_OPTIMIZE; + cmd->c_flags |= i? CFT_D1 : CFT_D0; + } + else + warn("Can't break at that line\n"); + } + break; + case '#': + stab = mstr->str_u.str_stab; + afill(stab_array(stab), (int)str_gnum(str) - arybase); + break; + case 'X': /* merely a copy of a * string */ + break; + case '*': + s = str->str_pok ? str_get(str) : ""; + if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) { + stab = mstr->str_u.str_stab; + if (!*s) { + STBP *stbp; + + /*SUPPRESS 701*/ + (void)savenostab(stab); /* schedule a free of this stab */ + if (stab->str_len) + Safefree(stab->str_ptr); + Newz(601,stbp, 1, STBP); + stab->str_ptr = stbp; + stab->str_len = stab->str_cur = sizeof(STBP); + stab->str_pok = 1; + strcpy(stab_magic(stab),"StB"); + stab_val(stab) = Str_new(70,0); + stab_line(stab) = curcmd->c_line; + stab_estab(stab) = stab; + } + else { + stab = stabent(s,TRUE); + if (!stab_xarray(stab)) + aadd(stab); + if (!stab_xhash(stab)) + hadd(stab); + if (!stab_io(stab)) + stab_io(stab) = stio_new(); + } + str_sset(str, (STR*) stab); + } + break; + case 's': { + struct lstring *lstr = (struct lstring*)str; + char *tmps; + + mstr->str_rare = 0; + str->str_magic = Nullstr; + tmps = str_get(str); + str_insert(mstr,lstr->lstr_offset,lstr->lstr_len, + tmps,str->str_cur); + } + break; + + case 'v': + do_vecset(mstr,str); + break; + + case 0: + /*SUPPRESS 560*/ + if (!(stab = mstr->str_u.str_stab)) + break; + switch (*stab->str_magic->str_ptr) { + case '\004': /* ^D */ +#ifdef DEBUGGING + debug = (int)(str_gnum(str)) | 32768; + if (debug & 1024) + dump_all(); +#endif + break; + case '\006': /* ^F */ + maxsysfd = (int)str_gnum(str); + break; + case '\t': /* ^I */ + if (inplace) + Safefree(inplace); + if (str->str_pok || str->str_nok) + inplace = savestr(str_get(str)); + else + inplace = Nullch; + break; + case '\020': /* ^P */ + i = (int)str_gnum(str); + if (i != perldb) { + static SPAT *oldlastspat; + + if (perldb) + oldlastspat = lastspat; + else + lastspat = oldlastspat; + } + perldb = i; + break; + case '\024': /* ^T */ + basetime = (time_t)str_gnum(str); + break; + case '\027': /* ^W */ + dowarn = (bool)str_gnum(str); + break; + case '.': + if (localizing) + savesptr((STR**)&last_in_stab); + break; + case '^': + Safefree(stab_io(curoutstab)->top_name); + stab_io(curoutstab)->top_name = s = savestr(str_get(str)); + stab_io(curoutstab)->top_stab = stabent(s,TRUE); + break; + case '~': + Safefree(stab_io(curoutstab)->fmt_name); + stab_io(curoutstab)->fmt_name = s = savestr(str_get(str)); + stab_io(curoutstab)->fmt_stab = stabent(s,TRUE); + break; + case '=': + stab_io(curoutstab)->page_len = (long)str_gnum(str); + break; + case '-': + stab_io(curoutstab)->lines_left = (long)str_gnum(str); + if (stab_io(curoutstab)->lines_left < 0L) + stab_io(curoutstab)->lines_left = 0L; + break; + case '%': + stab_io(curoutstab)->page = (long)str_gnum(str); + break; + case '|': + if (!stab_io(curoutstab)) + stab_io(curoutstab) = stio_new(); + stab_io(curoutstab)->flags &= ~IOF_FLUSH; + if (str_gnum(str) != 0.0) { + stab_io(curoutstab)->flags |= IOF_FLUSH; + } + break; + case '*': + i = (int)str_gnum(str); + multiline = (i != 0); + break; + case '/': + if (str->str_pok) { + rs = str_get(str); + rslen = str->str_cur; + if (rspara = !rslen) { + rs = "\n\n"; + rslen = 2; + } + rschar = rs[rslen - 1]; + } + else { + rschar = 0777; /* fake a non-existent char */ + rslen = 1; + } + break; + case '\\': + if (ors) + Safefree(ors); + ors = savestr(str_get(str)); + orslen = str->str_cur; + break; + case ',': + if (ofs) + Safefree(ofs); + ofs = savestr(str_get(str)); + ofslen = str->str_cur; + break; + case '#': + if (ofmt) + Safefree(ofmt); + ofmt = savestr(str_get(str)); + break; + case '[': + arybase = (int)str_gnum(str); + break; + case '?': + statusvalue = U_S(str_gnum(str)); + break; + case '!': + errno = (int)str_gnum(str); /* will anyone ever use this? */ + break; + case '<': + uid = (int)str_gnum(str); + if (delaymagic) { + delaymagic |= DM_RUID; + break; /* don't do magic till later */ + } +#ifdef HAS_SETRUID + (void)setruid((UIDTYPE)uid); +#else +#ifdef HAS_SETREUID + (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1); +#else + if (uid == euid) /* special case $< = $> */ + (void)setuid(uid); + else + fatal("setruid() not implemented"); +#endif +#endif + uid = (int)getuid(); + break; + case '>': + euid = (int)str_gnum(str); + if (delaymagic) { + delaymagic |= DM_EUID; + break; /* don't do magic till later */ + } +#ifdef HAS_SETEUID + (void)seteuid((UIDTYPE)euid); +#else +#ifdef HAS_SETREUID + (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid); +#else + if (euid == uid) /* special case $> = $< */ + setuid(euid); + else + fatal("seteuid() not implemented"); +#endif +#endif + euid = (int)geteuid(); + break; + case '(': + gid = (int)str_gnum(str); + if (delaymagic) { + delaymagic |= DM_RGID; + break; /* don't do magic till later */ + } +#ifdef HAS_SETRGID + (void)setrgid((GIDTYPE)gid); +#else +#ifdef HAS_SETREGID + (void)setregid((GIDTYPE)gid, (GIDTYPE)-1); +#else + if (gid == egid) /* special case $( = $) */ + (void)setgid(gid); + else + fatal("setrgid() not implemented"); +#endif +#endif + gid = (int)getgid(); + break; + case ')': + egid = (int)str_gnum(str); + if (delaymagic) { + delaymagic |= DM_EGID; + break; /* don't do magic till later */ + } +#ifdef HAS_SETEGID + (void)setegid((GIDTYPE)egid); +#else +#ifdef HAS_SETREGID + (void)setregid((GIDTYPE)-1, (GIDTYPE)egid); +#else + if (egid == gid) /* special case $) = $( */ + (void)setgid(egid); + else + fatal("setegid() not implemented"); +#endif +#endif + egid = (int)getegid(); + break; + case ':': + chopset = str_get(str); + break; + case '0': + if (!origalen) { + s = origargv[0]; + s += strlen(s); + /* See if all the arguments are contiguous in memory */ + for (i = 1; i < origargc; i++) { + if (origargv[i] == s + 1) + s += strlen(++s); /* this one is ok too */ + } + if (origenviron[0] == s + 1) { /* can grab env area too? */ + my_setenv("NoNeSuCh", Nullch); + /* force copy of environment */ + for (i = 0; origenviron[i]; i++) + if (origenviron[i] == s + 1) + s += strlen(++s); + } + origalen = s - origargv[0]; + } + s = str_get(str); + i = str->str_cur; + if (i >= origalen) { + i = origalen; + str->str_cur = i; + str->str_ptr[i] = '\0'; + Copy(s, origargv[0], i, char); + } + else { + Copy(s, origargv[0], i, char); + s = origargv[0]+i; + *s++ = '\0'; + while (++i < origalen) + *s++ = ' '; + } + break; + default: + { + struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr; + + if (uf && uf->uf_set) + (*uf->uf_set)(uf->uf_index, str); + } + break; + } + break; + } +} + +int +whichsig(sig) +char *sig; +{ + register char **sigv; + + for (sigv = sig_name+1; *sigv; sigv++) + if (strEQ(sig,*sigv)) + return sigv - sig_name; +#ifdef SIGCLD + if (strEQ(sig,"CHLD")) + return SIGCLD; +#endif +#ifdef SIGCHLD + if (strEQ(sig,"CLD")) + return SIGCHLD; +#endif + return 0; +} + +static handlertype +sighandler(sig) +int sig; +{ + STAB *stab; + STR *str; + int oldsave = savestack->ary_fill; + int oldtmps_base = tmps_base; + register CSV *csv; + SUBR *sub; + +#ifdef OS2 /* or anybody else who requires SIG_ACK */ + signal(sig, SIG_ACK); +#endif + stab = stabent( + str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]), + TRUE)), TRUE); + sub = stab_sub(stab); + if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) { + if (sig_name[sig][1] == 'H') + stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)), + TRUE); + else + stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)), + TRUE); + sub = stab_sub(stab); /* gag */ + } + if (!sub) { + if (dowarn) + warn("SIG%s handler \"%s\" not defined.\n", + sig_name[sig], stab_ename(stab) ); + return; + } + /*SUPPRESS 701*/ + saveaptr(&stack); + str = Str_new(15, sizeof(CSV)); + str->str_state = SS_SCSV; + (void)apush(savestack,str); + csv = (CSV*)str->str_ptr; + csv->sub = sub; + csv->stab = stab; + csv->curcsv = curcsv; + csv->curcmd = curcmd; + csv->depth = sub->depth; + csv->wantarray = G_SCALAR; + csv->hasargs = TRUE; + csv->savearray = stab_xarray(defstab); + csv->argarray = stab_xarray(defstab) = stack = anew(defstab); + stack->ary_flags = 0; + curcsv = csv; + str = str_mortal(&str_undef); + str_set(str,sig_name[sig]); + (void)apush(stab_xarray(defstab),str); + sub->depth++; + if (sub->depth >= 2) { /* save temporaries on recursion? */ + if (sub->depth == 100 && dowarn) + warn("Deep recursion on subroutine \"%s\"",stab_ename(stab)); + savelist(sub->tosave->ary_array,sub->tosave->ary_fill); + } + + tmps_base = tmps_max; /* protect our mortal string */ + (void)cmd_exec(sub->cmd,G_SCALAR,0); /* so do it already */ + tmps_base = oldtmps_base; + + restorelist(oldsave); /* put everything back */ +} + +STAB * +aadd(stab) +register STAB *stab; +{ + if (!stab_xarray(stab)) + stab_xarray(stab) = anew(stab); + return stab; +} + +STAB * +hadd(stab) +register STAB *stab; +{ + if (!stab_xhash(stab)) + stab_xhash(stab) = hnew(COEFFSIZE); + return stab; +} + +STAB * +fstab(name) +char *name; +{ + char tmpbuf[1200]; + STAB *stab; + + sprintf(tmpbuf,"'_<%s", name); + stab = stabent(tmpbuf, TRUE); + str_set(stab_val(stab), name); + if (perldb) + (void)hadd(aadd(stab)); + return stab; +} + +STAB * +stabent(name,add) +register char *name; +int add; +{ + register STAB *stab; + register STBP *stbp; + int len; + register char *namend; + HASH *stash; + char *sawquote = Nullch; + char *prevquote = Nullch; + bool global = FALSE; + + if (isUPPER(*name)) { + if (*name > 'I') { + if (*name == 'S' && ( + strEQ(name, "SIG") || + strEQ(name, "STDIN") || + strEQ(name, "STDOUT") || + strEQ(name, "STDERR") )) + global = TRUE; + } + else if (*name > 'E') { + if (*name == 'I' && strEQ(name, "INC")) + global = TRUE; + } + else if (*name > 'A') { + if (*name == 'E' && strEQ(name, "ENV")) + global = TRUE; + } + else if (*name == 'A' && ( + strEQ(name, "ARGV") || + strEQ(name, "ARGVOUT") )) + global = TRUE; + } + for (namend = name; *namend; namend++) { + if (*namend == '\'' && namend[1]) + prevquote = sawquote, sawquote = namend; + } + if (sawquote == name && name[1]) { + stash = defstash; + sawquote = Nullch; + name++; + } + else if (!isALPHA(*name) || global) + stash = defstash; + else if ((CMD*)curcmd == &compiling) + stash = curstash; + else + stash = curcmd->c_stash; + if (sawquote) { + char tmpbuf[256]; + char *s, *d; + + *sawquote = '\0'; + /*SUPPRESS 560*/ + if (s = prevquote) { + strncpy(tmpbuf,name,s-name+1); + d = tmpbuf+(s-name+1); + *d++ = '_'; + strcpy(d,s+1); + } + else { + *tmpbuf = '_'; + strcpy(tmpbuf+1,name); + } + stab = stabent(tmpbuf,TRUE); + if (!(stash = stab_xhash(stab))) + stash = stab_xhash(stab) = hnew(0); + if (!stash->tbl_name) + stash->tbl_name = savestr(name); + name = sawquote+1; + *sawquote = '\''; + } + len = namend - name; + stab = (STAB*)hfetch(stash,name,len,add); + if (stab == (STAB*)&str_undef) + return Nullstab; + if (stab->str_pok) { + stab->str_pok |= SP_MULTI; + return stab; + } + else { + if (stab->str_len) + Safefree(stab->str_ptr); + Newz(602,stbp, 1, STBP); + stab->str_ptr = stbp; + stab->str_len = stab->str_cur = sizeof(STBP); + stab->str_pok = 1; + strcpy(stab_magic(stab),"StB"); + stab_val(stab) = Str_new(72,0); + stab_line(stab) = curcmd->c_line; + stab_estab(stab) = stab; + str_magic((STR*)stab, stab, '*', name, len); + stab_stash(stab) = stash; + if (isDIGIT(*name) && *name != '0') { + stab_flags(stab) = SF_VMAGIC; + str_magic(stab_val(stab), stab, 0, Nullch, 0); + } + if (add & 2) + stab->str_pok |= SP_MULTI; + return stab; + } +} + +void +stab_fullname(str,stab) +STR *str; +STAB *stab; +{ + HASH *tb = stab_stash(stab); + + if (!tb) + return; + str_set(str,tb->tbl_name); + str_ncat(str,"'", 1); + str_scat(str,stab->str_magic); +} + +void +stab_efullname(str,stab) +STR *str; +STAB *stab; +{ + HASH *tb = stab_estash(stab); + + if (!tb) + return; + str_set(str,tb->tbl_name); + str_ncat(str,"'", 1); + str_scat(str,stab_estab(stab)->str_magic); +} + +STIO * +stio_new() +{ + STIO *stio; + + Newz(603,stio,1,STIO); + stio->page_len = 60; + return stio; +} + +void +stab_check(min,max) +int min; +register int max; +{ + register HENT *entry; + register int i; + register STAB *stab; + + for (i = min; i <= max; i++) { + for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) { + stab = (STAB*)entry->hent_val; + if (stab->str_pok & SP_MULTI) + continue; + curcmd->c_line = stab_line(stab); + warn("Possible typo: \"%s\"", stab_name(stab)); + } + } +} + +static int gensym = 0; + +STAB * +genstab() +{ + (void)sprintf(tokenbuf,"_GEN_%d",gensym++); + return stabent(tokenbuf,TRUE); +} + +/* hopefully this is only called on local symbol table entries */ + +void +stab_clear(stab) +register STAB *stab; +{ + STIO *stio; + SUBR *sub; + + if (!stab || !stab->str_ptr) + return; + afree(stab_xarray(stab)); + stab_xarray(stab) = Null(ARRAY*); + (void)hfree(stab_xhash(stab), FALSE); + stab_xhash(stab) = Null(HASH*); + str_free(stab_val(stab)); + stab_val(stab) = Nullstr; + /*SUPPRESS 560*/ + if (stio = stab_io(stab)) { + do_close(stab,FALSE); + Safefree(stio->top_name); + Safefree(stio->fmt_name); + Safefree(stio); + } + /*SUPPRESS 560*/ + if (sub = stab_sub(stab)) { + afree(sub->tosave); + cmd_free(sub->cmd); + } + Safefree(stab->str_ptr); + stab->str_ptr = Null(STBP*); + stab->str_len = 0; + stab->str_cur = 0; +} + +#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) +#define MICROPORT +#endif + +#ifdef MICROPORT /* Microport 2.4 hack */ +ARRAY *stab_array(stab) +register STAB *stab; +{ + if (((STBP*)(stab->str_ptr))->stbp_array) + return ((STBP*)(stab->str_ptr))->stbp_array; + else + return ((STBP*)(aadd(stab)->str_ptr))->stbp_array; +} + +HASH *stab_hash(stab) +register STAB *stab; +{ + if (((STBP*)(stab->str_ptr))->stbp_hash) + return ((STBP*)(stab->str_ptr))->stbp_hash; + else + return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash; +} +#endif /* Microport 2.4 hack */ diff --git a/gnu/usr.bin/perl/perl/stab.h b/gnu/usr.bin/perl/perl/stab.h new file mode 100644 index 0000000..7bce082 --- /dev/null +++ b/gnu/usr.bin/perl/perl/stab.h @@ -0,0 +1,145 @@ +/* $RCSfile: stab.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:39 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: stab.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:39 nate + * PERL! + * + * Revision 4.0.1.3 92/06/08 15:33:44 lwall + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: ($<,$>) = ... didn't work on some architectures + * + * Revision 4.0.1.2 91/11/05 18:36:15 lwall + * patch11: length($x) was sometimes wrong for numeric $x + * + * Revision 4.0.1.1 91/06/07 11:56:35 lwall + * patch4: new copyright notice + * patch4: length($`), length($&), length($') now optimized to avoid string copy + * + * Revision 4.0 91/03/20 01:39:49 lwall + * 4.0 baseline. + * + */ + +struct stabptrs { + char stbp_magic[4]; + STR *stbp_val; /* scalar value */ + struct stio *stbp_io; /* filehandle value */ + FCMD *stbp_form; /* format value */ + ARRAY *stbp_array; /* array value */ + HASH *stbp_hash; /* associative array value */ + STAB *stbp_stab; /* effective stab, if *glob */ + SUBR *stbp_sub; /* subroutine value */ + int stbp_lastexpr; /* used by nothing_in_common() */ + line_t stbp_line; /* line first declared at (for -w) */ + char stbp_flags; +}; + +#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) +#define MICROPORT +#endif + +#define stab_magic(stab) (((STBP*)(stab->str_ptr))->stbp_magic) +#define stab_val(stab) (((STBP*)(stab->str_ptr))->stbp_val) +#define stab_io(stab) (((STBP*)(stab->str_ptr))->stbp_io) +#define stab_form(stab) (((STBP*)(stab->str_ptr))->stbp_form) +#define stab_xarray(stab) (((STBP*)(stab->str_ptr))->stbp_array) +#ifdef MICROPORT /* Microport 2.4 hack */ +ARRAY *stab_array(); +#else +#define stab_array(stab) (((STBP*)(stab->str_ptr))->stbp_array ? \ + ((STBP*)(stab->str_ptr))->stbp_array : \ + ((STBP*)(aadd(stab)->str_ptr))->stbp_array) +#endif +#define stab_xhash(stab) (((STBP*)(stab->str_ptr))->stbp_hash) +#ifdef MICROPORT /* Microport 2.4 hack */ +HASH *stab_hash(); +#else +#define stab_hash(stab) (((STBP*)(stab->str_ptr))->stbp_hash ? \ + ((STBP*)(stab->str_ptr))->stbp_hash : \ + ((STBP*)(hadd(stab)->str_ptr))->stbp_hash) +#endif /* Microport 2.4 hack */ +#define stab_sub(stab) (((STBP*)(stab->str_ptr))->stbp_sub) +#define stab_lastexpr(stab) (((STBP*)(stab->str_ptr))->stbp_lastexpr) +#define stab_line(stab) (((STBP*)(stab->str_ptr))->stbp_line) +#define stab_flags(stab) (((STBP*)(stab->str_ptr))->stbp_flags) + +#define stab_stab(stab) (stab->str_magic->str_u.str_stab) +#define stab_estab(stab) (((STBP*)(stab->str_ptr))->stbp_stab) + +#define stab_name(stab) (stab->str_magic->str_ptr) +#define stab_ename(stab) stab_name(stab_estab(stab)) + +#define stab_stash(stab) (stab->str_magic->str_u.str_stash) +#define stab_estash(stab) stab_stash(stab_estab(stab)) + +#define SF_VMAGIC 1 /* call routine to dereference STR val */ +#define SF_MULTI 2 /* seen more than once */ + +struct stio { + FILE *ifp; /* ifp and ofp are normally the same */ + FILE *ofp; /* but sockets need separate streams */ +#ifdef HAS_READDIR + DIR *dirp; /* for opendir, readdir, etc */ +#endif + long lines; /* $. */ + long page; /* $% */ + long page_len; /* $= */ + long lines_left; /* $- */ + char *top_name; /* $^ */ + STAB *top_stab; /* $^ */ + char *fmt_name; /* $~ */ + STAB *fmt_stab; /* $~ */ + short subprocess; /* -| or |- */ + char type; + char flags; +}; + +#define IOF_ARGV 1 /* this fp iterates over ARGV */ +#define IOF_START 2 /* check for null ARGV and substitute '-' */ +#define IOF_FLUSH 4 /* this fp wants a flush after write op */ + +struct sub { + CMD *cmd; + int (*usersub)(); + int userindex; + STAB *filestab; + long depth; /* >= 2 indicates recursive call */ + ARRAY *tosave; +}; + +#define Nullstab Null(STAB*) + +STRLEN stab_len(); + +#define STAB_STR(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_str(stab_val(tmpstab)->str_magic) : stab_val(tmpstab)) +#define STAB_LEN(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_len(stab_val(tmpstab)->str_magic) : str_len(stab_val(tmpstab))) +#define STAB_GET(s) (tmpstab = (s), str_get(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab))) +#define STAB_GNUM(s) (tmpstab = (s), str_gnum(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab))) + +EXT STAB *tmpstab; + +EXT STAB *stab_index[128]; + +EXT unsigned short statusvalue; + +EXT int delaymagic INIT(0); +#define DM_UID 0x003 +#define DM_RUID 0x001 +#define DM_EUID 0x002 +#define DM_GID 0x030 +#define DM_RGID 0x010 +#define DM_EGID 0x020 +#define DM_DELAY 0x100 + +STAB *aadd(); +STAB *hadd(); +STAB *fstab(); +void stabset(); +void stab_fullname(); +void stab_efullname(); +void stab_check(); diff --git a/gnu/usr.bin/perl/perl/str.c b/gnu/usr.bin/perl/perl/str.c new file mode 100644 index 0000000..f034292 --- /dev/null +++ b/gnu/usr.bin/perl/perl/str.c @@ -0,0 +1,1599 @@ +/* $RCSfile: str.c,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:39 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: str.c,v $ + * Revision 1.1.1.1 1993/08/23 21:29:39 nate + * PERL! + * + * Revision 4.0.1.7 1993/02/05 19:43:47 lwall + * patch36: the non-std stdio input code wasn't null-proof + * + * Revision 4.0.1.6 92/06/11 21:14:21 lwall + * patch34: quotes containing subscripts containing variables didn't parse right + * + * Revision 4.0.1.5 92/06/08 15:40:43 lwall + * patch20: removed implicit int declarations on functions + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: paragraph mode now skips extra newlines automatically + * patch20: fixed memory leak in doube-quote interpretation + * patch20: made /\$$foo/ look for literal '$foo' + * patch20: "$var{$foo'bar}" didn't scan subscript correctly + * patch20: a splice on non-existent array elements could dump core + * patch20: running taintperl explicitly now does checks even if $< == $> + * + * Revision 4.0.1.4 91/11/05 18:40:51 lwall + * patch11: $foo .= could overrun malloced memory + * patch11: \$ didn't always make it through double-quoter to regexp routines + * patch11: prepared for ctype implementations that don't define isascii() + * + * Revision 4.0.1.3 91/06/10 01:27:54 lwall + * patch10: $) and $| incorrectly handled in run-time patterns + * + * Revision 4.0.1.2 91/06/07 11:58:13 lwall + * patch4: new copyright notice + * patch4: taint check on undefined string could cause core dump + * + * Revision 4.0.1.1 91/04/12 09:15:30 lwall + * patch1: fixed undefined environ problem + * patch1: substr($ENV{"PATH"},0,0) = "/foo:" didn't modify environment + * patch1: $foo .= could cause core dump for certain lengths of $foo + * + * Revision 4.0 91/03/20 01:39:55 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "perly.h" + +static void ucase(); +static void lcase(); + +#ifndef str_get +char * +str_get(str) +STR *str; +{ +#ifdef TAINT + tainted |= str->str_tainted; +#endif + return str->str_pok ? str->str_ptr : str_2ptr(str); +} +#endif + +/* dlb ... guess we have a "crippled cc". + * dlb the following functions are usually macros. + */ +#ifndef str_true +int +str_true(Str) +STR *Str; +{ + if (Str->str_pok) { + if (*Str->str_ptr > '0' || + Str->str_cur > 1 || + (Str->str_cur && *Str->str_ptr != '0')) + return 1; + return 0; + } + if (Str->str_nok) + return (Str->str_u.str_nval != 0.0); + return 0; +} +#endif /* str_true */ + +#ifndef str_gnum +double str_gnum(Str) +STR *Str; +{ +#ifdef TAINT + tainted |= Str->str_tainted; +#endif /* TAINT*/ + if (Str->str_nok) + return Str->str_u.str_nval; + return str_2num(Str); +} +#endif /* str_gnum */ +/* dlb ... end of crutch */ + +char * +str_grow(str,newlen) +register STR *str; +#ifndef DOSISH +register int newlen; +#else +unsigned long newlen; +#endif +{ + register char *s = str->str_ptr; + +#ifdef MSDOS + if (newlen >= 0x10000) { + fprintf(stderr, "Allocation too large: %lx\n", newlen); + exit(1); + } +#endif /* MSDOS */ + if (str->str_state == SS_INCR) { /* data before str_ptr? */ + str->str_len += str->str_u.str_useful; + str->str_ptr -= str->str_u.str_useful; + str->str_u.str_useful = 0L; + Move(s, str->str_ptr, str->str_cur+1, char); + s = str->str_ptr; + str->str_state = SS_NORM; /* normal again */ + if (newlen > str->str_len) + newlen += 10 * (newlen - str->str_cur); /* avoid copy each time */ + } + if (newlen > str->str_len) { /* need more room? */ + if (str->str_len) + Renew(s,newlen,char); + else + New(703,s,newlen,char); + str->str_ptr = s; + str->str_len = newlen; + } + return s; +} + +void +str_numset(str,num) +register STR *str; +double num; +{ + if (str->str_pok) { + str->str_pok = 0; /* invalidate pointer */ + if (str->str_state == SS_INCR) + Str_Grow(str,0); + } + str->str_u.str_nval = num; + str->str_state = SS_NORM; + str->str_nok = 1; /* validate number */ +#ifdef TAINT + str->str_tainted = tainted; +#endif +} + +char * +str_2ptr(str) +register STR *str; +{ + register char *s; + int olderrno; + + if (!str) + return ""; + if (str->str_nok) { + STR_GROW(str, 30); + s = str->str_ptr; + olderrno = errno; /* some Xenix systems wipe out errno here */ +#if defined(scs) && defined(ns32000) + gcvt(str->str_u.str_nval,20,s); +#else +#ifdef apollo + if (str->str_u.str_nval == 0.0) + (void)strcpy(s,"0"); + else +#endif /*apollo*/ + (void)sprintf(s,"%.20g",str->str_u.str_nval); +#endif /*scs*/ + errno = olderrno; + while (*s) s++; +#ifdef hcx + if (s[-1] == '.') + s--; +#endif + } + else { + if (str == &str_undef) + return No; + if (dowarn) + warn("Use of uninitialized variable"); + STR_GROW(str, 30); + s = str->str_ptr; + } + *s = '\0'; + str->str_cur = s - str->str_ptr; + str->str_pok = 1; +#ifdef DEBUGGING + if (debug & 32) + fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr); +#endif + return str->str_ptr; +} + +double +str_2num(str) +register STR *str; +{ + if (!str) + return 0.0; + if (str->str_state == SS_INCR) + Str_Grow(str,0); /* just force copy down */ + str->str_state = SS_NORM; + if (str->str_len && str->str_pok) + str->str_u.str_nval = atof(str->str_ptr); + else { + if (str == &str_undef) + return 0.0; + if (dowarn) + warn("Use of uninitialized variable"); + str->str_u.str_nval = 0.0; + } + str->str_nok = 1; +#ifdef DEBUGGING + if (debug & 32) + fprintf(stderr,"0x%lx num(%g)\n",str,str->str_u.str_nval); +#endif + return str->str_u.str_nval; +} + +/* Note: str_sset() should not be called with a source string that needs + * be reused, since it may destroy the source string if it is marked + * as temporary. + */ + +void +str_sset(dstr,sstr) +STR *dstr; +register STR *sstr; +{ +#ifdef TAINT + if (sstr) + tainted |= sstr->str_tainted; +#endif + if (sstr == dstr || dstr == &str_undef) + return; + if (!sstr) + dstr->str_pok = dstr->str_nok = 0; + else if (sstr->str_pok) { + + /* + * Check to see if we can just swipe the string. If so, it's a + * possible small lose on short strings, but a big win on long ones. + * It might even be a win on short strings if dstr->str_ptr + * has to be allocated and sstr->str_ptr has to be freed. + */ + + if (sstr->str_pok & SP_TEMP) { /* slated for free anyway? */ + if (dstr->str_ptr) { + if (dstr->str_state == SS_INCR) + dstr->str_ptr -= dstr->str_u.str_useful; + Safefree(dstr->str_ptr); + } + dstr->str_ptr = sstr->str_ptr; + dstr->str_len = sstr->str_len; + dstr->str_cur = sstr->str_cur; + dstr->str_state = sstr->str_state; + dstr->str_pok = sstr->str_pok & ~SP_TEMP; +#ifdef TAINT + dstr->str_tainted = sstr->str_tainted; +#endif + sstr->str_ptr = Nullch; + sstr->str_len = 0; + sstr->str_pok = 0; /* wipe out any weird flags */ + sstr->str_state = 0; /* so sstr frees uneventfully */ + } + else { /* have to copy actual string */ + if (dstr->str_ptr) { + if (dstr->str_state == SS_INCR) { + Str_Grow(dstr,0); + } + } + str_nset(dstr,sstr->str_ptr,sstr->str_cur); + } + /*SUPPRESS 560*/ + if (dstr->str_nok = sstr->str_nok) + dstr->str_u.str_nval = sstr->str_u.str_nval; + else { +#ifdef STRUCTCOPY + dstr->str_u = sstr->str_u; +#else + dstr->str_u.str_nval = sstr->str_u.str_nval; +#endif + if (dstr->str_cur == sizeof(STBP)) { + char *tmps = dstr->str_ptr; + + if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) { + if (dstr->str_magic && dstr->str_magic->str_rare == 'X') { + str_free(dstr->str_magic); + dstr->str_magic = Nullstr; + } + if (!dstr->str_magic) { + dstr->str_magic = str_smake(sstr->str_magic); + dstr->str_magic->str_rare = 'X'; + } + } + } + } + } + else if (sstr->str_nok) + str_numset(dstr,sstr->str_u.str_nval); + else { + if (dstr->str_state == SS_INCR) + Str_Grow(dstr,0); /* just force copy down */ + +#ifdef STRUCTCOPY + dstr->str_u = sstr->str_u; +#else + dstr->str_u.str_nval = sstr->str_u.str_nval; +#endif + dstr->str_pok = dstr->str_nok = 0; + } +} + +void +str_nset(str,ptr,len) +register STR *str; +register char *ptr; +register STRLEN len; +{ + if (str == &str_undef) + return; + STR_GROW(str, len + 1); + if (ptr) + Move(ptr,str->str_ptr,len,char); + str->str_cur = len; + *(str->str_ptr+str->str_cur) = '\0'; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +#ifdef TAINT + str->str_tainted = tainted; +#endif +} + +void +str_set(str,ptr) +register STR *str; +register char *ptr; +{ + register STRLEN len; + + if (str == &str_undef) + return; + if (!ptr) + ptr = ""; + len = strlen(ptr); + STR_GROW(str, len + 1); + Move(ptr,str->str_ptr,len+1,char); + str->str_cur = len; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +#ifdef TAINT + str->str_tainted = tainted; +#endif +} + +void +str_chop(str,ptr) /* like set but assuming ptr is in str */ +register STR *str; +register char *ptr; +{ + register STRLEN delta; + + if (!ptr || !(str->str_pok)) + return; + delta = ptr - str->str_ptr; + str->str_len -= delta; + str->str_cur -= delta; + str->str_ptr += delta; + if (str->str_state == SS_INCR) + str->str_u.str_useful += delta; + else { + str->str_u.str_useful = delta; + str->str_state = SS_INCR; + } + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer (and unstudy str) */ +} + +void +str_ncat(str,ptr,len) +register STR *str; +register char *ptr; +register STRLEN len; +{ + if (str == &str_undef) + return; + if (!(str->str_pok)) + (void)str_2ptr(str); + STR_GROW(str, str->str_cur + len + 1); + Move(ptr,str->str_ptr+str->str_cur,len,char); + str->str_cur += len; + *(str->str_ptr+str->str_cur) = '\0'; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +#ifdef TAINT + str->str_tainted |= tainted; +#endif +} + +void +str_scat(dstr,sstr) +STR *dstr; +register STR *sstr; +{ + if (!sstr) + return; +#ifdef TAINT + tainted |= sstr->str_tainted; +#endif + if (!(sstr->str_pok)) + (void)str_2ptr(sstr); + if (sstr) + str_ncat(dstr,sstr->str_ptr,sstr->str_cur); +} + +void +str_cat(str,ptr) +register STR *str; +register char *ptr; +{ + register STRLEN len; + + if (str == &str_undef) + return; + if (!ptr) + return; + if (!(str->str_pok)) + (void)str_2ptr(str); + len = strlen(ptr); + STR_GROW(str, str->str_cur + len + 1); + Move(ptr,str->str_ptr+str->str_cur,len+1,char); + str->str_cur += len; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +#ifdef TAINT + str->str_tainted |= tainted; +#endif +} + +char * +str_append_till(str,from,fromend,delim,keeplist) +register STR *str; +register char *from; +register char *fromend; +register int delim; +char *keeplist; +{ + register char *to; + register STRLEN len; + + if (str == &str_undef) + return Nullch; + if (!from) + return Nullch; + len = fromend - from; + STR_GROW(str, str->str_cur + len + 1); + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ + to = str->str_ptr+str->str_cur; + for (; from < fromend; from++,to++) { + if (*from == '\\' && from+1 < fromend && delim != '\\') { + if (!keeplist) { + if (from[1] == delim || from[1] == '\\') + from++; + else + *to++ = *from++; + } + else if (from[1] && index(keeplist,from[1])) + *to++ = *from++; + else + from++; + } + else if (*from == delim) + break; + *to = *from; + } + *to = '\0'; + str->str_cur = to - str->str_ptr; + return from; +} + +STR * +#ifdef LEAKTEST +str_new(x,len) +int x; +#else +str_new(len) +#endif +STRLEN len; +{ + register STR *str; + + if (freestrroot) { + str = freestrroot; + freestrroot = str->str_magic; + str->str_magic = Nullstr; + str->str_state = SS_NORM; + } + else { + Newz(700+x,str,1,STR); + } + if (len) + STR_GROW(str, len + 1); + return str; +} + +void +str_magic(str, stab, how, name, namlen) +register STR *str; +STAB *stab; +int how; +char *name; +STRLEN namlen; +{ + if (str == &str_undef || str->str_magic) + return; + str->str_magic = Str_new(75,namlen); + str = str->str_magic; + str->str_u.str_stab = stab; + str->str_rare = how; + if (name) + str_nset(str,name,namlen); +} + +void +str_insert(bigstr,offset,len,little,littlelen) +STR *bigstr; +STRLEN offset; +STRLEN len; +char *little; +STRLEN littlelen; +{ + register char *big; + register char *mid; + register char *midend; + register char *bigend; + register int i; + + if (bigstr == &str_undef) + return; + bigstr->str_nok = 0; + bigstr->str_pok = SP_VALID; /* disable possible screamer */ + + i = littlelen - len; + if (i > 0) { /* string might grow */ + STR_GROW(bigstr, bigstr->str_cur + i + 1); + big = bigstr->str_ptr; + mid = big + offset + len; + midend = bigend = big + bigstr->str_cur; + bigend += i; + *bigend = '\0'; + while (midend > mid) /* shove everything down */ + *--bigend = *--midend; + Move(little,big+offset,littlelen,char); + bigstr->str_cur += i; + STABSET(bigstr); + return; + } + else if (i == 0) { + Move(little,bigstr->str_ptr+offset,len,char); + STABSET(bigstr); + return; + } + + big = bigstr->str_ptr; + mid = big + offset; + midend = mid + len; + bigend = big + bigstr->str_cur; + + if (midend > bigend) + fatal("panic: str_insert"); + + if (mid - big > bigend - midend) { /* faster to shorten from end */ + if (littlelen) { + Move(little, mid, littlelen,char); + mid += littlelen; + } + i = bigend - midend; + if (i > 0) { + Move(midend, mid, i,char); + mid += i; + } + *mid = '\0'; + bigstr->str_cur = mid - big; + } + /*SUPPRESS 560*/ + else if (i = mid - big) { /* faster from front */ + midend -= littlelen; + mid = midend; + str_chop(bigstr,midend-i); + big += i; + while (i--) + *--midend = *--big; + if (littlelen) + Move(little, mid, littlelen,char); + } + else if (littlelen) { + midend -= littlelen; + str_chop(bigstr,midend); + Move(little,midend,littlelen,char); + } + else { + str_chop(bigstr,midend); + } + STABSET(bigstr); +} + +/* make str point to what nstr did */ + +void +str_replace(str,nstr) +register STR *str; +register STR *nstr; +{ + if (str == &str_undef) + return; + if (str->str_state == SS_INCR) + Str_Grow(str,0); /* just force copy down */ + if (nstr->str_state == SS_INCR) + Str_Grow(nstr,0); + if (str->str_ptr) + Safefree(str->str_ptr); + str->str_ptr = nstr->str_ptr; + str->str_len = nstr->str_len; + str->str_cur = nstr->str_cur; + str->str_pok = nstr->str_pok; + str->str_nok = nstr->str_nok; +#ifdef STRUCTCOPY + str->str_u = nstr->str_u; +#else + str->str_u.str_nval = nstr->str_u.str_nval; +#endif +#ifdef TAINT + str->str_tainted = nstr->str_tainted; +#endif + if (nstr->str_magic) + str_free(nstr->str_magic); + Safefree(nstr); +} + +void +str_free(str) +register STR *str; +{ + if (!str || str == &str_undef) + return; + if (str->str_state) { + if (str->str_state == SS_FREE) /* already freed */ + return; + if (str->str_state == SS_INCR && !(str->str_pok & 2)) { + str->str_ptr -= str->str_u.str_useful; + str->str_len += str->str_u.str_useful; + } + } + if (str->str_magic) + str_free(str->str_magic); + str->str_magic = freestrroot; +#ifdef LEAKTEST + if (str->str_len) { + Safefree(str->str_ptr); + str->str_ptr = Nullch; + } + if ((str->str_pok & SP_INTRP) && str->str_u.str_args) + arg_free(str->str_u.str_args); + Safefree(str); +#else /* LEAKTEST */ + if (str->str_len) { + if (str->str_len > 127) { /* next user not likely to want more */ + Safefree(str->str_ptr); /* so give it back to malloc */ + str->str_ptr = Nullch; + str->str_len = 0; + } + else + str->str_ptr[0] = '\0'; + } + if ((str->str_pok & SP_INTRP) && str->str_u.str_args) + arg_free(str->str_u.str_args); + str->str_cur = 0; + str->str_nok = 0; + str->str_pok = 0; + str->str_state = SS_FREE; +#ifdef TAINT + str->str_tainted = 0; +#endif + freestrroot = str; +#endif /* LEAKTEST */ +} + +STRLEN +str_len(str) +register STR *str; +{ + if (!str) + return 0; + if (!(str->str_pok)) + (void)str_2ptr(str); + if (str->str_ptr) + return str->str_cur; + else + return 0; +} + +int +str_eq(str1,str2) +register STR *str1; +register STR *str2; +{ + if (!str1 || str1 == &str_undef) + return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur); + if (!str2 || str2 == &str_undef) + return !str1->str_cur; + + if (!str1->str_pok) + (void)str_2ptr(str1); + if (!str2->str_pok) + (void)str_2ptr(str2); + + if (str1->str_cur != str2->str_cur) + return 0; + + return !bcmp(str1->str_ptr, str2->str_ptr, str1->str_cur); +} + +int +str_cmp(str1,str2) +register STR *str1; +register STR *str2; +{ + int retval; + + if (!str1 || str1 == &str_undef) + return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur)?0:-1; + if (!str2 || str2 == &str_undef) + return str1->str_cur != 0; + + if (!str1->str_pok) + (void)str_2ptr(str1); + if (!str2->str_pok) + (void)str_2ptr(str2); + + if (str1->str_cur < str2->str_cur) { + /*SUPPRESS 560*/ + if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur)) + return retval < 0 ? -1 : 1; + else + return -1; + } + /*SUPPRESS 560*/ + else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur)) + return retval < 0 ? -1 : 1; + else if (str1->str_cur == str2->str_cur) + return 0; + else + return 1; +} + +char * +str_gets(str,fp,append) +register STR *str; +register FILE *fp; +int append; +{ + register char *bp; /* we're going to steal some values */ + register int cnt; /* from the stdio struct and put EVERYTHING */ + register STDCHAR *ptr; /* in the innermost loop into registers */ + register int newline = rschar;/* (assuming >= 6 registers) */ + int i; + STRLEN bpx; + int shortbuffered; + + if (str == &str_undef) + return Nullch; + if (rspara) { /* have to do this both before and after */ + do { /* to make sure file boundaries work right */ + i = getc(fp); + if (i != '\n') { + ungetc(i,fp); + break; + } + } while (i != EOF); + } +#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */ + cnt = fp->_cnt; /* get count into register */ + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ + if (str->str_len - append <= cnt + 1) { /* make sure we have the room */ + if (cnt > 80 && str->str_len > append) { + shortbuffered = cnt - str->str_len + append + 1; + cnt -= shortbuffered; + } + else { + shortbuffered = 0; + STR_GROW(str, append+cnt+2);/* (remembering cnt can be -1) */ + } + } + else + shortbuffered = 0; + bp = str->str_ptr + append; /* move these two too to registers */ + ptr = fp->_ptr; + for (;;) { + screamer: + while (--cnt >= 0) { /* this */ /* eat */ + if ((*bp++ = *ptr++) == newline) /* really */ /* dust */ + goto thats_all_folks; /* screams */ /* sed :-) */ + } + + if (shortbuffered) { /* oh well, must extend */ + cnt = shortbuffered; + shortbuffered = 0; + bpx = bp - str->str_ptr; /* prepare for possible relocation */ + str->str_cur = bpx; + STR_GROW(str, str->str_len + append + cnt + 2); + bp = str->str_ptr + bpx; /* reconstitute our pointer */ + continue; + } + + fp->_cnt = cnt; /* deregisterize cnt and ptr */ + fp->_ptr = ptr; + i = _filbuf(fp); /* get more characters */ + cnt = fp->_cnt; + ptr = fp->_ptr; /* reregisterize cnt and ptr */ + + bpx = bp - str->str_ptr; /* prepare for possible relocation */ + str->str_cur = bpx; + STR_GROW(str, bpx + cnt + 2); + bp = str->str_ptr + bpx; /* reconstitute our pointer */ + + if (i == newline) { /* all done for now? */ + *bp++ = i; + goto thats_all_folks; + } + else if (i == EOF) /* all done for ever? */ + goto thats_really_all_folks; + *bp++ = i; /* now go back to screaming loop */ + } + +thats_all_folks: + if (rslen > 1 && (bp - str->str_ptr < rslen || bcmp(bp - rslen, rs, rslen))) + goto screamer; /* go back to the fray */ +thats_really_all_folks: + if (shortbuffered) + cnt += shortbuffered; + fp->_cnt = cnt; /* put these back or we're in trouble */ + fp->_ptr = ptr; + *bp = '\0'; + str->str_cur = bp - str->str_ptr; /* set length */ + +#else /* !STDSTDIO */ /* The big, slow, and stupid way */ + + { + static char buf[8192]; + char * bpe = buf + sizeof(buf) - 3; + +screamer: + bp = buf; + while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) ; + + if (append) + str_ncat(str, buf, bp - buf); + else + str_nset(str, buf, bp - buf); + if (i != EOF /* joy */ + && + (i != newline + || + (rslen > 1 + && + (str->str_cur < rslen + || + bcmp(str->str_ptr + str->str_cur - rslen, rs, rslen) + ) + ) + ) + ) + { + append = -1; + goto screamer; + } + } + +#endif /* STDSTDIO */ + + if (rspara) { + while (i != EOF) { + i = getc(fp); + if (i != '\n') { + ungetc(i,fp); + break; + } + } + } + return str->str_cur - append ? str->str_ptr : Nullch; +} + +ARG * +parselist(str) +STR *str; +{ + register CMD *cmd; + register ARG *arg; + CMD *oldcurcmd = curcmd; + int oldperldb = perldb; + int retval; + + perldb = 0; + str_sset(linestr,str); + in_eval++; + oldoldbufptr = oldbufptr = bufptr = str_get(linestr); + bufend = bufptr + linestr->str_cur; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } + loop_stack[loop_ptr].loop_label = "_EVAL_"; + loop_stack[loop_ptr].loop_sp = 0; +#ifdef DEBUGGING + if (debug & 4) { + deb("(Pushing label #%d _EVAL_)\n", loop_ptr); + } +#endif + if (setjmp(loop_stack[loop_ptr].loop_env)) { + in_eval--; + loop_ptr--; + perldb = oldperldb; + fatal("%s\n",stab_val(stabent("@",TRUE))->str_ptr); + } +#ifdef DEBUGGING + if (debug & 4) { + char *tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, + tmps ? tmps : "" ); + } +#endif + loop_ptr--; + error_count = 0; + curcmd = &compiling; + curcmd->c_line = oldcurcmd->c_line; + retval = yyparse(); + curcmd = oldcurcmd; + perldb = oldperldb; + in_eval--; + if (retval || error_count) + fatal("Invalid component in string or format"); + cmd = eval_root; + arg = cmd->c_expr; + if (cmd->c_type != C_EXPR || cmd->c_next || arg->arg_type != O_LIST) + fatal("panic: error in parselist %d %x %d", cmd->c_type, + cmd->c_next, arg ? arg->arg_type : -1); + cmd->c_expr = Nullarg; + cmd_free(cmd); + eval_root = Nullcmd; + return arg; +} + +void +intrpcompile(src) +STR *src; +{ + register char *s = str_get(src); + register char *send = s + src->str_cur; + register STR *str; + register char *t; + STR *toparse; + STRLEN len; + register int brackets; + register char *d; + STAB *stab; + char *checkpoint; + int sawcase = 0; + + toparse = Str_new(76,0); + str = Str_new(77,0); + + str_nset(str,"",0); + str_nset(toparse,"",0); + t = s; + while (s < send) { + if (*s == '\\' && s[1] && index("$@[{\\]}lLuUE",s[1])) { + str_ncat(str, t, s - t); + ++s; + if (isALPHA(*s)) { + str_ncat(str, "$c", 2); + sawcase = (*s != 'E'); + } + else { + if (*nointrp) { /* in a regular expression */ + if (*s == '@') /* always strip \@ */ /*SUPPRESS 530*/ + ; + else /* don't strip \\, \[, \{ etc. */ + str_ncat(str,s-1,1); + } + str_ncat(str, "$b", 2); + } + str_ncat(str, s, 1); + ++s; + t = s; + } + else if (*s == '$' && s+1 < send && *nointrp && index(nointrp,s[1])) { + str_ncat(str, t, s - t); + str_ncat(str, "$b", 2); + str_ncat(str, s, 2); + s += 2; + t = s; + } + else if ((*s == '@' || *s == '$') && s+1 < send) { + str_ncat(str,t,s-t); + t = s; + if (*s == '$' && s[1] == '#' && (isALPHA(s[2]) || s[2] == '_')) + s++; + s = scanident(s,send,tokenbuf); + if (*t == '@' && + (!(stab = stabent(tokenbuf,FALSE)) || + (*s == '{' ? !stab_xhash(stab) : !stab_xarray(stab)) )) { + str_ncat(str,"@",1); + s = ++t; + continue; /* grandfather @ from old scripts */ + } + str_ncat(str,"$a",2); + str_ncat(toparse,",",1); + if (t[1] != '{' && (*s == '[' || *s == '{' /* }} */ ) && + (stab = stabent(tokenbuf,FALSE)) && + ((*s == '[') ? (stab_xarray(stab) != 0) : (stab_xhash(stab) != 0)) ) { + brackets = 0; + checkpoint = s; + do { + switch (*s) { + case '[': + brackets++; + break; + case '{': + brackets++; + break; + case ']': + brackets--; + break; + case '}': + brackets--; + break; + case '$': + case '%': + case '@': + case '&': + case '*': + s = scanident(s,send,tokenbuf); + continue; + case '\'': + case '"': + /*SUPPRESS 68*/ + s = cpytill(tokenbuf,s+1,send,*s,&len); + if (s >= send) + fatal("Unterminated string"); + break; + } + s++; + } while (brackets > 0 && s < send); + if (s > send) + fatal("Unmatched brackets in string"); + if (*nointrp) { /* we're in a regular expression */ + d = checkpoint; + if (*d == '{' && s[-1] == '}') { /* maybe {n,m} */ + ++d; + if (isDIGIT(*d)) { /* matches /^{\d,?\d*}$/ */ + if (*++d == ',') + ++d; + while (isDIGIT(*d)) + d++; + if (d == s - 1) + s = checkpoint; /* Is {n,m}! Backoff! */ + } + } + else if (*d == '[' && s[-1] == ']') { /* char class? */ + int weight = 2; /* let's weigh the evidence */ + char seen[256]; + unsigned char un_char = 0, last_un_char; + + Zero(seen,256,char); + *--s = '\0'; + if (d[1] == '^') + weight += 150; + else if (d[1] == '$') + weight -= 3; + if (isDIGIT(d[1])) { + if (d[2]) { + if (isDIGIT(d[2]) && !d[3]) + weight -= 10; + } + else + weight -= 100; + } + for (d++; d < s; d++) { + last_un_char = un_char; + un_char = (unsigned char)*d; + switch (*d) { + case '&': + case '$': + weight -= seen[un_char] * 10; + if (isALNUM(d[1])) { + d = scanident(d,s,tokenbuf); + if (stabent(tokenbuf,FALSE)) + weight -= 100; + else + weight -= 10; + } + else if (*d == '$' && d[1] && + index("[#!%*<>()-=",d[1])) { + if (!d[2] || /*{*/ index("])} =",d[2])) + weight -= 10; + else + weight -= 1; + } + break; + case '\\': + un_char = 254; + if (d[1]) { + if (index("wds",d[1])) + weight += 100; + else if (seen['\''] || seen['"']) + weight += 1; + else if (index("rnftb",d[1])) + weight += 40; + else if (isDIGIT(d[1])) { + weight += 40; + while (d[1] && isDIGIT(d[1])) + d++; + } + } + else + weight += 100; + break; + case '-': + if (last_un_char < (unsigned char) d[1] + || d[1] == '\\') { + if (index("aA01! ",last_un_char)) + weight += 30; + if (index("zZ79~",d[1])) + weight += 30; + } + else + weight -= 1; + default: + if (isALPHA(*d) && d[1] && isALPHA(d[1])) { + bufptr = d; + if (yylex() != WORD) + weight -= 150; + d = bufptr; + } + if (un_char == last_un_char + 1) + weight += 5; + weight -= seen[un_char]; + break; + } + seen[un_char]++; + } +#ifdef DEBUGGING + if (debug & 512) + fprintf(stderr,"[%s] weight %d\n", + checkpoint+1,weight); +#endif + *s++ = ']'; + if (weight >= 0) /* probably a character class */ + s = checkpoint; + } + } + } + if (*t == '@') + str_ncat(toparse, "join($\",", 8); + if (t[1] == '{' && s[-1] == '}') { + str_ncat(toparse, t, 1); + str_ncat(toparse, t+2, s - t - 3); + } + else + str_ncat(toparse, t, s - t); + if (*t == '@') + str_ncat(toparse, ")", 1); + t = s; + } + else + s++; + } + str_ncat(str,t,s-t); + if (sawcase) + str_ncat(str, "$cE", 3); + if (toparse->str_ptr && *toparse->str_ptr == ',') { + *toparse->str_ptr = '('; + str_ncat(toparse,",$$);",5); + str->str_u.str_args = parselist(toparse); + str->str_u.str_args->arg_len--; /* ignore $$ reference */ + } + else + str->str_u.str_args = Nullarg; + str_free(toparse); + str->str_pok |= SP_INTRP; + str->str_nok = 0; + str_replace(src,str); +} + +STR * +interp(str,src,sp) +register STR *str; +STR *src; +int sp; +{ + register char *s; + register char *t; + register char *send; + register STR **elem; + int docase = 0; + int l = 0; + int u = 0; + int L = 0; + int U = 0; + + if (str == &str_undef) + return Nullstr; + if (!(src->str_pok & SP_INTRP)) { + int oldsave = savestack->ary_fill; + + (void)savehptr(&curstash); + curstash = curcmd->c_stash; /* so stabent knows right package */ + intrpcompile(src); + restorelist(oldsave); + } + s = src->str_ptr; /* assumed valid since str_pok set */ + t = s; + send = s + src->str_cur; + + if (src->str_u.str_args) { + (void)eval(src->str_u.str_args,G_ARRAY,sp); + /* Assuming we have correct # of args */ + elem = stack->ary_array + sp; + } + + str_nset(str,"",0); + while (s < send) { + if (*s == '$' && s+1 < send) { + if (s-t > 0) + str_ncat(str,t,s-t); + switch(*++s) { + default: + fatal("panic: unknown interp cookie\n"); + break; + case 'a': + str_scat(str,*++elem); + break; + case 'b': + str_ncat(str,++s,1); + break; + case 'c': + if (docase && str->str_cur >= docase) { + char *b = str->str_ptr + --docase; + + if (L) + lcase(b, str->str_ptr + str->str_cur); + else if (U) + ucase(b, str->str_ptr + str->str_cur); + + if (u) /* note that l & u are independent of L & U */ + ucase(b, b+1); + else if (l) + lcase(b, b+1); + l = u = 0; + } + docase = str->str_cur + 1; + switch (*++s) { + case 'u': + u = 1; + l = 0; + break; + case 'U': + U = 1; + L = 0; + break; + case 'l': + l = 1; + u = 0; + break; + case 'L': + L = 1; + U = 0; + break; + case 'E': + docase = L = U = l = u = 0; + break; + } + break; + } + t = ++s; + } + else + s++; + } + if (s-t > 0) + str_ncat(str,t,s-t); + return str; +} + +static void +ucase(s,send) +register char *s; +register char *send; +{ + while (s < send) { + if (isLOWER(*s)) + *s = toupper(*s); + s++; + } +} + +static void +lcase(s,send) +register char *s; +register char *send; +{ + while (s < send) { + if (isUPPER(*s)) + *s = tolower(*s); + s++; + } +} + +void +str_inc(str) +register STR *str; +{ + register char *d; + + if (!str || str == &str_undef) + return; + if (str->str_nok) { + str->str_u.str_nval += 1.0; + str->str_pok = 0; + return; + } + if (!str->str_pok || !*str->str_ptr) { + str->str_u.str_nval = 1.0; + str->str_nok = 1; + str->str_pok = 0; + return; + } + d = str->str_ptr; + while (isALPHA(*d)) d++; + while (isDIGIT(*d)) d++; + if (*d) { + str_numset(str,atof(str->str_ptr) + 1.0); /* punt */ + return; + } + d--; + while (d >= str->str_ptr) { + if (isDIGIT(*d)) { + if (++*d <= '9') + return; + *(d--) = '0'; + } + else { + ++*d; + if (isALPHA(*d)) + return; + *(d--) -= 'z' - 'a' + 1; + } + } + /* oh,oh, the number grew */ + STR_GROW(str, str->str_cur + 2); + str->str_cur++; + for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--) + *d = d[-1]; + if (isDIGIT(d[1])) + *d = '1'; + else + *d = d[1]; +} + +void +str_dec(str) +register STR *str; +{ + if (!str || str == &str_undef) + return; + if (str->str_nok) { + str->str_u.str_nval -= 1.0; + str->str_pok = 0; + return; + } + if (!str->str_pok) { + str->str_u.str_nval = -1.0; + str->str_nok = 1; + return; + } + str_numset(str,atof(str->str_ptr) - 1.0); +} + +/* Make a string that will exist for the duration of the expression + * evaluation. Actually, it may have to last longer than that, but + * hopefully cmd_exec won't free it until it has been assigned to a + * permanent location. */ + +static long tmps_size = -1; + +STR * +str_mortal(oldstr) +STR *oldstr; +{ + register STR *str = Str_new(78,0); + + str_sset(str,oldstr); + if (++tmps_max > tmps_size) { + tmps_size = tmps_max; + if (!(tmps_size & 127)) { + if (tmps_size) + Renew(tmps_list, tmps_size + 128, STR*); + else + New(702,tmps_list, 128, STR*); + } + } + tmps_list[tmps_max] = str; + if (str->str_pok) + str->str_pok |= SP_TEMP; + return str; +} + +/* same thing without the copying */ + +STR * +str_2mortal(str) +register STR *str; +{ + if (!str || str == &str_undef) + return str; + if (++tmps_max > tmps_size) { + tmps_size = tmps_max; + if (!(tmps_size & 127)) { + if (tmps_size) + Renew(tmps_list, tmps_size + 128, STR*); + else + New(704,tmps_list, 128, STR*); + } + } + tmps_list[tmps_max] = str; + if (str->str_pok) + str->str_pok |= SP_TEMP; + return str; +} + +STR * +str_make(s,len) +char *s; +STRLEN len; +{ + register STR *str = Str_new(79,0); + + if (!len) + len = strlen(s); + str_nset(str,s,len); + return str; +} + +STR * +str_nmake(n) +double n; +{ + register STR *str = Str_new(80,0); + + str_numset(str,n); + return str; +} + +/* make an exact duplicate of old */ + +STR * +str_smake(old) +register STR *old; +{ + register STR *new = Str_new(81,0); + + if (!old) + return Nullstr; + if (old->str_state == SS_FREE) { + warn("semi-panic: attempt to dup freed string"); + return Nullstr; + } + if (old->str_state == SS_INCR && !(old->str_pok & 2)) + Str_Grow(old,0); + if (new->str_ptr) + Safefree(new->str_ptr); + StructCopy(old,new,STR); + if (old->str_ptr) { + new->str_ptr = nsavestr(old->str_ptr,old->str_len); + new->str_pok &= ~SP_TEMP; + } + return new; +} + +void +str_reset(s,stash) +register char *s; +HASH *stash; +{ + register HENT *entry; + register STAB *stab; + register STR *str; + register int i; + register SPAT *spat; + register int max; + + if (!*s) { /* reset ?? searches */ + for (spat = stash->tbl_spatroot; + spat != Nullspat; + spat = spat->spat_next) { + spat->spat_flags &= ~SPAT_USED; + } + return; + } + + /* reset variables */ + + if (!stash->tbl_array) + return; + while (*s) { + i = *s; + if (s[1] == '-') { + s += 2; + } + max = *s++; + for ( ; i <= max; i++) { + for (entry = stash->tbl_array[i]; + entry; + entry = entry->hent_next) { + stab = (STAB*)entry->hent_val; + str = stab_val(stab); + str->str_cur = 0; + str->str_nok = 0; +#ifdef TAINT + str->str_tainted = tainted; +#endif + if (str->str_ptr != Nullch) + str->str_ptr[0] = '\0'; + if (stab_xarray(stab)) { + aclear(stab_xarray(stab)); + } + if (stab_xhash(stab)) { + hclear(stab_xhash(stab), FALSE); + if (stab == envstab) + environ[0] = Nullch; + } + } + } + } +} + +#ifdef TAINT +void +taintproper(s) +char *s; +{ +#ifdef DEBUGGING + if (debug & 2048) + fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid); +#endif + if (tainted && (!euid || euid != uid || egid != gid || taintanyway)) { + if (!unsafe) + fatal("%s", s); + else if (dowarn) + warn("%s", s); + } +} + +void +taintenv() +{ + register STR *envstr; + + envstr = hfetch(stab_hash(envstab),"PATH",4,FALSE); + if (envstr == &str_undef || envstr->str_tainted) { + tainted = 1; + if (envstr->str_tainted == 2) + taintproper("Insecure directory in PATH"); + else + taintproper("Insecure PATH"); + } + envstr = hfetch(stab_hash(envstab),"IFS",3,FALSE); + if (envstr != &str_undef && envstr->str_tainted) { + tainted = 1; + taintproper("Insecure IFS"); + } +} +#endif /* TAINT */ diff --git a/gnu/usr.bin/perl/perl/str.h b/gnu/usr.bin/perl/perl/str.h new file mode 100644 index 0000000..7eb4b69 --- /dev/null +++ b/gnu/usr.bin/perl/perl/str.h @@ -0,0 +1,171 @@ +/* $RCSfile: str.h,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:29:39 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: str.h,v $ + * Revision 1.1.1.1 1993/08/23 21:29:39 nate + * PERL! + * + * Revision 4.0.1.4 92/06/08 15:41:45 lwall + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: removed implicit int declarations on functions + * + * Revision 4.0.1.3 91/11/05 18:41:47 lwall + * patch11: random cleanup + * patch11: solitary subroutine references no longer trigger typo warnings + * + * Revision 4.0.1.2 91/06/07 11:58:33 lwall + * patch4: new copyright notice + * + * Revision 4.0.1.1 91/04/12 09:16:12 lwall + * patch1: you may now use "die" and "caller" in a signal handler + * + * Revision 4.0 91/03/20 01:40:04 lwall + * 4.0 baseline. + * + */ + +struct string { + char * str_ptr; /* pointer to malloced string */ + STRLEN str_len; /* allocated size */ + union { + double str_nval; /* numeric value, if any */ + long str_useful; /* is this search optimization effective? */ + ARG *str_args; /* list of args for interpreted string */ + HASH *str_hash; /* string represents an assoc array (stab?) */ + ARRAY *str_array; /* string represents an array */ + CMD *str_cmd; /* command for this source line */ + struct { + STAB *stb_stab; /* magic stab for magic "key" string */ + HASH *stb_stash; /* which symbol table this stab is in */ + } stb_u; + } str_u; + STRLEN str_cur; /* length of str_ptr as a C string */ + STR *str_magic; /* while free, link to next free str */ + /* while in use, ptr to "key" for magic items */ + unsigned char str_pok; /* state of str_ptr */ + unsigned char str_nok; /* state of str_nval */ + unsigned char str_rare; /* used by search strings */ + unsigned char str_state; /* one of SS_* below */ + /* also used by search strings for backoff */ +#ifdef TAINT + bool str_tainted; /* 1 if possibly under control of $< */ +#endif +}; + +struct stab { /* should be identical, except for str_ptr */ + STBP * str_ptr; /* pointer to malloced string */ + STRLEN str_len; /* allocated size */ + union { + double str_nval; /* numeric value, if any */ + long str_useful; /* is this search optimization effective? */ + ARG *str_args; /* list of args for interpreted string */ + HASH *str_hash; /* string represents an assoc array (stab?) */ + ARRAY *str_array; /* string represents an array */ + CMD *str_cmd; /* command for this source line */ + struct { + STAB *stb_stab; /* magic stab for magic "key" string */ + HASH *stb_stash; /* which symbol table this stab is in */ + } stb_u; + } str_u; + STRLEN str_cur; /* length of str_ptr as a C string */ + STR *str_magic; /* while free, link to next free str */ + /* while in use, ptr to "key" for magic items */ + unsigned char str_pok; /* state of str_ptr */ + unsigned char str_nok; /* state of str_nval */ + unsigned char str_rare; /* used by search strings */ + unsigned char str_state; /* one of SS_* below */ + /* also used by search strings for backoff */ +#ifdef TAINT + bool str_tainted; /* 1 if possibly under control of $< */ +#endif +}; + +#define str_stab stb_u.stb_stab +#define str_stash stb_u.stb_stash + +/* some extra info tacked to some lvalue strings */ + +struct lstring { + struct string lstr; + STRLEN lstr_offset; + STRLEN lstr_len; +}; + +/* These are the values of str_pok: */ +#define SP_VALID 1 /* str_ptr is valid */ +#define SP_FBM 2 /* string was compiled for fbm search */ +#define SP_STUDIED 4 /* string was studied */ +#define SP_CASEFOLD 8 /* case insensitive fbm search */ +#define SP_INTRP 16 /* string was compiled for interping */ +#define SP_TAIL 32 /* fbm string is tail anchored: /foo$/ */ +#define SP_MULTI 64 /* symbol table entry probably isn't a typo */ +#define SP_TEMP 128 /* string slated to die, so can be plundered */ + +#define Nullstr Null(STR*) + +/* These are the values of str_state: */ +#define SS_NORM 0 /* normal string */ +#define SS_INCR 1 /* normal string, incremented ptr */ +#define SS_SARY 2 /* array on save stack */ +#define SS_SHASH 3 /* associative array on save stack */ +#define SS_SINT 4 /* integer on save stack */ +#define SS_SLONG 5 /* long on save stack */ +#define SS_SSTRP 6 /* STR* on save stack */ +#define SS_SHPTR 7 /* HASH* on save stack */ +#define SS_SNSTAB 8 /* non-stab on save stack */ +#define SS_SCSV 9 /* callsave structure on save stack */ +#define SS_SAPTR 10 /* ARRAY* on save stack */ +#define SS_HASH 253 /* carrying an hash */ +#define SS_ARY 254 /* carrying an array */ +#define SS_FREE 255 /* in free list */ +/* str_state may have any value 0-255 when used to hold fbm pattern, in which */ +/* case it indicates offset to rarest character in screaminstr key */ + +/* the following macro updates any magic values this str is associated with */ + +#ifdef TAINT +#define STABSET(x) \ + (x)->str_tainted |= tainted; \ + if ((x)->str_magic) \ + stabset((x)->str_magic,(x)) +#else +#define STABSET(x) \ + if ((x)->str_magic) \ + stabset((x)->str_magic,(x)) +#endif + +#define STR_SSET(dst,src) if (dst != src) str_sset(dst,src) + +EXT STR **tmps_list; +EXT int tmps_max INIT(-1); +EXT int tmps_base INIT(-1); + +char *str_2ptr(); +double str_2num(); +STR *str_mortal(); +STR *str_2mortal(); +STR *str_make(); +STR *str_nmake(); +STR *str_smake(); +int str_cmp(); +int str_eq(); +void str_magic(); +void str_insert(); +void str_numset(); +void str_sset(); +void str_nset(); +void str_set(); +void str_chop(); +void str_cat(); +void str_scat(); +void str_ncat(); +void str_reset(); +void str_taintproper(); +void str_taintenv(); +STRLEN str_len(); + +#define MULTI (3) diff --git a/gnu/usr.bin/perl/perl/t/README b/gnu/usr.bin/perl/perl/t/README new file mode 100644 index 0000000..47ab845 --- /dev/null +++ b/gnu/usr.bin/perl/perl/t/README @@ -0,0 +1,11 @@ +This is the perl test library. To run all the tests, just type 'TEST'. + +To add new tests, just look at the current tests and do likewise. + +If a test fails, run it by itself to see if it prints any informative +diagnostics. If not, modify the test to print informative diagnostics. +If you put out extra lines with a '#' character on the front, you don't +have to worry about removing the extra print statements later since TEST +ignores lines beginning with '#'. + +If you come up with new tests, send them to lwall@netlabs.com. diff --git a/gnu/usr.bin/perl/perl/t/TEST b/gnu/usr.bin/perl/perl/t/TEST new file mode 100755 index 0000000..957a868 --- /dev/null +++ b/gnu/usr.bin/perl/perl/t/TEST @@ -0,0 +1,102 @@ +#!./perl + +# $RCSfile: TEST,v $$Revision: 1.1.1.1 $$Date: 1993/08/23 21:30:01 $ + +# This is written in a peculiar style, since we're trying to avoid +# most of the constructs we'll be testing for. + +$| = 1; + +if ($ARGV[0] eq '-v') { + $verbose = 1; + shift; +} + +chdir 't' if -f 't/TEST'; + +if ($ARGV[0] eq '') { + @ARGV = split(/[ \n]/, + `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`); +} + +open(CONFIG,"../config.sh"); +while () { + if (/sharpbang='(.*)'/) { + $sharpbang = ($1 eq '#!'); + last; + } +} +$bad = 0; +while ($test = shift) { + if ($test =~ /^$/) { + next; + } + $te = $test; + chop($te); + print "$te" . '.' x (15 - length($te)); + if ($sharpbang) { + open(results,"./$test|") || (print "can't run.\n"); + } else { + open(script,"$test") || die "Can't run $test.\n"; + $_ =