Usenet 1994 October

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume18 / perl / part27 < prev next >

Wrap

Internet Message Format | 1991-04-17 | 49.4 KB

From: lwall@netlabs.com (Larry Wall) Newsgroups: comp.sources.misc Subject: v18i045: perl - The perl programming language, Part27/36 Message-ID: <1991Apr17.185752.2658@sparky.IMD.Sterling.COM> Date: 17 Apr 91 18:57:52 GMT Approved: kent@sparky.imd.sterling.com X-Checksum-Snefru: 443b1506 81bea342 fe4444fd 4c0c71ef Submitted-by: Larry Wall <lwall@netlabs.com> Posting-number: Volume 18, Issue 45 Archive-name: perl/part27 [There are 36 kits for perl version 4.0.] #! /bin/sh # Make a new directory for the perl sources, cd to it, and run kits 1 # thru 36 through sh. When all 36 kits have been run, read README. echo "This is perl 4.0 kit 27 (of 36). If kit 27 is complete, the line" echo '"'"End of kit 27 (of 36)"'" will echo at the end.' echo "" export PATH || (echo "You didn't use sh, you clunch." ; kill $$) mkdir emacs t t/op x2p 2>/dev/null echo Extracting MANIFEST sed >MANIFEST <<'!STUFFY!FUNK!' -e 's/X//' XConfigure Run this first XCopying The GNU General Public License XEXTERN.h Included before foreign .h files XINTERN.h Included before domestic .h files XMANIFEST This list of files XMakefile.SH Precursor to Makefile XPACKINGLIST Which files came from which kits XREADME The Instructions XREADME.uport Special instructions for Microports XREADME.xenix Special instructions for Xenix XWishlist Some things that may or may not happen Xarg.h Public declarations for the above Xarray.c Numerically subscripted arrays Xarray.h Public declarations for the above Xcflags.SH A script that emits C compilation flags per file Xclient A client to test sockets Xcmd.c Command interpreter Xcmd.h Public declarations for the above Xconfig.H Sample config.h Xconfig_h.SH Produces config.h Xcons.c Routines to construct cmd nodes of a parse tree Xconsarg.c Routines to construct arg nodes of a parse tree Xdoarg.c Scalar expression evaluation Xdoio.c I/O operations Xdolist.c Array expression evaluation Xdump.c Debugging output Xeg/ADB An adb wrapper to put in your crash dir Xeg/README Intro to example perl scripts Xeg/changes A program to list recently changed files Xeg/down A program to do things to subdirectories Xeg/dus A program to do du -s on non-mounted dirs Xeg/findcp A find wrapper that implements a -cp switch Xeg/findtar A find wrapper that pumps out a tar file Xeg/g/gcp A program to do a global rcp Xeg/g/gcp.man Manual page for gcp Xeg/g/ged A program to do a global edit Xeg/g/ghosts A sample /etc/ghosts file Xeg/g/gsh A program to do a global rsh Xeg/g/gsh.man Manual page for gsh Xeg/muck A program to find missing make dependencies Xeg/muck.man Manual page for muck Xeg/myrup A program to find lightly loaded machines Xeg/nih Script to insert #! workaround Xeg/relink A program to change symbolic links Xeg/rename A program to rename files Xeg/rmfrom A program to feed doomed filenames to Xeg/scan/scan_df Scan for filesystem anomalies Xeg/scan/scan_last Scan for login anomalies Xeg/scan/scan_messages Scan for console message anomalies Xeg/scan/scan_passwd Scan for passwd file anomalies Xeg/scan/scan_ps Scan for process anomalies Xeg/scan/scan_sudo Scan for sudo anomalies Xeg/scan/scan_suid Scan for setuid anomalies Xeg/scan/scanner An anomaly reporter Xeg/shmkill A program to remove unused shared memory Xeg/sysvipc/README Intro to Sys V IPC examples Xeg/sysvipc/ipcmsg Example of SYS V IPC message queues Xeg/sysvipc/ipcsem Example of Sys V IPC semaphores Xeg/sysvipc/ipcshm Example of Sys V IPC shared memory Xeg/travesty A program to print travesties of its input text Xeg/van/empty A program to empty the trashcan Xeg/van/unvanish A program to undo what vanish does Xeg/van/vanexp A program to expire vanished files Xeg/van/vanish A program to put files in a trashcan Xeg/who A sample who program Xemacs/perldb.pl Emacs debugging Xemacs/perldb.el Emacs debugging Xemacs/perl-mode.el Emacs major mode for perl Xemacs/tedstuff Some optional patches Xeval.c The expression evaluator Xform.c Format processing Xform.h Public declarations for the above Xgettest A little script to test the get* routines Xh2ph.SH A thing to turn C .h file into perl .ph files Xh2pl/README How to turn .ph files into .pl files Xh2pl/cbreak.pl cbreak routines using .ph Xh2pl/cbreak2.pl cbreak routines using .pl Xh2pl/eg/sizeof.ph Sample sizeof array initialization Xh2pl/eg/sys/errno.pl Sample translated errno.pl Xh2pl/eg/sys/ioctl.pl Sample translated ioctl.pl Xh2pl/eg/sysexits.pl Sample translated sysexits.pl Xh2pl/getioctlsizes Program to extract types from ioctl.h Xh2pl/mksizes Program to make %sizeof array. Xh2pl/mkvars Program to make .pl from .ph files Xh2pl/tcbreak cbreak test routine using .ph Xh2pl/tcbreak2 cbreak test routine using .pl Xhandy.h Handy definitions Xhash.c Associative arrays Xhash.h Public declarations for the above Xhints/3b2.sh Xhints/aix_rs.sh Xhints/aix_rt.sh Xhints/apollo_C6_7.sh Xhints/aux.sh Xhints/dnix.sh Xhints/dynix.sh Xhints/fps.sh Xhints/genix.sh Xhints/hp9000_300.sh Xhints/hp9000_400.sh Xhints/hpux.sh Xhints/i386.sh Xhints/mips.sh Xhints/ncr_tower.sh Xhints/next.sh Xhints/osf_1.sh Xhints/sco_2_3_0.sh Xhints/sco_2_3_1.sh Xhints/sco_2_3_2.sh Xhints/sco_2_3_3.sh Xhints/sco_3.sh Xhints/sgi.sh Xhints/sunos_3_4.sh Xhints/sunos_3_5.sh Xhints/sunos_4_0_1.sh Xhints/sunos_4_0_2.sh Xhints/ultrix_3.sh Xhints/ultrix_4.sh Xhints/uts.sh Xinstallperl Perl script to do "make install" dirty work Xioctl.pl Sample ioctl.pl Xlib/abbrev.pl An abbreviation table builder Xlib/bigfloat.pl An arbitrary precision floating point package Xlib/bigint.pl An arbitrary precision integer arithmetic package Xlib/bigrat.pl An arbitrary precision rational arithmetic package Xlib/cacheout.pl Manages output filehandles when you need too many Xlib/complete.pl A command completion subroutine Xlib/ctime.pl A ctime workalike Xlib/dumpvar.pl A variable dumper Xlib/flush.pl Routines to do single flush Xlib/getopt.pl Perl library supporting option parsing Xlib/getopts.pl Perl library supporting option parsing Xlib/importenv.pl Perl routine to get environment into variables Xlib/look.pl A "look" equivalent Xlib/perldb.pl Perl debugging routines Xlib/pwd.pl Routines to keep track of PWD environment variable Xlib/stat.pl Perl library supporting stat function Xlib/syslog.pl Perl library supporting syslogging Xlib/termcap.pl Perl library supporting termcap usage Xlib/timelocal.pl Perl library supporting inverse of localtime, gmtime Xlib/validate.pl Perl library supporting wholesale file mode validation Xmakedepend.SH Precursor to makedepend Xmakedir.SH Precursor to makedir Xmalloc.c A version of malloc you might not want Xmsdos/Changes.dds Expanation of MS-DOS patches by Diomidis Spinellis Xmsdos/Makefile MS-DOS makefile Xmsdos/README.msdos Compiling and usage information Xmsdos/Wishlist.dds My wishlist Xmsdos/config.h Definitions for msdos Xmsdos/chdir.c A chdir that can change drives Xmsdos/dir.h MS-DOS header for directory access functions Xmsdos/directory.c MS-DOS directory access functions. Xmsdos/eg/crlf.bat Convert files from unix to MS-DOS line termination Xmsdos/eg/drives.bat List the system drives and their characteristics Xmsdos/eg/lf.bat Convert files from MS-DOS to Unix line termination Xmsdos/glob.c A command equivalent to csh glob Xmsdos/msdos.c MS-DOS ioctl, sleep, gete?[gu]if, spawn, aspawn Xmsdos/popen.c My_popen and my_pclose for MS-DOS Xmsdos/usage.c How to invoke perl under MS-DOS Xos2/Makefile Makefile for OS/2 Xos2/README.OS2 Notes for OS/2 Xos2/a2p.cs Compiler script for a2p Xos2/a2p.def Linker defs for a2p Xos2/alarm.c An implementation of alarm() Xos2/alarm.h Header file for same Xos2/config.h Configuration file for OS/2 Xos2/dir.h Directory header Xos2/director.c Directory routines Xos2/eg/alarm.pl Example of alarm code Xos2/eg/os2.pl Sample script for OS/2 Xos2/eg/syscalls.pl Example of syscall on OS/2 Xos2/glob.c Globbing routines Xos2/makefile Make file Xos2/mktemp.c Mktemp() using TMP Xos2/os2.c Unix compatibility functions Xos2/perl.bad names of protect-only API calls for BIND Xos2/perl.cs Compiler script for perl Xos2/perl.def Linker defs for perl Xos2/perldb.dif Changes to make the debugger work Xos2/perlglob.bad names of protect-only API calls for BIND Xos2/perlglob.cs Compiler script for perlglob Xos2/perlglob.def Linker defs for perlglob Xos2/perlsh.cmd Poor man's shell for os2 Xos2/popen.c Code for opening pipes Xos2/s2p.cmd s2p as command file Xos2/selfrun.bat A self running perl script for DOS Xos2/selfrun.cmd Example of extproc feature Xos2/suffix.c Code for creating backup filenames Xpatchlevel.h The current patch level of perl Xperl.c main() Xperl.h Global declarations Xperl.man The manual page(s) Xperlsh A poor man's perl shell Xperly.y Yacc grammar for perl Xperly.fixer A program to remove yacc stack limitations Xregcomp.c Regular expression compiler Xregcomp.h Private declarations for above Xregexec.c Regular expression evaluator Xregexp.h Public declarations for the above Xserver A server to test sockets Xspat.h Search pattern declarations Xstab.c Symbol table stuff Xstab.h Public declarations for the above Xstr.c String handling package Xstr.h Public declarations for the above Xt/README Instructions for regression tests Xt/TEST The regression tester Xt/base/cond.t See if conditionals work Xt/base/if.t See if if works Xt/base/lex.t See if lexical items work Xt/base/pat.t See if pattern matching works Xt/base/term.t See if various terms work Xt/cmd/elsif.t See if else-if works Xt/cmd/for.t See if for loops work Xt/cmd/mod.t See if statement modifiers work Xt/cmd/subval.t See if subroutine values work Xt/cmd/switch.t See if switch optimizations work Xt/cmd/while.t See if while loops work Xt/comp/cmdopt.t See if command optimization works Xt/comp/cpp.t See if C preprocessor works Xt/comp/decl.t See if declarations work Xt/comp/multiline.t See if multiline strings work Xt/comp/package.t See if packages work Xt/comp/script.t See if script invokation works Xt/comp/term.t See if more terms work Xt/io/argv.t See if ARGV stuff works Xt/io/dup.t See if >& works right Xt/io/fs.t See if directory manipulations work Xt/io/inplace.t See if inplace editing works Xt/io/pipe.t See if secure pipes work Xt/io/print.t See if print commands work Xt/io/tell.t See if file seeking works Xt/lib/big.t See if lib/bigint.pl works Xt/op/append.t See if . works Xt/op/array.t See if array operations work Xt/op/auto.t See if autoincrement et all work Xt/op/chop.t See if chop works Xt/op/cond.t See if conditional expressions work Xt/op/dbm.t See if dbm binding works Xt/op/delete.t See if delete works Xt/op/do.t See if subroutines work Xt/op/each.t See if associative iterators work Xt/op/eval.t See if eval operator works Xt/op/exec.t See if exec and system work Xt/op/exp.t See if math functions work Xt/op/flip.t See if range operator works Xt/op/fork.t See if fork works Xt/op/glob.t See if <*> works Xt/op/goto.t See if goto works Xt/op/groups.t See if $( works Xt/op/index.t See if index works Xt/op/int.t See if int works Xt/op/join.t See if join works Xt/op/list.t See if array lists work Xt/op/local.t See if local works Xt/op/magic.t See if magic variables work Xt/op/mkdir.t See if mkdir works Xt/op/oct.t See if oct and hex work Xt/op/ord.t See if ord works Xt/op/pack.t See if pack and unpack work Xt/op/pat.t See if esoteric patterns work Xt/op/push.t See if push and pop work Xt/op/range.t See if .. works Xt/op/read.t See if read() works Xt/op/regexp.t See if regular expressions work Xt/op/repeat.t See if x operator works Xt/op/s.t See if substitutions work Xt/op/sleep.t See if sleep works Xt/op/sort.t See if sort works Xt/op/split.t See if split works Xt/op/sprintf.t See if sprintf works Xt/op/stat.t See if stat works Xt/op/study.t See if study works Xt/op/substr.t See if substr works Xt/op/time.t See if time functions work Xt/op/undef.t See if undef works Xt/op/unshift.t See if unshift works Xt/op/vec.t See if vectors work Xt/op/write.t See if write works Xt/op/re_tests Input file for op.regexp Xtoke.c The tokener Xusersub.c User supplied (possibly proprietary) subroutines Xusub/README Instructions for user supplied subroutines Xusub/Makefile Makefile for curseperl Xusub/curses.mus Glue routines for BSD curses Xusub/man2mus A manual page to .mus translator Xusub/mus A .mus to .c translator Xusub/pager A sample pager in curseperl Xusub/usersub.c An initialization file to call curses glue routines Xutil.c Utility routines Xutil.h Public declarations for the above Xx2p/EXTERN.h Same as above Xx2p/INTERN.h Same as above Xx2p/Makefile.SH Precursor to Makefile Xx2p/a2p.h Global declarations Xx2p/a2p.man Manual page for awk to perl translator Xx2p/a2p.y A yacc grammer for awk Xx2p/a2py.c Awk compiler, sort of Xx2p/find2perl.SH A find to perl translator Xx2p/handy.h Handy definitions Xx2p/hash.c Associative arrays again Xx2p/hash.h Public declarations for the above Xx2p/s2p.SH Sed to perl translator Xx2p/s2p.man Manual page for sed to perl translator Xx2p/str.c String handling package Xx2p/str.h Public declarations for the above Xx2p/util.c Utility routines Xx2p/util.h Public declarations for the above Xx2p/walk.c Parse tree walker !STUFFY!FUNK! echo Extracting emacs/tedstuff sed >emacs/tedstuff <<'!STUFFY!FUNK!' -e 's/X//' XArticle 4417 of comp.lang.perl: XPath: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf XFrom: ted@evi.com (Ted Stefanik) XNewsgroups: comp.lang.perl XSubject: Correction to Perl fatal error marking in GNU Emacs XMessage-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU> XDate: 27 Feb 91 06:58:53 GMT XSender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System) XReply-To: ted@evi.com (Ted Stefanik) XOrganization: The Internet XLines: 282 X XReading my own message, it occurred to me that I didn't quite satisfy the Xrequest of stef@zweig.sun (Stephane Payrard): X X| Does anyone has extended perdb/perdb.el to position the X| point to the first syntax error? It would be cool. X XWhat I posted is a way to use the "M-x compile" command to test perl scripts. X(Needless to say, the script cannot be not interactive; you can't provide input Xto a *compilation* buffer). When creating new Perl programs, I use "M-x Xcompile" until I'm sure that they are syntatically correct; if syntax errors Xoccur, C-x` takes me to each in sequence. After I'm sure the syntax is Xcorrect, I start worrying about semantics, and switch to "M-x perldb" if Xnecessary. X XTherefore, the stuff I posted works great with "M-x compile", but not at all Xwith "M-x perldb". X XNext, let me update what I posted. I found that perl's die() command doesn't Xprint the same format error message as perl does when it dies with a syntax Xerror. If you put the following in your ".emacs" file, it causes C-x` to Xrecognize both kinds of errors: X X(load-library "compile") X(setq compilation-error-regexp X "\$[^ :\n]+\\(: *\\|, line \\|(\$[0-9]+\\)\\|\$[0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \$*line [0-9]+\\)") X XLast, so I don't look like a total fool, let me propose a way to satisfy XStephane Payrard's original request (repeated again): X X| Does anyone has extended perdb/perdb.el to position the X| point to the first syntax error? It would be cool. X XI'm not satisfied with just the "first syntax error". Perl's parser is better Xthan most about not getting out of sync; therefore, if it reports multiple Xerrors, you can usually be assured they are all real errors. X XSo... I hacked in the "next-error" function from "compile.el" to form X"perldb-next-error". You can apply the patches at the end of this message Xto add "perldb-next-error" to your "perldb.el". X XNotes: X 1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift X of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS). X X 2) "next-error" is meant to work on a single *compilation* buffer; any new X "M-x compile" or "M-x grep" command will clear the old *compilation* X buffer and reset the compilation-error parser to start at the top of the X *compilation* buffer. X X "perldb-next-error", on the other hand, has to deal with multiple X *perldb-<foo>* buffers, each of which keep growing. "perldb-next-error" X correctly handles the constantly growing *perldb-<foo>* buffers by X keeping track of the last reported error in the "current-perldb-buffer". X X Sadly however, when you invoke a new "M-x perldb" on a different Perl X script, "perldb-next-error" will start parsing the new *perldb-<bar>* X buffer at the top (even if it was previously parsed), and will completely X lose the marker of the last reported error in *perldb-<foo>*. X X 3) "perldb-next-error" still uses "compilation-error-regexp" to find X fatal errors. Therefore, both the "M-x compile"/C-x` scheme and X the "M-x perldb"/C-x~ scheme can be used to find fatal errors that X match the common "compilation-error-regexp". You *will* want to install X that "compilation-error-regexp" stuff into your .emacs file. X X 4) The patch was developed and tested with GNU Emacs 18.55. X X 5) Since the patch was ripped off from compile.el, the code is (of X course) subject to the GNU copyleft. X X*** perldb.el.orig Wed Feb 27 00:44:27 1991 X--- perldb.el Wed Feb 27 00:44:30 1991 X*************** X*** 199,205 **** X X (defun perldb-set-buffer () X (cond ((eq major-mode 'perldb-mode) X! (setq current-perldb-buffer (current-buffer))))) X X ;; This function is responsible for inserting output from Perl X ;; into the buffer. X--- 199,211 ---- X X (defun perldb-set-buffer () X (cond ((eq major-mode 'perldb-mode) X! (cond ((not (eq current-perldb-buffer (current-buffer))) X! (perldb-forget-errors) X! (setq perldb-parsing-end 2)) ;; 2 to defeat grep defeater X! (t X! (if (> perldb-parsing-end (point-max)) X! (setq perldb-parsing-end (max (point-max) 2))))) X! (setq current-perldb-buffer (current-buffer))))) X X ;; This function is responsible for inserting output from Perl X ;; into the buffer. X*************** X*** 291,297 **** X ;; process-buffer is current-buffer X (unwind-protect X (progn X! ;; Write something in *compilation* and hack its mode line, X (set-buffer (process-buffer proc)) X ;; Force mode line redisplay soon X (set-buffer-modified-p (buffer-modified-p)) X--- 297,303 ---- X ;; process-buffer is current-buffer X (unwind-protect X (progn X! ;; Write something in *perldb-<foo>* and hack its mode line, X (set-buffer (process-buffer proc)) X ;; Force mode line redisplay soon X (set-buffer-modified-p (buffer-modified-p)) X*************** X*** 421,423 **** X--- 427,593 ---- X (switch-to-buffer-other-window current-perldb-buffer) X (goto-char (dot-max)) X (insert-string comm))) X+ X+ (defvar perldb-error-list nil X+ "List of error message descriptors for visiting erring functions. X+ Each error descriptor is a list of length two. X+ Its car is a marker pointing to an error message. X+ Its cadr is a marker pointing to the text of the line the message is about, X+ or nil if that is not interesting. X+ The value may be t instead of a list; X+ this means that the buffer of error messages should be reparsed X+ the next time the list of errors is wanted.") X+ X+ (defvar perldb-parsing-end nil X+ "Position of end of buffer when last error messages parsed.") X+ X+ (defvar perldb-error-message "No more fatal Perl errors" X+ "Message to print when no more matches for compilation-error-regexp are found") X+ X+ (defun perldb-next-error (&optional argp) X+ "Visit next perldb error message and corresponding source code. X+ This operates on the output from the \\[perldb] command. X+ If all preparsed error messages have been processed, X+ the error message buffer is checked for new ones. X+ A non-nil argument (prefix arg, if interactive) X+ means reparse the error message buffer and start at the first error." X+ (interactive "P") X+ (if (or (eq perldb-error-list t) X+ argp) X+ (progn (perldb-forget-errors) X+ (setq perldb-parsing-end 2))) ;; 2 to defeat grep defeater X+ (if perldb-error-list X+ nil X+ (save-excursion X+ (switch-to-buffer current-perldb-buffer) X+ (perldb-parse-errors))) X+ (let ((next-error (car perldb-error-list))) X+ (if (null next-error) X+ (error (concat perldb-error-message X+ (if (and (get-buffer-process current-perldb-buffer) X+ (eq (process-status X+ (get-buffer-process X+ current-perldb-buffer)) X+ 'run)) X+ " yet" "")))) X+ (setq perldb-error-list (cdr perldb-error-list)) X+ (if (null (car (cdr next-error))) X+ nil X+ (switch-to-buffer (marker-buffer (car (cdr next-error)))) X+ (goto-char (car (cdr next-error))) X+ (set-marker (car (cdr next-error)) nil)) X+ (let* ((pop-up-windows t) X+ (w (display-buffer (marker-buffer (car next-error))))) X+ (set-window-point w (car next-error)) X+ (set-window-start w (car next-error))) X+ (set-marker (car next-error) nil))) X+ X+ ;; Set perldb-error-list to nil, and X+ ;; unchain the markers that point to the error messages and their text, X+ ;; so that they no longer slow down gap motion. X+ ;; This would happen anyway at the next garbage collection, X+ ;; but it is better to do it right away. X+ (defun perldb-forget-errors () X+ (if (eq perldb-error-list t) X+ (setq perldb-error-list nil)) X+ (while perldb-error-list X+ (let ((next-error (car perldb-error-list))) X+ (set-marker (car next-error) nil) X+ (if (car (cdr next-error)) X+ (set-marker (car (cdr next-error)) nil))) X+ (setq perldb-error-list (cdr perldb-error-list)))) X+ X+ (defun perldb-parse-errors () X+ "Parse the current buffer as error messages. X+ This makes a list of error descriptors, perldb-error-list. X+ For each source-file, line-number pair in the buffer, X+ the source file is read in, and the text location is saved in perldb-error-list. X+ The function next-error, assigned to \\[next-error], takes the next error off the list X+ and visits its location." X+ (setq perldb-error-list nil) X+ (message "Parsing error messages...") X+ (let (text-buffer X+ last-filename last-linenum) X+ ;; Don't reparse messages already seen at last parse. X+ (goto-char perldb-parsing-end) X+ ;; Don't parse the first two lines as error messages. X+ ;; This matters for grep. X+ (if (bobp) X+ (forward-line 2)) X+ (while (re-search-forward compilation-error-regexp nil t) X+ (let (linenum filename X+ error-marker text-marker) X+ ;; Extract file name and line number from error message. X+ (save-restriction X+ (narrow-to-region (match-beginning 0) (match-end 0)) X+ (goto-char (point-max)) X+ (skip-chars-backward "[0-9]") X+ ;; If it's a lint message, use the last file(linenum) on the line. X+ ;; Normally we use the first on the line. X+ (if (= (preceding-char) ?\() X+ (progn X+ (narrow-to-region (point-min) (1+ (buffer-size))) X+ (end-of-line) X+ (re-search-backward compilation-error-regexp) X+ (skip-chars-backward "^ \t\n") X+ (narrow-to-region (point) (match-end 0)) X+ (goto-char (point-max)) X+ (skip-chars-backward "[0-9]"))) X+ ;; Are we looking at a "filename-first" or "line-number-first" form? X+ (if (looking-at "[0-9]") X+ (progn X+ (setq linenum (read (current-buffer))) X+ (goto-char (point-min))) X+ ;; Line number at start, file name at end. X+ (progn X+ (goto-char (point-min)) X+ (setq linenum (read (current-buffer))) X+ (goto-char (point-max)) X+ (skip-chars-backward "^ \t\n"))) X+ (setq filename (perldb-grab-filename))) X+ ;; Locate the erring file and line. X+ (if (and (equal filename last-filename) X+ (= linenum last-linenum)) X+ nil X+ (beginning-of-line 1) X+ (setq error-marker (point-marker)) X+ ;; text-buffer gets the buffer containing this error's file. X+ (if (not (equal filename last-filename)) X+ (setq text-buffer X+ (and (file-exists-p (setq last-filename filename)) X+ (find-file-noselect filename)) X+ last-linenum 0)) X+ (if text-buffer X+ ;; Go to that buffer and find the erring line. X+ (save-excursion X+ (set-buffer text-buffer) X+ (if (zerop last-linenum) X+ (progn X+ (goto-char 1) X+ (setq last-linenum 1))) X+ (forward-line (- linenum last-linenum)) X+ (setq last-linenum linenum) X+ (setq text-marker (point-marker)) X+ (setq perldb-error-list X+ (cons (list error-marker text-marker) X+ perldb-error-list))))) X+ (forward-line 1))) X+ (setq perldb-parsing-end (point-max))) X+ (message "Parsing error messages...done") X+ (setq perldb-error-list (nreverse perldb-error-list))) X+ X+ (defun perldb-grab-filename () X+ "Return a string which is a filename, starting at point. X+ Ignore quotes and parentheses around it, as well as trailing colons." X+ (if (eq (following-char) ?\") X+ (save-restriction X+ (narrow-to-region (point) X+ (progn (forward-sexp 1) (point))) X+ (goto-char (point-min)) X+ (read (current-buffer))) X+ (buffer-substring (point) X+ (progn X+ (skip-chars-forward "^ :,\n\t(") X+ (point))))) X+ X+ (define-key ctl-x-map "~" 'perldb-next-error) X X !STUFFY!FUNK! echo Extracting x2p/s2p.SH sed >x2p/s2p.SH <<'!STUFFY!FUNK!' -e 's/X//' X: This forces SH files to create target in same directory as SH file. X: This is so that make depend always knows where to find SH derivatives. Xcase "$0" in X*/*) cd `expr X$0 : 'X$.*$/'` ;; Xesac Xcase $CONFIG in X'') X if test ! -f config.sh; then X ln ../config.sh . || \ X ln -s ../config.sh . || \ X ln ../../config.sh . || \ X ln ../../../config.sh . || \ X (echo "Can't find config.sh."; exit 1) X fi 2>/dev/null X . ./config.sh X ;; Xesac Xecho "Extracting s2p (with variable substitutions)" X: This section of the file will have variable substitutions done on it. X: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!. X: Protect any dollar signs and backticks that you do not want interpreted X: by putting a backslash in front. You may delete these comments. X$spitshell >s2p <<!GROK!THIS! X#!$bin/perl X X\$bin = '$bin'; X!GROK!THIS! X X: In the following dollars and backticks do not need the extra backslash. X$spitshell >>s2p <<'!NO!SUBS!' X X# $Header: s2p.SH,v 4.0 91/03/20 01:57:59 lwall Locked $ X# X# $Log: s2p.SH,v $ X# Revision 4.0 91/03/20 01:57:59 lwall X# 4.0 baseline. X# X# X X$indent = 4; X$shiftwidth = 4; X$l = '{'; $r = '}'; X Xwhile ($ARGV[0] =~ /^-/) { X $_ = shift; X last if /^--/; X if (/^-D/) { X $debug++; X open(BODY,'>-'); X next; X } X if (/^-n/) { X $assumen++; X next; X } X if (/^-p/) { X $assumep++; X next; X } X die "I don't recognize this switch: $_\n"; X} X Xunless ($debug) { X open(BODY,">/tmp/sperl$$") || X &Die("Can't open temp file: $!\n"); X} X Xif (!$assumen && !$assumep) { X print BODY <<'EOT'; Xwhile ($ARGV[0] =~ /^-/) { X $_ = shift; X last if /^--/; X if (/^-n/) { X $nflag++; X next; X } X die "I don't recognize this switch: $_\\n"; X} X XEOT X} X Xprint BODY <<'EOT'; X X#ifdef PRINTIT X#ifdef ASSUMEP X$printit++; X#else X$printit++ unless $nflag; X#endif X#endif XLINE: while (<>) { XEOT X XLINE: while (<>) { X X # Wipe out surrounding whitespace. X X s/[ \t]*(.*)\n$/$1/; X X # Perhaps it's a label/comment. X X if (/^:/) { X s/^:[ \t]*//; X $label = &make_label($_); X if ($. == 1) { X $toplabel = $label; X } X $_ = "$label:"; X if ($lastlinewaslabel++) { X $indent += 4; X print BODY &tab, ";\n"; X $indent -= 4; X } X if ($indent >= 2) { X $indent -= 2; X $indmod = 2; X } X next; X } else { X $lastlinewaslabel = ''; X } X X # Look for one or two address clauses X X $addr1 = ''; X $addr2 = ''; X if (s/^([0-9]+)//) { X $addr1 = "$1"; X } X elsif (s/^\$//) { X $addr1 = 'eof()'; X } X elsif (s|^/||) { X $addr1 = &fetchpat('/'); X } X if (s/^,//) { X if (s/^([0-9]+)//) { X $addr2 = "$1"; X } elsif (s/^\$//) { X $addr2 = "eof()"; X } elsif (s|^/||) { X $addr2 = &fetchpat('/'); X } else { X &Die("Invalid second address at line $.\n"); X } X $addr1 .= " .. $addr2"; X } X X # Now we check for metacommands {, }, and ! and worry X # about indentation. X X s/^[ \t]+//; X # a { to keep vi happy X if ($_ eq '}') { X $indent -= 4; X next; X } X if (s/^!//) { X $if = 'unless'; X $else = "$r else $l\n"; X } else { X $if = 'if'; X $else = ''; X } X if (s/^{//) { # a } to keep vi happy X $indmod = 4; X $redo = $_; X $_ = ''; X $rmaybe = ''; X } else { X $rmaybe = "\n$r"; X if ($addr2 || $addr1) { X $space = ' ' x $shiftwidth; X } else { X $space = ''; X } X $_ = &transmogrify(); X } X X # See if we can optimize to modifier form. X X if ($addr1) { X if ($_ !~ /[\n{}]/ && $rmaybe && !$change && X $_ !~ / if / && $_ !~ / unless /) { X s/;$/ $if $addr1;/; X $_ = substr($_,$shiftwidth,1000); X } else { X $_ = "$if ($addr1) $l\n$change$_$rmaybe"; X } X $change = ''; X next LINE; X } X} continue { X @lines = split(/\n/,$_); X for (@lines) { X unless (s/^ *<<--//) { X print BODY &tab; X } X print BODY $_, "\n"; X } X $indent += $indmod; X $indmod = 0; X if ($redo) { X $_ = $redo; X $redo = ''; X redo LINE; X } X} Xif ($lastlinewaslabel++) { X $indent += 4; X print BODY &tab, ";\n"; X $indent -= 4; X} X Xprint BODY "}\n"; Xif ($appendseen || $tseen || !$assumen) { X $printit++ if $dseen || (!$assumen && !$assumep); X print BODY <<'EOT'; X Xcontinue { X#ifdef PRINTIT X#ifdef DSEEN X#ifdef ASSUMEP X print if $printit++; X#else X if ($printit) X { print; } X else X { $printit++ unless $nflag; } X#endif X#else X print if $printit; X#endif X#else X print; X#endif X#ifdef TSEEN X $tflag = ''; X#endif X#ifdef APPENDSEEN X if ($atext) { print $atext; $atext = ''; } X#endif X} XEOT X} X Xclose BODY; X Xunless ($debug) { X open(HEAD,">/tmp/sperl2$$.c") X || &Die("Can't open temp file 2: $!\n"); X print HEAD "#define PRINTIT\n" if ($printit); X print HEAD "#define APPENDSEEN\n" if ($appendseen); X print HEAD "#define TSEEN\n" if ($tseen); X print HEAD "#define DSEEN\n" if ($dseen); X print HEAD "#define ASSUMEN\n" if ($assumen); X print HEAD "#define ASSUMEP\n" if ($assumep); X if ($opens) {print HEAD "$opens\n";} X open(BODY,"/tmp/sperl$$") X || &Die("Can't reopen temp file: $!\n"); X while (<BODY>) { X print HEAD $_; X } X close HEAD; X X print <<"EOT"; X#!$bin/perl Xeval 'exec $bin/perl -S \$0 \$*' X if \$running_under_some_shell; X XEOT X open(BODY,"cc -E /tmp/sperl2$$.c |") || X &Die("Can't reopen temp file: $!\n"); X while (<BODY>) { X /^# [0-9]/ && next; X /^[ \t]*$/ && next; X s/^<><>//; X print; X } X} X X&Cleanup; Xexit; X Xsub Cleanup { X chdir "/tmp"; X unlink "sperl$$", "sperl2$$", "sperl2$$.c"; X} Xsub Die { X &Cleanup; X die $_[0]; X} Xsub tab { X "\t" x ($indent / 8) . ' ' x ($indent % 8); X} Xsub make_filehandle { X local($_) = $_[0]; X local($fname) = $_; X s/[^a-zA-Z]/_/g; X s/^_*//; X substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/; X if (!$seen{$_}) { X $opens .= <<"EOT"; Xopen($_,'>$fname') || die "Can't create $fname"; XEOT X } X $seen{$_} = $_; X} X Xsub make_label { X local($label) = @_; X $label =~ s/[^a-zA-Z0-9]/_/g; X if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } X $label = substr($label,0,8); X X # Could be a reserved word, so capitalize it. X substr($label,0,1) =~ y/a-z/A-Z/ X if $label =~ /^[a-z]/; X X $label; X} X Xsub transmogrify { X { # case X if (/^d/) { X $dseen++; X chop($_ = <<'EOT'); X<<--#ifdef PRINTIT X$printit = ''; X<<--#endif Xnext LINE; XEOT X next; X } X X if (/^n/) { X chop($_ = <<'EOT'); X<<--#ifdef PRINTIT X<<--#ifdef DSEEN X<<--#ifdef ASSUMEP Xprint if $printit++; X<<--#else Xif ($printit) X { print; } Xelse X { $printit++ unless $nflag; } X<<--#endif X<<--#else Xprint if $printit; X<<--#endif X<<--#else Xprint; X<<--#endif X<<--#ifdef APPENDSEEN Xif ($atext) {print $atext; $atext = '';} X<<--#endif X$_ = <>; X<<--#ifdef TSEEN X$tflag = ''; X<<--#endif XEOT X next; X } X X if (/^a/) { X $appendseen++; X $command = $space . '$atext .=' . "\n<<--'"; X $lastline = 0; X while (<>) { X s/^[ \t]*//; X s/^[\\]//; X unless (s|\\$||) { $lastline = 1;} X s/'/\\'/g; X s/^([ \t]*\n)/<><>$1/; X $command .= $_; X $command .= '<<--'; X last if $lastline; X } X $_ = $command . "';"; X last; X } X X if (/^[ic]/) { X if (/^c/) { $change = 1; } X $addr1 = '$iter = (' . $addr1 . ')'; X $command = $space . 'if ($iter == 1) { print' X . "\n<<--'"; X $lastline = 0; X while (<>) { X s/^[ \t]*//; X s/^[\\]//; X unless (s/\\$//) { $lastline = 1;} X s/'/\\'/g; X s/^([ \t]*\n)/<><>$1/; X $command .= $_; X $command .= '<<--'; X last if $lastline; X } X $_ = $command . "';}"; X if ($change) { X $dseen++; X $change = "$_\n"; X chop($_ = <<"EOT"); X<<--#ifdef PRINTIT X$space\$printit = ''; X<<--#endif X${space}next LINE; XEOT X } X last; X } X X if (/^s/) { X $delim = substr($_,1,1); X $len = length($_); X $repl = $end = 0; X $inbracket = 0; X for ($i = 2; $i < $len; $i++) { X $c = substr($_,$i,1); X if ($c eq $delim) { X if ($inbracket) { X substr($_, $i, 0) = '\\'; X $i++; X $len++; X } X else { X if ($repl) { X $end = $i; X last; X } else { X $repl = $i; X } X } X } X elsif ($c eq '\\') { X $i++; X if ($i >= $len) { X $_ .= 'n'; X $_ .= <>; X $len = length($_); X $_ = substr($_,0,--$len); X } X elsif (substr($_,$i,1) =~ /^[n]$/) { X ; X } X elsif (!$repl && X substr($_,$i,1) =~ /^[(){}\w]$/) { X $i--; X $len--; X substr($_, $i, 1) = ''; X } X elsif (!$repl && X substr($_,$i,1) =~ /^[<>]$/) { X substr($_,$i,1) = 'b'; X } X } X elsif ($c eq '[' && !$repl) { X $i++ if substr($_,$i,1) eq '^'; X $i++ if substr($_,$i,1) eq ']'; X $inbracket = 1; X } X elsif ($c eq ']') { X $inbracket = 0; X } X elsif (!$repl && index("()+",$c) >= 0) { X substr($_, $i, 0) = '\\'; X $i++; X $len++; X } X } X &Die("Malformed substitution at line $.\n") X unless $end; X $pat = substr($_, 0, $repl + 1); X $repl = substr($_, $repl+1, $end-$repl-1); X $end = substr($_, $end + 1, 1000); X $dol = '$'; X $repl =~ s/\$/\\$/; X $repl =~ s'&'$&'g; X $repl =~ s/[\\]([0-9])/$dol$1/g; X $subst = "$pat$repl$delim"; X $cmd = ''; X while ($end) { X if ($end =~ s/^g//) { X $subst .= 'g'; X next; X } X if ($end =~ s/^p//) { X $cmd .= ' && (print)'; X next; X } X if ($end =~ s/^w[ \t]*//) { X $fh = &make_filehandle($end); X $cmd .= " && (print $fh \$_)"; X $end = ''; X next; X } X &Die("Unrecognized substitution command". X "($end) at line $.\n"); X } X chop ($_ = <<"EOT"); X<<--#ifdef TSEEN X$subst && \$tflag++$cmd; X<<--#else X$subst$cmd; X<<--#endif XEOT X next; X } X X if (/^p/) { X $_ = 'print;'; X next; X } X X if (/^w/) { X s/^w[ \t]*//; X $fh = &make_filehandle($_); X $_ = "print $fh \$_;"; X next; X } X X if (/^r/) { X $appendseen++; X s/^r[ \t]*//; X $file = $_; X $_ = "\$atext .= `cat $file 2>/dev/null`;"; X next; X } X X if (/^P/) { X $_ = 'print $1 if /(^.*\n)/;'; X next; X } X X if (/^D/) { X chop($_ = <<'EOT'); Xs/^.*\n//; Xredo LINE if $_; Xnext LINE; XEOT X next; X } X X if (/^N/) { X chop($_ = <<'EOT'); X$_ .= <>; X<<--#ifdef TSEEN X$tflag = ''; X<<--#endif XEOT X next; X } X X if (/^h/) { X $_ = '$hold = $_;'; X next; X } X X if (/^H/) { X $_ = '$hold .= $_ ? $_ : "\n";'; X next; X } X X if (/^g/) { X $_ = '$_ = $hold;'; X next; X } X X if (/^G/) { X $_ = '$_ .= $hold ? $hold : "\n";'; X next; X } X X if (/^x/) { X $_ = '($_, $hold) = ($hold, $_);'; X next; X } X X if (/^b$/) { X $_ = 'next LINE;'; X next; X } X X if (/^b/) { X s/^b[ \t]*//; X $lab = &make_label($_); X if ($lab eq $toplabel) { X $_ = 'redo LINE;'; X } else { X $_ = "goto $lab;"; X } X next; X } X X if (/^t$/) { X $_ = 'next LINE if $tflag;'; X $tseen++; X next; X } X X if (/^t/) { X s/^t[ \t]*//; X $lab = &make_label($_); X $_ = q/if ($tflag) {$tflag = ''; /; X if ($lab eq $toplabel) { X $_ .= 'redo LINE;}'; X } else { X $_ .= "goto $lab;}"; X } X $tseen++; X next; X } X X if (/^=/) { X $_ = 'print "$.\n";'; X next; X } X X if (/^q/) { X chop($_ = <<'EOT'); Xclose(ARGV); X@ARGV = (); Xnext LINE; XEOT X next; X } X } continue { X if ($space) { X s/^/$space/; X s/(\n)(.)/$1$space$2/g; X } X last; X } X $_; X} X Xsub fetchpat { X local($outer) = @_; X local($addr) = $outer; X local($inbracket); X local($prefix,$delim,$ch); X X # Process pattern one potential delimiter at a time. X X DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) { X $prefix = $1; X $delim = $2; X if ($delim eq '\\') { X s/(.)//; X $ch = $1; X $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/; X $ch = 'b' if $ch =~ /^[<>]$/; X $delim .= $ch; X } X elsif ($delim eq '[') { X $inbracket = 1; X s/^\^// && ($delim .= '^'); X s/^]// && ($delim .= ']'); X } X elsif ($delim eq ']') { X $inbracket = 0; X } X elsif ($inbracket || $delim ne $outer) { X $delim = '\\' . $delim; X } X $addr .= $prefix; X $addr .= $delim; X if ($delim eq $outer && !$inbracket) { X last DELIM; X } X } X $addr; X} X X!NO!SUBS! Xchmod 755 s2p X$eunicefix s2p !STUFFY!FUNK! echo Extracting x2p/a2p.y sed >x2p/a2p.y <<'!STUFFY!FUNK!' -e 's/X//' X%{ X/* $Header: a2p.y,v 4.0 91/03/20 01:57:21 lwall Locked $ X * X * Copyright (c) 1989, Larry Wall X * X * You may distribute under the terms of the GNU General Public License X * as specified in the README file that comes with the perl 3.0 kit. X * X * $Log: a2p.y,v $ X * Revision 4.0 91/03/20 01:57:21 lwall X * 4.0 baseline. X * X */ X X#include "INTERN.h" X#include "a2p.h" X Xint root; Xint begins = Nullop; Xint ends = Nullop; X X%} X%token BEGIN END X%token REGEX X%token SEMINEW NEWLINE COMMENT X%token FUN1 FUNN GRGR X%token PRINT PRINTF SPRINTF SPLIT X%token IF ELSE WHILE FOR IN X%token EXIT NEXT BREAK CONTINUE RET X%token GETLINE DO SUB GSUB MATCH X%token FUNCTION USERFUN DELETE X X%right ASGNOP X%right '?' ':' X%left OROR X%left ANDAND X%left IN X%left NUMBER VAR SUBSTR INDEX X%left MATCHOP X%left RELOP '<' '>' X%left OR X%left STRING X%left '+' '-' X%left '*' '/' '%' X%right UMINUS X%left NOT X%right '^' X%left INCR DECR X%left FIELD VFIELD X X%% X Xprogram : junk hunks X { root = oper4(OPROG,$1,begins,$2,ends); } X ; X Xbegin : BEGIN '{' maybe states '}' junk X { begins = oper4(OJUNK,begins,$3,$4,$6); in_begin = FALSE; X $$ = Nullop; } X ; X Xend : END '{' maybe states '}' X { ends = oper3(OJUNK,ends,$3,$4); $$ = Nullop; } X | end NEWLINE X { $$ = $1; } X ; X Xhunks : hunks hunk junk X { $$ = oper3(OHUNKS,$1,$2,$3); } X | /* NULL */ X { $$ = Nullop; } X ; X Xhunk : patpat X { $$ = oper1(OHUNK,$1); need_entire = TRUE; } X | patpat '{' maybe states '}' X { $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); } X | FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}' X { fixfargs($2,$4,0); $$ = oper5(OUSERDEF,$2,$4,$6,$8,$9); } X | '{' maybe states '}' X { $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); } X | begin X | end X ; X Xarg_list: expr_list X { $$ = rememberargs($$); } X ; X Xpatpat : cond X { $$ = oper1(OPAT,$1); } X | cond ',' cond X { $$ = oper2(ORANGE,$1,$3); } X ; X Xcond : expr X | match X | rel X | compound_cond X ; X Xcompound_cond X : '(' compound_cond ')' X { $$ = oper1(OCPAREN,$2); } X | cond ANDAND maybe cond X { $$ = oper3(OCANDAND,$1,$3,$4); } X | cond OROR maybe cond X { $$ = oper3(OCOROR,$1,$3,$4); } X | NOT cond X { $$ = oper1(OCNOT,$2); } X ; X Xrel : expr RELOP expr X { $$ = oper3(ORELOP,$2,$1,$3); } X | expr '>' expr X { $$ = oper3(ORELOP,string(">",1),$1,$3); } X | expr '<' expr X { $$ = oper3(ORELOP,string("<",1),$1,$3); } X | '(' rel ')' X { $$ = oper1(ORPAREN,$2); } X ; X Xmatch : expr MATCHOP expr X { $$ = oper3(OMATCHOP,$2,$1,$3); } X | expr MATCHOP REGEX X { $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); } X | REGEX %prec MATCHOP X { $$ = oper1(OREGEX,$1); } X | '(' match ')' X { $$ = oper1(OMPAREN,$2); } X ; X Xexpr : term X { $$ = $1; } X | expr term X { $$ = oper2(OCONCAT,$1,$2); } X | variable ASGNOP cond X { $$ = oper3(OASSIGN,$2,$1,$3); X if ((ops[$1].ival & 255) == OFLD) X lval_field = TRUE; X if ((ops[$1].ival & 255) == OVFLD) X lval_field = TRUE; X } X ; X Xterm : variable X { $$ = $1; } X | NUMBER X { $$ = oper1(ONUM,$1); } X | STRING X { $$ = oper1(OSTR,$1); } X | term '+' term X { $$ = oper2(OADD,$1,$3); } X | term '-' term X { $$ = oper2(OSUBTRACT,$1,$3); } X | term '*' term X { $$ = oper2(OMULT,$1,$3); } X | term '/' term X { $$ = oper2(ODIV,$1,$3); } X | term '%' term X { $$ = oper2(OMOD,$1,$3); } X | term '^' term X { $$ = oper2(OPOW,$1,$3); } X | term IN VAR X { $$ = oper2(ODEFINED,aryrefarg($3),$1); } X | term '?' term ':' term X { $$ = oper3(OCOND,$1,$3,$5); } X | variable INCR X { $$ = oper1(OPOSTINCR,$1); } X | variable DECR X { $$ = oper1(OPOSTDECR,$1); } X | INCR variable X { $$ = oper1(OPREINCR,$2); } X | DECR variable X { $$ = oper1(OPREDECR,$2); } X | '-' term %prec UMINUS X { $$ = oper1(OUMINUS,$2); } X | '+' term %prec UMINUS X { $$ = oper1(OUPLUS,$2); } X | '(' cond ')' X { $$ = oper1(OPAREN,$2); } X | GETLINE X { $$ = oper0(OGETLINE); } X | GETLINE VAR X { $$ = oper1(OGETLINE,$2); } X | GETLINE '<' expr X { $$ = oper3(OGETLINE,Nullop,string("<",1),$3); X if (ops[$3].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | GETLINE VAR '<' expr X { $$ = oper3(OGETLINE,$2,string("<",1),$4); X if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | term 'p' GETLINE X { $$ = oper3(OGETLINE,Nullop,string("|",1),$1); X if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | term 'p' GETLINE VAR X { $$ = oper3(OGETLINE,$4,string("|",1),$1); X if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | FUN1 X { $$ = oper0($1); need_entire = do_chop = TRUE; } X | FUN1 '(' ')' X { $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; } X | FUN1 '(' expr ')' X { $$ = oper1($1,$3); } X | FUNN '(' expr_list ')' X { $$ = oper1($1,$3); } X | USERFUN '(' expr_list ')' X { $$ = oper2(OUSERFUN,$1,$3); } X | SPRINTF expr_list X { $$ = oper1(OSPRINTF,$2); } X | SUBSTR '(' expr ',' expr ',' expr ')' X { $$ = oper3(OSUBSTR,$3,$5,$7); } X | SUBSTR '(' expr ',' expr ')' X { $$ = oper2(OSUBSTR,$3,$5); } X | SPLIT '(' expr ',' VAR ',' expr ')' X { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),$7); } X | SPLIT '(' expr ',' VAR ',' REGEX ')' X { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),oper1(OREGEX,$7));} X | SPLIT '(' expr ',' VAR ')' X { $$ = oper2(OSPLIT,$3,aryrefarg(numary($5))); } X | INDEX '(' expr ',' expr ')' X { $$ = oper2(OINDEX,$3,$5); } X | MATCH '(' expr ',' REGEX ')' X { $$ = oper2(OMATCH,$3,oper1(OREGEX,$5)); } X | MATCH '(' expr ',' expr ')' X { $$ = oper2(OMATCH,$3,$5); } X | SUB '(' expr ',' expr ')' X { $$ = oper2(OSUB,$3,$5); } X | SUB '(' REGEX ',' expr ')' X { $$ = oper2(OSUB,oper1(OREGEX,$3),$5); } X | GSUB '(' expr ',' expr ')' X { $$ = oper2(OGSUB,$3,$5); } X | GSUB '(' REGEX ',' expr ')' X { $$ = oper2(OGSUB,oper1(OREGEX,$3),$5); } X | SUB '(' expr ',' expr ',' expr ')' X { $$ = oper3(OSUB,$3,$5,$7); } X | SUB '(' REGEX ',' expr ',' expr ')' X { $$ = oper3(OSUB,oper1(OREGEX,$3),$5,$7); } X | GSUB '(' expr ',' expr ',' expr ')' X { $$ = oper3(OGSUB,$3,$5,$7); } X | GSUB '(' REGEX ',' expr ',' expr ')' X { $$ = oper3(OGSUB,oper1(OREGEX,$3),$5,$7); } X ; X Xvariable: VAR X { $$ = oper1(OVAR,$1); } X | VAR '[' expr_list ']' X { $$ = oper2(OVAR,aryrefarg($1),$3); } X | FIELD X { $$ = oper1(OFLD,$1); } X | VFIELD term X { $$ = oper1(OVFLD,$2); } X ; X Xexpr_list X : expr X | clist X | /* NULL */ X { $$ = Nullop; } X ; X Xclist : expr ',' maybe expr X { $$ = oper3(OCOMMA,$1,$3,$4); } X | clist ',' maybe expr X { $$ = oper3(OCOMMA,$1,$3,$4); } X | '(' clist ')' /* these parens are invisible */ X { $$ = $2; } X ; X Xjunk : junk hunksep X { $$ = oper2(OJUNK,$1,$2); } X | /* NULL */ X { $$ = Nullop; } X ; X Xhunksep : ';' X { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } X | SEMINEW X { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); } X | NEWLINE X { $$ = oper0(ONEWLINE); } X | COMMENT X { $$ = oper1(OCOMMENT,$1); } X ; X Xmaybe : maybe nlstuff X { $$ = oper2(OJUNK,$1,$2); } X | /* NULL */ X { $$ = Nullop; } X ; X Xnlstuff : NEWLINE X { $$ = oper0(ONEWLINE); } X | COMMENT X { $$ = oper1(OCOMMENT,$1); } X ; X Xseparator X : ';' maybe X { $$ = oper2(OJUNK,oper0(OSEMICOLON),$2); } X | SEMINEW maybe X { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); } X | NEWLINE maybe X { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); } X | COMMENT maybe X { $$ = oper2(OJUNK,oper1(OSCOMMENT,$1),$2); } X ; X Xstates : states statement X { $$ = oper2(OSTATES,$1,$2); } X | /* NULL */ X { $$ = Nullop; } X ; X Xstatement X : simple separator maybe X { $$ = oper2(OJUNK,oper2(OSTATE,$1,$2),$3); } X | ';' maybe X { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),$2)); } X | SEMINEW maybe X { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),$2)); } X | compound X ; X Xsimpnull: simple X | /* NULL */ X { $$ = Nullop; } X ; X Xsimple X : expr X | PRINT expr_list redir expr X { $$ = oper3(OPRINT,$2,$3,$4); X do_opens = TRUE; X saw_ORS = saw_OFS = TRUE; X if (!$2) need_entire = TRUE; X if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | PRINT expr_list X { $$ = oper1(OPRINT,$2); X if (!$2) need_entire = TRUE; X saw_ORS = saw_OFS = TRUE; X } X | PRINTF expr_list redir expr X { $$ = oper3(OPRINTF,$2,$3,$4); X do_opens = TRUE; X if (!$2) need_entire = TRUE; X if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; } X | PRINTF expr_list X { $$ = oper1(OPRINTF,$2); X if (!$2) need_entire = TRUE; X } X | BREAK X { $$ = oper0(OBREAK); } X | NEXT X { $$ = oper0(ONEXT); } X | EXIT X { $$ = oper0(OEXIT); } X | EXIT expr X { $$ = oper1(OEXIT,$2); } X | CONTINUE X { $$ = oper0(OCONTINUE); } X | RET X { $$ = oper0(ORETURN); } X | RET expr X { $$ = oper1(ORETURN,$2); } X | DELETE VAR '[' expr ']' X { $$ = oper2(ODELETE,aryrefarg($2),$4); } X ; X Xredir : '>' %prec FIELD X { $$ = oper1(OREDIR,string(">",1)); } X | GRGR X { $$ = oper1(OREDIR,string(">>",2)); } X | '|' X { $$ = oper1(OREDIR,string("|",1)); } X ; X Xcompound X : IF '(' cond ')' maybe statement X { $$ = oper2(OIF,$3,bl($6,$5)); } X | IF '(' cond ')' maybe statement ELSE maybe statement X { $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); } X | WHILE '(' cond ')' maybe statement X { $$ = oper2(OWHILE,$3,bl($6,$5)); } X | DO maybe statement WHILE '(' cond ')' X { $$ = oper2(ODO,bl($3,$2),$6); } X | FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement X { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); } X | FOR '(' simpnull ';' ';' simpnull ')' maybe statement X { $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); } X | FOR '(' expr ')' maybe statement X { $$ = oper2(OFORIN,$3,bl($6,$5)); } X | '{' maybe states '}' maybe X { $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); } X ; X X%% X#include "a2py.c" !STUFFY!FUNK! echo Extracting t/op/sort.t sed >t/op/sort.t <<'!STUFFY!FUNK!' -e 's/X//' X#!./perl X X# $Header: sort.t,v 4.0 91/03/20 01:54:38 lwall Locked $ X Xprint "1..8\n"; X Xsub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; } X X@harry = ('dog','cat','x','Cain','Abel'); X@george = ('gone','chased','yz','Punished','Axed'); X X$x = join('', sort @harry); Xprint ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n"); X X$x = join('', sort reverse @harry); Xprint ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n"); X X$x = join('', sort @george, 'to', @harry); Xprint ($x eq 'AbelAxedCainPunishedcatchaseddoggonetoxyz'?"ok 3\n":"not ok 3\n"); X X@a = (); X@b = reverse @a; Xprint ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); X X@a = (1); X@b = reverse @a; Xprint ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); X X@a = (1,2); X@b = reverse @a; Xprint ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); X X@a = (1,2,3); X@b = reverse @a; Xprint ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); X X@a = (1,2,3,4); X@b = reverse @a; Xprint ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); !STUFFY!FUNK! echo " " echo "End of kit 27 (of 36)" cat /dev/null >kit27isdone run='' config='' for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do if test -f kit${iskit}isdone; then run="$run $iskit" else todo="$todo $iskit" fi done case $todo in '') echo "You have run all your kits. Please read README and then type Configure." for combo in *:AA; do if test -f "$combo"; then realfile=`basename $combo :AA` cat $realfile:[A-Z][A-Z] >$realfile rm -rf $realfile:[A-Z][A-Z] fi done rm -rf kit*isdone chmod 755 Configure ;; *) echo "You have run$run." echo "You still need to run$todo." ;; esac : Someone might mail this, so... exit exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.