home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume18 / perl / part27 < prev    next >
Internet Message Format  |  1991-04-17  |  51KB
  1. From: lwall@netlabs.com (Larry Wall)
  2. Newsgroups: comp.sources.misc
  3. Subject: v18i045:  perl - The perl programming language, Part27/36
  4. Message-ID: <1991Apr17.185752.2658@sparky.IMD.Sterling.COM>
  5. Date: 17 Apr 91 18:57:52 GMT
  6. Approved: kent@sparky.imd.sterling.com
  7. X-Checksum-Snefru: 443b1506 81bea342 fe4444fd 4c0c71ef
  8.  
  9. Submitted-by: Larry Wall <lwall@netlabs.com>
  10. Posting-number: Volume 18, Issue 45
  11. Archive-name: perl/part27
  12.  
  13. [There are 36 kits for perl version 4.0.]
  14.  
  15. #! /bin/sh
  16.  
  17. # Make a new directory for the perl sources, cd to it, and run kits 1
  18. # thru 36 through sh.  When all 36 kits have been run, read README.
  19.  
  20. echo "This is perl 4.0 kit 27 (of 36).  If kit 27 is complete, the line"
  21. echo '"'"End of kit 27 (of 36)"'" will echo at the end.'
  22. echo ""
  23. export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
  24. mkdir emacs t t/op x2p 2>/dev/null
  25. echo Extracting MANIFEST
  26. sed >MANIFEST <<'!STUFFY!FUNK!' -e 's/X//'
  27. XConfigure        Run this first
  28. XCopying            The GNU General Public License
  29. XEXTERN.h        Included before foreign .h files
  30. XINTERN.h        Included before domestic .h files
  31. XMANIFEST        This list of files
  32. XMakefile.SH        Precursor to Makefile
  33. XPACKINGLIST        Which files came from which kits
  34. XREADME            The Instructions
  35. XREADME.uport        Special instructions for Microports
  36. XREADME.xenix        Special instructions for Xenix
  37. XWishlist        Some things that may or may not happen
  38. Xarg.h            Public declarations for the above
  39. Xarray.c            Numerically subscripted arrays
  40. Xarray.h            Public declarations for the above
  41. Xcflags.SH        A script that emits C compilation flags per file
  42. Xclient            A client to test sockets
  43. Xcmd.c            Command interpreter
  44. Xcmd.h            Public declarations for the above
  45. Xconfig.H        Sample config.h
  46. Xconfig_h.SH        Produces config.h
  47. Xcons.c            Routines to construct cmd nodes of a parse tree
  48. Xconsarg.c        Routines to construct arg nodes of a parse tree
  49. Xdoarg.c            Scalar expression evaluation
  50. Xdoio.c            I/O operations
  51. Xdolist.c        Array expression evaluation
  52. Xdump.c            Debugging output
  53. Xeg/ADB            An adb wrapper to put in your crash dir
  54. Xeg/README        Intro to example perl scripts
  55. Xeg/changes        A program to list recently changed files
  56. Xeg/down            A program to do things to subdirectories
  57. Xeg/dus            A program to do du -s on non-mounted dirs
  58. Xeg/findcp        A find wrapper that implements a -cp switch
  59. Xeg/findtar        A find wrapper that pumps out a tar file
  60. Xeg/g/gcp        A program to do a global rcp
  61. Xeg/g/gcp.man        Manual page for gcp
  62. Xeg/g/ged        A program to do a global edit
  63. Xeg/g/ghosts        A sample /etc/ghosts file
  64. Xeg/g/gsh        A program to do a global rsh
  65. Xeg/g/gsh.man        Manual page for gsh
  66. Xeg/muck            A program to find missing make dependencies
  67. Xeg/muck.man        Manual page for muck
  68. Xeg/myrup        A program to find lightly loaded machines
  69. Xeg/nih            Script to insert #! workaround
  70. Xeg/relink        A program to change symbolic links
  71. Xeg/rename        A program to rename files
  72. Xeg/rmfrom        A program to feed doomed filenames to
  73. Xeg/scan/scan_df        Scan for filesystem anomalies
  74. Xeg/scan/scan_last    Scan for login anomalies
  75. Xeg/scan/scan_messages    Scan for console message anomalies
  76. Xeg/scan/scan_passwd    Scan for passwd file anomalies
  77. Xeg/scan/scan_ps        Scan for process anomalies
  78. Xeg/scan/scan_sudo    Scan for sudo anomalies
  79. Xeg/scan/scan_suid    Scan for setuid anomalies
  80. Xeg/scan/scanner        An anomaly reporter
  81. Xeg/shmkill        A program to remove unused shared memory
  82. Xeg/sysvipc/README    Intro to Sys V IPC examples
  83. Xeg/sysvipc/ipcmsg    Example of SYS V IPC message queues
  84. Xeg/sysvipc/ipcsem    Example of Sys V IPC semaphores
  85. Xeg/sysvipc/ipcshm    Example of Sys V IPC shared memory
  86. Xeg/travesty        A program to print travesties of its input text
  87. Xeg/van/empty        A program to empty the trashcan
  88. Xeg/van/unvanish        A program to undo what vanish does
  89. Xeg/van/vanexp        A program to expire vanished files
  90. Xeg/van/vanish        A program to put files in a trashcan
  91. Xeg/who            A sample who program
  92. Xemacs/perldb.pl        Emacs debugging
  93. Xemacs/perldb.el        Emacs debugging
  94. Xemacs/perl-mode.el    Emacs major mode for perl
  95. Xemacs/tedstuff        Some optional patches
  96. Xeval.c            The expression evaluator
  97. Xform.c            Format processing
  98. Xform.h            Public declarations for the above
  99. Xgettest            A little script to test the get* routines
  100. Xh2ph.SH            A thing to turn C .h file into perl .ph files
  101. Xh2pl/README        How to turn .ph files into .pl files
  102. Xh2pl/cbreak.pl        cbreak routines using .ph
  103. Xh2pl/cbreak2.pl        cbreak routines using .pl
  104. Xh2pl/eg/sizeof.ph    Sample sizeof array initialization
  105. Xh2pl/eg/sys/errno.pl    Sample translated errno.pl
  106. Xh2pl/eg/sys/ioctl.pl    Sample translated ioctl.pl
  107. Xh2pl/eg/sysexits.pl    Sample translated sysexits.pl
  108. Xh2pl/getioctlsizes    Program to extract types from ioctl.h
  109. Xh2pl/mksizes        Program to make %sizeof array.
  110. Xh2pl/mkvars        Program to make .pl from .ph files
  111. Xh2pl/tcbreak        cbreak test routine using .ph
  112. Xh2pl/tcbreak2        cbreak test routine using .pl
  113. Xhandy.h            Handy definitions
  114. Xhash.c            Associative arrays
  115. Xhash.h            Public declarations for the above
  116. Xhints/3b2.sh
  117. Xhints/aix_rs.sh
  118. Xhints/aix_rt.sh
  119. Xhints/apollo_C6_7.sh
  120. Xhints/aux.sh
  121. Xhints/dnix.sh
  122. Xhints/dynix.sh
  123. Xhints/fps.sh
  124. Xhints/genix.sh
  125. Xhints/hp9000_300.sh
  126. Xhints/hp9000_400.sh
  127. Xhints/hpux.sh
  128. Xhints/i386.sh
  129. Xhints/mips.sh
  130. Xhints/ncr_tower.sh
  131. Xhints/next.sh
  132. Xhints/osf_1.sh
  133. Xhints/sco_2_3_0.sh
  134. Xhints/sco_2_3_1.sh
  135. Xhints/sco_2_3_2.sh
  136. Xhints/sco_2_3_3.sh
  137. Xhints/sco_3.sh
  138. Xhints/sgi.sh
  139. Xhints/sunos_3_4.sh
  140. Xhints/sunos_3_5.sh
  141. Xhints/sunos_4_0_1.sh
  142. Xhints/sunos_4_0_2.sh
  143. Xhints/ultrix_3.sh
  144. Xhints/ultrix_4.sh
  145. Xhints/uts.sh
  146. Xinstallperl        Perl script to do "make install" dirty work
  147. Xioctl.pl        Sample ioctl.pl
  148. Xlib/abbrev.pl        An abbreviation table builder
  149. Xlib/bigfloat.pl        An arbitrary precision floating point package
  150. Xlib/bigint.pl        An arbitrary precision integer arithmetic package
  151. Xlib/bigrat.pl        An arbitrary precision rational arithmetic package
  152. Xlib/cacheout.pl        Manages output filehandles when you need too many
  153. Xlib/complete.pl        A command completion subroutine
  154. Xlib/ctime.pl        A ctime workalike
  155. Xlib/dumpvar.pl        A variable dumper
  156. Xlib/flush.pl        Routines to do single flush
  157. Xlib/getopt.pl        Perl library supporting option parsing
  158. Xlib/getopts.pl        Perl library supporting option parsing
  159. Xlib/importenv.pl    Perl routine to get environment into variables
  160. Xlib/look.pl        A "look" equivalent
  161. Xlib/perldb.pl        Perl debugging routines
  162. Xlib/pwd.pl        Routines to keep track of PWD environment variable
  163. Xlib/stat.pl        Perl library supporting stat function
  164. Xlib/syslog.pl        Perl library supporting syslogging
  165. Xlib/termcap.pl        Perl library supporting termcap usage
  166. Xlib/timelocal.pl    Perl library supporting inverse of localtime, gmtime
  167. Xlib/validate.pl        Perl library supporting wholesale file mode validation
  168. Xmakedepend.SH        Precursor to makedepend
  169. Xmakedir.SH        Precursor to makedir
  170. Xmalloc.c        A version of malloc you might not want
  171. Xmsdos/Changes.dds    Expanation of MS-DOS patches by Diomidis Spinellis
  172. Xmsdos/Makefile        MS-DOS makefile
  173. Xmsdos/README.msdos    Compiling and usage information
  174. Xmsdos/Wishlist.dds    My wishlist
  175. Xmsdos/config.h        Definitions for msdos
  176. Xmsdos/chdir.c        A chdir that can change drives
  177. Xmsdos/dir.h        MS-DOS header for directory access functions
  178. Xmsdos/directory.c    MS-DOS directory access functions.
  179. Xmsdos/eg/crlf.bat    Convert files from unix to MS-DOS line termination
  180. Xmsdos/eg/drives.bat    List the system drives and their characteristics
  181. Xmsdos/eg/lf.bat        Convert files from MS-DOS to Unix line termination
  182. Xmsdos/glob.c        A command equivalent to csh glob
  183. Xmsdos/msdos.c        MS-DOS ioctl, sleep, gete?[gu]if, spawn, aspawn
  184. Xmsdos/popen.c        My_popen and my_pclose for MS-DOS
  185. Xmsdos/usage.c        How to invoke perl under MS-DOS
  186. Xos2/Makefile        Makefile for OS/2
  187. Xos2/README.OS2        Notes for OS/2
  188. Xos2/a2p.cs        Compiler script for a2p
  189. Xos2/a2p.def        Linker defs for a2p
  190. Xos2/alarm.c        An implementation of alarm()
  191. Xos2/alarm.h        Header file for same
  192. Xos2/config.h        Configuration file for OS/2
  193. Xos2/dir.h        Directory header
  194. Xos2/director.c        Directory routines
  195. Xos2/eg/alarm.pl        Example of alarm code
  196. Xos2/eg/os2.pl        Sample script for OS/2
  197. Xos2/eg/syscalls.pl    Example of syscall on OS/2
  198. Xos2/glob.c        Globbing routines
  199. Xos2/makefile        Make file
  200. Xos2/mktemp.c        Mktemp() using TMP
  201. Xos2/os2.c        Unix compatibility functions
  202. Xos2/perl.bad        names of protect-only API calls for BIND
  203. Xos2/perl.cs        Compiler script for perl
  204. Xos2/perl.def        Linker defs for perl
  205. Xos2/perldb.dif        Changes to make the debugger work
  206. Xos2/perlglob.bad    names of protect-only API calls for BIND
  207. Xos2/perlglob.cs        Compiler script for perlglob
  208. Xos2/perlglob.def    Linker defs for perlglob
  209. Xos2/perlsh.cmd        Poor man's shell for os2
  210. Xos2/popen.c        Code for opening pipes
  211. Xos2/s2p.cmd        s2p as command file
  212. Xos2/selfrun.bat        A self running perl script for DOS
  213. Xos2/selfrun.cmd        Example of extproc feature
  214. Xos2/suffix.c        Code for creating backup filenames
  215. Xpatchlevel.h        The current patch level of perl
  216. Xperl.c            main()
  217. Xperl.h            Global declarations
  218. Xperl.man        The manual page(s)
  219. Xperlsh            A poor man's perl shell
  220. Xperly.y            Yacc grammar for perl
  221. Xperly.fixer        A program to remove yacc stack limitations
  222. Xregcomp.c        Regular expression compiler
  223. Xregcomp.h        Private declarations for above
  224. Xregexec.c        Regular expression evaluator
  225. Xregexp.h        Public declarations for the above
  226. Xserver            A server to test sockets
  227. Xspat.h            Search pattern declarations
  228. Xstab.c            Symbol table stuff
  229. Xstab.h            Public declarations for the above
  230. Xstr.c            String handling package
  231. Xstr.h            Public declarations for the above
  232. Xt/README        Instructions for regression tests
  233. Xt/TEST            The regression tester
  234. Xt/base/cond.t        See if conditionals work
  235. Xt/base/if.t        See if if works
  236. Xt/base/lex.t        See if lexical items work
  237. Xt/base/pat.t        See if pattern matching works
  238. Xt/base/term.t        See if various terms work
  239. Xt/cmd/elsif.t        See if else-if works
  240. Xt/cmd/for.t        See if for loops work
  241. Xt/cmd/mod.t        See if statement modifiers work
  242. Xt/cmd/subval.t        See if subroutine values work
  243. Xt/cmd/switch.t        See if switch optimizations work
  244. Xt/cmd/while.t        See if while loops work
  245. Xt/comp/cmdopt.t        See if command optimization works
  246. Xt/comp/cpp.t        See if C preprocessor works
  247. Xt/comp/decl.t        See if declarations work
  248. Xt/comp/multiline.t    See if multiline strings work
  249. Xt/comp/package.t    See if packages work
  250. Xt/comp/script.t        See if script invokation works
  251. Xt/comp/term.t        See if more terms work
  252. Xt/io/argv.t        See if ARGV stuff works
  253. Xt/io/dup.t        See if >& works right
  254. Xt/io/fs.t        See if directory manipulations work
  255. Xt/io/inplace.t        See if inplace editing works
  256. Xt/io/pipe.t        See if secure pipes work
  257. Xt/io/print.t        See if print commands work
  258. Xt/io/tell.t        See if file seeking works
  259. Xt/lib/big.t        See if lib/bigint.pl works
  260. Xt/op/append.t        See if . works
  261. Xt/op/array.t        See if array operations work
  262. Xt/op/auto.t        See if autoincrement et all work
  263. Xt/op/chop.t        See if chop works
  264. Xt/op/cond.t        See if conditional expressions work
  265. Xt/op/dbm.t        See if dbm binding works
  266. Xt/op/delete.t        See if delete works
  267. Xt/op/do.t        See if subroutines work
  268. Xt/op/each.t        See if associative iterators work
  269. Xt/op/eval.t        See if eval operator works
  270. Xt/op/exec.t        See if exec and system work
  271. Xt/op/exp.t        See if math functions work
  272. Xt/op/flip.t        See if range operator works
  273. Xt/op/fork.t        See if fork works
  274. Xt/op/glob.t        See if <*> works
  275. Xt/op/goto.t        See if goto works
  276. Xt/op/groups.t        See if $( works
  277. Xt/op/index.t        See if index works
  278. Xt/op/int.t        See if int works
  279. Xt/op/join.t        See if join works
  280. Xt/op/list.t        See if array lists work
  281. Xt/op/local.t        See if local works
  282. Xt/op/magic.t        See if magic variables work
  283. Xt/op/mkdir.t        See if mkdir works
  284. Xt/op/oct.t        See if oct and hex work
  285. Xt/op/ord.t        See if ord works
  286. Xt/op/pack.t        See if pack and unpack work
  287. Xt/op/pat.t        See if esoteric patterns work
  288. Xt/op/push.t        See if push and pop work
  289. Xt/op/range.t        See if .. works
  290. Xt/op/read.t        See if read() works
  291. Xt/op/regexp.t        See if regular expressions work
  292. Xt/op/repeat.t        See if x operator works
  293. Xt/op/s.t        See if substitutions work
  294. Xt/op/sleep.t        See if sleep works
  295. Xt/op/sort.t        See if sort works
  296. Xt/op/split.t        See if split works
  297. Xt/op/sprintf.t        See if sprintf works
  298. Xt/op/stat.t        See if stat works
  299. Xt/op/study.t        See if study works
  300. Xt/op/substr.t        See if substr works
  301. Xt/op/time.t        See if time functions work
  302. Xt/op/undef.t        See if undef works
  303. Xt/op/unshift.t        See if unshift works
  304. Xt/op/vec.t        See if vectors work
  305. Xt/op/write.t        See if write works
  306. Xt/op/re_tests        Input file for op.regexp
  307. Xtoke.c            The tokener
  308. Xusersub.c        User supplied (possibly proprietary) subroutines
  309. Xusub/README        Instructions for user supplied subroutines
  310. Xusub/Makefile        Makefile for curseperl
  311. Xusub/curses.mus        Glue routines for BSD curses
  312. Xusub/man2mus        A manual page to .mus translator
  313. Xusub/mus        A .mus to .c translator
  314. Xusub/pager        A sample pager in curseperl
  315. Xusub/usersub.c        An initialization file to call curses glue routines
  316. Xutil.c            Utility routines
  317. Xutil.h            Public declarations for the above
  318. Xx2p/EXTERN.h        Same as above
  319. Xx2p/INTERN.h        Same as above
  320. Xx2p/Makefile.SH        Precursor to Makefile
  321. Xx2p/a2p.h        Global declarations
  322. Xx2p/a2p.man        Manual page for awk to perl translator
  323. Xx2p/a2p.y        A yacc grammer for awk
  324. Xx2p/a2py.c        Awk compiler, sort of
  325. Xx2p/find2perl.SH    A find to perl translator
  326. Xx2p/handy.h        Handy definitions
  327. Xx2p/hash.c        Associative arrays again
  328. Xx2p/hash.h        Public declarations for the above
  329. Xx2p/s2p.SH        Sed to perl translator
  330. Xx2p/s2p.man        Manual page for sed to perl translator
  331. Xx2p/str.c        String handling package
  332. Xx2p/str.h        Public declarations for the above
  333. Xx2p/util.c        Utility routines
  334. Xx2p/util.h        Public declarations for the above
  335. Xx2p/walk.c        Parse tree walker
  336. !STUFFY!FUNK!
  337. echo Extracting emacs/tedstuff
  338. sed >emacs/tedstuff <<'!STUFFY!FUNK!' -e 's/X//'
  339. XArticle 4417 of comp.lang.perl:
  340. XPath: jpl-devvax!elroy.jpl.nasa.gov!decwrl!mcnc!uvaarpa!mmdf
  341. XFrom: ted@evi.com (Ted Stefanik)
  342. XNewsgroups: comp.lang.perl
  343. XSubject: Correction to Perl fatal error marking in GNU Emacs
  344. XMessage-ID: <1991Feb27.065853.15801@uvaarpa.Virginia.EDU>
  345. XDate: 27 Feb 91 06:58:53 GMT
  346. XSender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System)
  347. XReply-To: ted@evi.com (Ted Stefanik)
  348. XOrganization: The Internet
  349. XLines: 282
  350. X
  351. XReading my own message, it occurred to me that I didn't quite satisfy the
  352. Xrequest of stef@zweig.sun (Stephane Payrard):
  353. X
  354. X| Does anyone has extended perdb/perdb.el to position the
  355. X| point to the first syntax error? It would be cool.
  356. X
  357. XWhat I posted is a way to use the "M-x compile" command to test perl scripts.
  358. X(Needless to say, the script cannot be not interactive; you can't provide input
  359. Xto a *compilation* buffer).  When creating new Perl programs, I use "M-x
  360. Xcompile" until I'm sure that they are syntatically correct; if syntax errors
  361. Xoccur, C-x` takes me to each in sequence.  After I'm sure the syntax is
  362. Xcorrect, I start worrying about semantics, and switch to "M-x perldb" if
  363. Xnecessary.
  364. X
  365. XTherefore, the stuff I posted works great with "M-x compile", but not at all
  366. Xwith "M-x perldb".
  367. X
  368. XNext, let me update what I posted.  I found that perl's die() command doesn't
  369. Xprint the same format error message as perl does when it dies with a syntax
  370. Xerror.   If you put the following in your ".emacs" file, it causes C-x` to
  371. Xrecognize both kinds of errors:
  372. X
  373. X(load-library "compile")
  374. X(setq compilation-error-regexp
  375. X  "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\|[^ \n]+ \\(at \\)*line [0-9]+\\)")
  376. X
  377. XLast, so I don't look like a total fool, let me propose a way to satisfy
  378. XStephane Payrard's original request (repeated again):
  379. X
  380. X| Does anyone has extended perdb/perdb.el to position the
  381. X| point to the first syntax error? It would be cool.
  382. X
  383. XI'm not satisfied with just the "first syntax error".  Perl's parser is better
  384. Xthan most about not getting out of sync; therefore, if it reports multiple
  385. Xerrors, you can usually be assured they are all real errors.
  386. X
  387. XSo... I hacked in the "next-error" function from "compile.el" to form
  388. X"perldb-next-error".  You can apply the patches at the end of this message
  389. Xto add "perldb-next-error" to your "perldb.el".
  390. X
  391. XNotes:
  392. X   1) The patch binds "perldb-next-error" to C-x~ (because ~ is the shift
  393. X      of ` on my keyboard, and C-x~ is not yet taken in my version of EMACS).
  394. X
  395. X   2) "next-error" is meant to work on a single *compilation* buffer; any new
  396. X      "M-x compile" or "M-x grep" command will clear the old *compilation*
  397. X      buffer and reset the compilation-error parser to start at the top of the
  398. X      *compilation* buffer.
  399. X
  400. X     "perldb-next-error", on the other hand, has to deal with multiple
  401. X      *perldb-<foo>* buffers, each of which keep growing.  "perldb-next-error"
  402. X      correctly handles the constantly growing *perldb-<foo>* buffers by
  403. X      keeping track of the last reported error in the "current-perldb-buffer".
  404. X
  405. X      Sadly however, when you invoke a new "M-x perldb" on a different Perl
  406. X      script, "perldb-next-error" will start parsing the new *perldb-<bar>*
  407. X      buffer at the top (even if it was previously parsed), and will completely
  408. X      lose the marker of the last reported error in *perldb-<foo>*.
  409. X
  410. X   3) "perldb-next-error" still uses "compilation-error-regexp" to find
  411. X      fatal errors.  Therefore, both the "M-x compile"/C-x` scheme and
  412. X      the "M-x perldb"/C-x~ scheme can be used to find fatal errors that
  413. X      match the common "compilation-error-regexp".  You *will* want to install
  414. X      that "compilation-error-regexp" stuff into your .emacs file.
  415. X
  416. X   4) The patch was developed and tested with GNU Emacs 18.55.
  417. X
  418. X   5) Since the patch was ripped off from compile.el, the code is (of
  419. X      course) subject to the GNU copyleft.
  420. X
  421. X*** perldb.el.orig    Wed Feb 27 00:44:27 1991
  422. X--- perldb.el    Wed Feb 27 00:44:30 1991
  423. X***************
  424. X*** 199,205 ****
  425. X  
  426. X  (defun perldb-set-buffer ()
  427. X    (cond ((eq major-mode 'perldb-mode)
  428. X!     (setq current-perldb-buffer (current-buffer)))))
  429. X  
  430. X  ;; This function is responsible for inserting output from Perl
  431. X  ;; into the buffer.
  432. X--- 199,211 ----
  433. X  
  434. X  (defun perldb-set-buffer ()
  435. X    (cond ((eq major-mode 'perldb-mode)
  436. X!          (cond ((not (eq current-perldb-buffer (current-buffer)))
  437. X!                 (perldb-forget-errors)
  438. X!                 (setq perldb-parsing-end 2)) ;; 2 to defeat grep defeater
  439. X!                (t
  440. X!                 (if (> perldb-parsing-end (point-max))
  441. X!                     (setq perldb-parsing-end (max (point-max) 2)))))
  442. X!          (setq current-perldb-buffer (current-buffer)))))
  443. X  
  444. X  ;; This function is responsible for inserting output from Perl
  445. X  ;; into the buffer.
  446. X***************
  447. X*** 291,297 ****
  448. X         ;;  process-buffer is current-buffer
  449. X         (unwind-protect
  450. X             (progn
  451. X!          ;; Write something in *compilation* and hack its mode line,
  452. X           (set-buffer (process-buffer proc))
  453. X           ;; Force mode line redisplay soon
  454. X           (set-buffer-modified-p (buffer-modified-p))
  455. X--- 297,303 ----
  456. X         ;;  process-buffer is current-buffer
  457. X         (unwind-protect
  458. X             (progn
  459. X!          ;; Write something in *perldb-<foo>* and hack its mode line,
  460. X           (set-buffer (process-buffer proc))
  461. X           ;; Force mode line redisplay soon
  462. X           (set-buffer-modified-p (buffer-modified-p))
  463. X***************
  464. X*** 421,423 ****
  465. X--- 427,593 ----
  466. X      (switch-to-buffer-other-window current-perldb-buffer)
  467. X      (goto-char (dot-max))
  468. X      (insert-string comm)))
  469. X+ 
  470. X+ (defvar perldb-error-list nil
  471. X+   "List of error message descriptors for visiting erring functions.
  472. X+ Each error descriptor is a list of length two.
  473. X+ Its car is a marker pointing to an error message.
  474. X+ Its cadr is a marker pointing to the text of the line the message is about,
  475. X+   or nil if that is not interesting.
  476. X+ The value may be t instead of a list;
  477. X+ this means that the buffer of error messages should be reparsed
  478. X+ the next time the list of errors is wanted.")
  479. X+ 
  480. X+ (defvar perldb-parsing-end nil
  481. X+   "Position of end of buffer when last error messages parsed.")
  482. X+ 
  483. X+ (defvar perldb-error-message "No more fatal Perl errors"
  484. X+   "Message to print when no more matches for compilation-error-regexp are found")
  485. X+ 
  486. X+ (defun perldb-next-error (&optional argp)
  487. X+   "Visit next perldb error message and corresponding source code.
  488. X+ This operates on the output from the \\[perldb] command.
  489. X+ If all preparsed error messages have been processed,
  490. X+ the error message buffer is checked for new ones.
  491. X+ A non-nil argument (prefix arg, if interactive)
  492. X+ means reparse the error message buffer and start at the first error."
  493. X+   (interactive "P")
  494. X+   (if (or (eq perldb-error-list t)
  495. X+       argp)
  496. X+       (progn (perldb-forget-errors)
  497. X+          (setq perldb-parsing-end 2))) ;; 2 to defeat grep defeater
  498. X+   (if perldb-error-list
  499. X+       nil
  500. X+     (save-excursion
  501. X+       (switch-to-buffer current-perldb-buffer)
  502. X+       (perldb-parse-errors)))
  503. X+   (let ((next-error (car perldb-error-list)))
  504. X+     (if (null next-error)
  505. X+     (error (concat perldb-error-message
  506. X+                (if (and (get-buffer-process current-perldb-buffer)
  507. X+                 (eq (process-status
  508. X+                                      (get-buffer-process
  509. X+                                       current-perldb-buffer))
  510. X+                     'run))
  511. X+                " yet" ""))))
  512. X+     (setq perldb-error-list (cdr perldb-error-list))
  513. X+     (if (null (car (cdr next-error)))
  514. X+     nil
  515. X+       (switch-to-buffer (marker-buffer (car (cdr next-error))))
  516. X+       (goto-char (car (cdr next-error)))
  517. X+       (set-marker (car (cdr next-error)) nil))
  518. X+     (let* ((pop-up-windows t)
  519. X+        (w (display-buffer (marker-buffer (car next-error)))))
  520. X+       (set-window-point w (car next-error))
  521. X+       (set-window-start w (car next-error)))
  522. X+     (set-marker (car next-error) nil)))
  523. X+ 
  524. X+ ;; Set perldb-error-list to nil, and
  525. X+ ;; unchain the markers that point to the error messages and their text,
  526. X+ ;; so that they no longer slow down gap motion.
  527. X+ ;; This would happen anyway at the next garbage collection,
  528. X+ ;; but it is better to do it right away.
  529. X+ (defun perldb-forget-errors ()
  530. X+   (if (eq perldb-error-list t)
  531. X+       (setq perldb-error-list nil))
  532. X+   (while perldb-error-list
  533. X+     (let ((next-error (car perldb-error-list)))
  534. X+       (set-marker (car next-error) nil)
  535. X+       (if (car (cdr next-error))
  536. X+       (set-marker (car (cdr next-error)) nil)))
  537. X+     (setq perldb-error-list (cdr perldb-error-list))))
  538. X+ 
  539. X+ (defun perldb-parse-errors ()
  540. X+   "Parse the current buffer as error messages.
  541. X+ This makes a list of error descriptors, perldb-error-list.
  542. X+ For each source-file, line-number pair in the buffer,
  543. X+ the source file is read in, and the text location is saved in perldb-error-list.
  544. X+ The function next-error, assigned to \\[next-error], takes the next error off the list
  545. X+ and visits its location."
  546. X+   (setq perldb-error-list nil)
  547. X+   (message "Parsing error messages...")
  548. X+   (let (text-buffer
  549. X+     last-filename last-linenum)
  550. X+     ;; Don't reparse messages already seen at last parse.
  551. X+     (goto-char perldb-parsing-end)
  552. X+     ;; Don't parse the first two lines as error messages.
  553. X+     ;; This matters for grep.
  554. X+     (if (bobp)
  555. X+     (forward-line 2))
  556. X+     (while (re-search-forward compilation-error-regexp nil t)
  557. X+       (let (linenum filename
  558. X+         error-marker text-marker)
  559. X+     ;; Extract file name and line number from error message.
  560. X+     (save-restriction
  561. X+       (narrow-to-region (match-beginning 0) (match-end 0))
  562. X+       (goto-char (point-max))
  563. X+       (skip-chars-backward "[0-9]")
  564. X+       ;; If it's a lint message, use the last file(linenum) on the line.
  565. X+       ;; Normally we use the first on the line.
  566. X+       (if (= (preceding-char) ?\()
  567. X+           (progn
  568. X+         (narrow-to-region (point-min) (1+ (buffer-size)))
  569. X+         (end-of-line)
  570. X+         (re-search-backward compilation-error-regexp)
  571. X+         (skip-chars-backward "^ \t\n")
  572. X+         (narrow-to-region (point) (match-end 0))
  573. X+         (goto-char (point-max))
  574. X+         (skip-chars-backward "[0-9]")))
  575. X+       ;; Are we looking at a "filename-first" or "line-number-first" form?
  576. X+       (if (looking-at "[0-9]")
  577. X+           (progn
  578. X+         (setq linenum (read (current-buffer)))
  579. X+         (goto-char (point-min)))
  580. X+         ;; Line number at start, file name at end.
  581. X+         (progn
  582. X+           (goto-char (point-min))
  583. X+           (setq linenum (read (current-buffer)))
  584. X+           (goto-char (point-max))
  585. X+           (skip-chars-backward "^ \t\n")))
  586. X+       (setq filename (perldb-grab-filename)))
  587. X+     ;; Locate the erring file and line.
  588. X+     (if (and (equal filename last-filename)
  589. X+          (= linenum last-linenum))
  590. X+         nil
  591. X+       (beginning-of-line 1)
  592. X+       (setq error-marker (point-marker))
  593. X+       ;; text-buffer gets the buffer containing this error's file.
  594. X+       (if (not (equal filename last-filename))
  595. X+           (setq text-buffer
  596. X+             (and (file-exists-p (setq last-filename filename))
  597. X+              (find-file-noselect filename))
  598. X+             last-linenum 0))
  599. X+       (if text-buffer
  600. X+           ;; Go to that buffer and find the erring line.
  601. X+           (save-excursion
  602. X+         (set-buffer text-buffer)
  603. X+         (if (zerop last-linenum)
  604. X+             (progn
  605. X+               (goto-char 1)
  606. X+               (setq last-linenum 1)))
  607. X+         (forward-line (- linenum last-linenum))
  608. X+         (setq last-linenum linenum)
  609. X+         (setq text-marker (point-marker))
  610. X+         (setq perldb-error-list
  611. X+               (cons (list error-marker text-marker)
  612. X+                 perldb-error-list)))))
  613. X+     (forward-line 1)))
  614. X+     (setq perldb-parsing-end (point-max)))
  615. X+   (message "Parsing error messages...done")
  616. X+   (setq perldb-error-list (nreverse perldb-error-list)))
  617. X+ 
  618. X+ (defun perldb-grab-filename ()
  619. X+   "Return a string which is a filename, starting at point.
  620. X+ Ignore quotes and parentheses around it, as well as trailing colons."
  621. X+   (if (eq (following-char) ?\")
  622. X+       (save-restriction
  623. X+     (narrow-to-region (point)
  624. X+               (progn (forward-sexp 1) (point)))
  625. X+     (goto-char (point-min))
  626. X+     (read (current-buffer)))
  627. X+     (buffer-substring (point)
  628. X+               (progn
  629. X+             (skip-chars-forward "^ :,\n\t(")
  630. X+             (point)))))
  631. X+ 
  632. X+ (define-key ctl-x-map "~" 'perldb-next-error)
  633. X
  634. X
  635. !STUFFY!FUNK!
  636. echo Extracting x2p/s2p.SH
  637. sed >x2p/s2p.SH <<'!STUFFY!FUNK!' -e 's/X//'
  638. X: This forces SH files to create target in same directory as SH file.
  639. X: This is so that make depend always knows where to find SH derivatives.
  640. Xcase "$0" in
  641. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  642. Xesac
  643. Xcase $CONFIG in
  644. X'')
  645. X    if test ! -f config.sh; then
  646. X    ln ../config.sh . || \
  647. X    ln -s ../config.sh . || \
  648. X    ln ../../config.sh . || \
  649. X    ln ../../../config.sh . || \
  650. X    (echo "Can't find config.sh."; exit 1)
  651. X    fi 2>/dev/null
  652. X    . ./config.sh
  653. X    ;;
  654. Xesac
  655. Xecho "Extracting s2p (with variable substitutions)"
  656. X: This section of the file will have variable substitutions done on it.
  657. X: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
  658. X: Protect any dollar signs and backticks that you do not want interpreted
  659. X: by putting a backslash in front.  You may delete these comments.
  660. X$spitshell >s2p <<!GROK!THIS!
  661. X#!$bin/perl
  662. X
  663. X\$bin = '$bin';
  664. X!GROK!THIS!
  665. X
  666. X: In the following dollars and backticks do not need the extra backslash.
  667. X$spitshell >>s2p <<'!NO!SUBS!'
  668. X
  669. X# $Header: s2p.SH,v 4.0 91/03/20 01:57:59 lwall Locked $
  670. X#
  671. X# $Log:    s2p.SH,v $
  672. X# Revision 4.0  91/03/20  01:57:59  lwall
  673. X# 4.0 baseline.
  674. X# 
  675. X#
  676. X
  677. X$indent = 4;
  678. X$shiftwidth = 4;
  679. X$l = '{'; $r = '}';
  680. X
  681. Xwhile ($ARGV[0] =~ /^-/) {
  682. X    $_ = shift;
  683. X  last if /^--/;
  684. X    if (/^-D/) {
  685. X    $debug++;
  686. X    open(BODY,'>-');
  687. X    next;
  688. X    }
  689. X    if (/^-n/) {
  690. X    $assumen++;
  691. X    next;
  692. X    }
  693. X    if (/^-p/) {
  694. X    $assumep++;
  695. X    next;
  696. X    }
  697. X    die "I don't recognize this switch: $_\n";
  698. X}
  699. X
  700. Xunless ($debug) {
  701. X    open(BODY,">/tmp/sperl$$") ||
  702. X      &Die("Can't open temp file: $!\n");
  703. X}
  704. X
  705. Xif (!$assumen && !$assumep) {
  706. X    print BODY <<'EOT';
  707. Xwhile ($ARGV[0] =~ /^-/) {
  708. X    $_ = shift;
  709. X  last if /^--/;
  710. X    if (/^-n/) {
  711. X    $nflag++;
  712. X    next;
  713. X    }
  714. X    die "I don't recognize this switch: $_\\n";
  715. X}
  716. X
  717. XEOT
  718. X}
  719. X
  720. Xprint BODY <<'EOT';
  721. X
  722. X#ifdef PRINTIT
  723. X#ifdef ASSUMEP
  724. X$printit++;
  725. X#else
  726. X$printit++ unless $nflag;
  727. X#endif
  728. X#endif
  729. XLINE: while (<>) {
  730. XEOT
  731. X
  732. XLINE: while (<>) {
  733. X
  734. X    # Wipe out surrounding whitespace.
  735. X
  736. X    s/[ \t]*(.*)\n$/$1/;
  737. X
  738. X    # Perhaps it's a label/comment.
  739. X
  740. X    if (/^:/) {
  741. X    s/^:[ \t]*//;
  742. X    $label = &make_label($_);
  743. X    if ($. == 1) {
  744. X        $toplabel = $label;
  745. X    }
  746. X    $_ = "$label:";
  747. X    if ($lastlinewaslabel++) {
  748. X        $indent += 4;
  749. X        print BODY &tab, ";\n";
  750. X        $indent -= 4;
  751. X    }
  752. X    if ($indent >= 2) {
  753. X        $indent -= 2;
  754. X        $indmod = 2;
  755. X    }
  756. X    next;
  757. X    } else {
  758. X    $lastlinewaslabel = '';
  759. X    }
  760. X
  761. X    # Look for one or two address clauses
  762. X
  763. X    $addr1 = '';
  764. X    $addr2 = '';
  765. X    if (s/^([0-9]+)//) {
  766. X    $addr1 = "$1";
  767. X    }
  768. X    elsif (s/^\$//) {
  769. X    $addr1 = 'eof()';
  770. X    }
  771. X    elsif (s|^/||) {
  772. X    $addr1 = &fetchpat('/');
  773. X    }
  774. X    if (s/^,//) {
  775. X    if (s/^([0-9]+)//) {
  776. X        $addr2 = "$1";
  777. X    } elsif (s/^\$//) {
  778. X        $addr2 = "eof()";
  779. X    } elsif (s|^/||) {
  780. X        $addr2 = &fetchpat('/');
  781. X    } else {
  782. X        &Die("Invalid second address at line $.\n");
  783. X    }
  784. X    $addr1 .= " .. $addr2";
  785. X    }
  786. X
  787. X    # Now we check for metacommands {, }, and ! and worry
  788. X    # about indentation.
  789. X
  790. X    s/^[ \t]+//;
  791. X    # a { to keep vi happy
  792. X    if ($_ eq '}') {
  793. X    $indent -= 4;
  794. X    next;
  795. X    }
  796. X    if (s/^!//) {
  797. X    $if = 'unless';
  798. X    $else = "$r else $l\n";
  799. X    } else {
  800. X    $if = 'if';
  801. X    $else = '';
  802. X    }
  803. X    if (s/^{//) {    # a } to keep vi happy
  804. X    $indmod = 4;
  805. X    $redo = $_;
  806. X    $_ = '';
  807. X    $rmaybe = '';
  808. X    } else {
  809. X    $rmaybe = "\n$r";
  810. X    if ($addr2 || $addr1) {
  811. X        $space = ' ' x $shiftwidth;
  812. X    } else {
  813. X        $space = '';
  814. X    }
  815. X    $_ = &transmogrify();
  816. X    }
  817. X
  818. X    # See if we can optimize to modifier form.
  819. X
  820. X    if ($addr1) {
  821. X    if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
  822. X      $_ !~ / if / && $_ !~ / unless /) {
  823. X        s/;$/ $if $addr1;/;
  824. X        $_ = substr($_,$shiftwidth,1000);
  825. X    } else {
  826. X        $_ = "$if ($addr1) $l\n$change$_$rmaybe";
  827. X    }
  828. X    $change = '';
  829. X    next LINE;
  830. X    }
  831. X} continue {
  832. X    @lines = split(/\n/,$_);
  833. X    for (@lines) {
  834. X    unless (s/^ *<<--//) {
  835. X        print BODY &tab;
  836. X    }
  837. X    print BODY $_, "\n";
  838. X    }
  839. X    $indent += $indmod;
  840. X    $indmod = 0;
  841. X    if ($redo) {
  842. X    $_ = $redo;
  843. X    $redo = '';
  844. X    redo LINE;
  845. X    }
  846. X}
  847. Xif ($lastlinewaslabel++) {
  848. X    $indent += 4;
  849. X    print BODY &tab, ";\n";
  850. X    $indent -= 4;
  851. X}
  852. X
  853. Xprint BODY "}\n";
  854. Xif ($appendseen || $tseen || !$assumen) {
  855. X    $printit++ if $dseen || (!$assumen && !$assumep);
  856. X    print BODY <<'EOT';
  857. X
  858. Xcontinue {
  859. X#ifdef PRINTIT
  860. X#ifdef DSEEN
  861. X#ifdef ASSUMEP
  862. X    print if $printit++;
  863. X#else
  864. X    if ($printit)
  865. X    { print; }
  866. X    else
  867. X    { $printit++ unless $nflag; }
  868. X#endif
  869. X#else
  870. X    print if $printit;
  871. X#endif
  872. X#else
  873. X    print;
  874. X#endif
  875. X#ifdef TSEEN
  876. X    $tflag = '';
  877. X#endif
  878. X#ifdef APPENDSEEN
  879. X    if ($atext) { print $atext; $atext = ''; }
  880. X#endif
  881. X}
  882. XEOT
  883. X}
  884. X
  885. Xclose BODY;
  886. X
  887. Xunless ($debug) {
  888. X    open(HEAD,">/tmp/sperl2$$.c")
  889. X      || &Die("Can't open temp file 2: $!\n");
  890. X    print HEAD "#define PRINTIT\n" if ($printit);
  891. X    print HEAD "#define APPENDSEEN\n" if ($appendseen);
  892. X    print HEAD "#define TSEEN\n" if ($tseen);
  893. X    print HEAD "#define DSEEN\n" if ($dseen);
  894. X    print HEAD "#define ASSUMEN\n" if ($assumen);
  895. X    print HEAD "#define ASSUMEP\n" if ($assumep);
  896. X    if ($opens) {print HEAD "$opens\n";}
  897. X    open(BODY,"/tmp/sperl$$")
  898. X      || &Die("Can't reopen temp file: $!\n");
  899. X    while (<BODY>) {
  900. X    print HEAD $_;
  901. X    }
  902. X    close HEAD;
  903. X
  904. X    print <<"EOT";
  905. X#!$bin/perl
  906. Xeval 'exec $bin/perl -S \$0 \$*'
  907. X    if \$running_under_some_shell;
  908. X
  909. XEOT
  910. X    open(BODY,"cc -E /tmp/sperl2$$.c |") ||
  911. X    &Die("Can't reopen temp file: $!\n");
  912. X    while (<BODY>) {
  913. X    /^# [0-9]/ && next;
  914. X    /^[ \t]*$/ && next;
  915. X    s/^<><>//;
  916. X    print;
  917. X    }
  918. X}
  919. X
  920. X&Cleanup;
  921. Xexit;
  922. X
  923. Xsub Cleanup {
  924. X    chdir "/tmp";
  925. X    unlink "sperl$$", "sperl2$$", "sperl2$$.c";
  926. X}
  927. Xsub Die {
  928. X    &Cleanup;
  929. X    die $_[0];
  930. X}
  931. Xsub tab {
  932. X    "\t" x ($indent / 8) . ' ' x ($indent % 8);
  933. X}
  934. Xsub make_filehandle {
  935. X    local($_) = $_[0];
  936. X    local($fname) = $_;
  937. X    s/[^a-zA-Z]/_/g;
  938. X    s/^_*//;
  939. X    substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
  940. X    if (!$seen{$_}) {
  941. X    $opens .= <<"EOT";
  942. Xopen($_,'>$fname') || die "Can't create $fname";
  943. XEOT
  944. X    }
  945. X    $seen{$_} = $_;
  946. X}
  947. X
  948. Xsub make_label {
  949. X    local($label) = @_;
  950. X    $label =~ s/[^a-zA-Z0-9]/_/g;
  951. X    if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
  952. X    $label = substr($label,0,8);
  953. X
  954. X    # Could be a reserved word, so capitalize it.
  955. X    substr($label,0,1) =~ y/a-z/A-Z/
  956. X      if $label =~ /^[a-z]/;
  957. X
  958. X    $label;
  959. X}
  960. X
  961. Xsub transmogrify {
  962. X    {    # case
  963. X    if (/^d/) {
  964. X        $dseen++;
  965. X        chop($_ = <<'EOT');
  966. X<<--#ifdef PRINTIT
  967. X$printit = '';
  968. X<<--#endif
  969. Xnext LINE;
  970. XEOT
  971. X        next;
  972. X    }
  973. X
  974. X    if (/^n/) {
  975. X        chop($_ = <<'EOT');
  976. X<<--#ifdef PRINTIT
  977. X<<--#ifdef DSEEN
  978. X<<--#ifdef ASSUMEP
  979. Xprint if $printit++;
  980. X<<--#else
  981. Xif ($printit)
  982. X    { print; }
  983. Xelse
  984. X    { $printit++ unless $nflag; }
  985. X<<--#endif
  986. X<<--#else
  987. Xprint if $printit;
  988. X<<--#endif
  989. X<<--#else
  990. Xprint;
  991. X<<--#endif
  992. X<<--#ifdef APPENDSEEN
  993. Xif ($atext) {print $atext; $atext = '';}
  994. X<<--#endif
  995. X$_ = <>;
  996. X<<--#ifdef TSEEN
  997. X$tflag = '';
  998. X<<--#endif
  999. XEOT
  1000. X        next;
  1001. X    }
  1002. X
  1003. X    if (/^a/) {
  1004. X        $appendseen++;
  1005. X        $command = $space . '$atext .=' . "\n<<--'";
  1006. X        $lastline = 0;
  1007. X        while (<>) {
  1008. X        s/^[ \t]*//;
  1009. X        s/^[\\]//;
  1010. X        unless (s|\\$||) { $lastline = 1;}
  1011. X        s/'/\\'/g;
  1012. X        s/^([ \t]*\n)/<><>$1/;
  1013. X        $command .= $_;
  1014. X        $command .= '<<--';
  1015. X        last if $lastline;
  1016. X        }
  1017. X        $_ = $command . "';";
  1018. X        last;
  1019. X    }
  1020. X
  1021. X    if (/^[ic]/) {
  1022. X        if (/^c/) { $change = 1; }
  1023. X        $addr1 = '$iter = (' . $addr1 . ')';
  1024. X        $command = $space . 'if ($iter == 1) { print'
  1025. X          . "\n<<--'";
  1026. X        $lastline = 0;
  1027. X        while (<>) {
  1028. X        s/^[ \t]*//;
  1029. X        s/^[\\]//;
  1030. X        unless (s/\\$//) { $lastline = 1;}
  1031. X        s/'/\\'/g;
  1032. X        s/^([ \t]*\n)/<><>$1/;
  1033. X        $command .= $_;
  1034. X        $command .= '<<--';
  1035. X        last if $lastline;
  1036. X        }
  1037. X        $_ = $command . "';}";
  1038. X        if ($change) {
  1039. X        $dseen++;
  1040. X        $change = "$_\n";
  1041. X        chop($_ = <<"EOT");
  1042. X<<--#ifdef PRINTIT
  1043. X$space\$printit = '';
  1044. X<<--#endif
  1045. X${space}next LINE;
  1046. XEOT
  1047. X        }
  1048. X        last;
  1049. X    }
  1050. X
  1051. X    if (/^s/) {
  1052. X        $delim = substr($_,1,1);
  1053. X        $len = length($_);
  1054. X        $repl = $end = 0;
  1055. X        $inbracket = 0;
  1056. X        for ($i = 2; $i < $len; $i++) {
  1057. X        $c = substr($_,$i,1);
  1058. X        if ($c eq $delim) {
  1059. X            if ($inbracket) {
  1060. X            substr($_, $i, 0) = '\\';
  1061. X            $i++;
  1062. X            $len++;
  1063. X            }
  1064. X            else {
  1065. X            if ($repl) {
  1066. X                $end = $i;
  1067. X                last;
  1068. X            } else {
  1069. X                $repl = $i;
  1070. X            }
  1071. X            }
  1072. X        }
  1073. X        elsif ($c eq '\\') {
  1074. X            $i++;
  1075. X            if ($i >= $len) {
  1076. X            $_ .= 'n';
  1077. X            $_ .= <>;
  1078. X            $len = length($_);
  1079. X            $_ = substr($_,0,--$len);
  1080. X            }
  1081. X            elsif (substr($_,$i,1) =~ /^[n]$/) {
  1082. X            ;
  1083. X            }
  1084. X            elsif (!$repl &&
  1085. X              substr($_,$i,1) =~ /^[(){}\w]$/) {
  1086. X            $i--;
  1087. X            $len--;
  1088. X            substr($_, $i, 1) = '';
  1089. X            }
  1090. X            elsif (!$repl &&
  1091. X              substr($_,$i,1) =~ /^[<>]$/) {
  1092. X            substr($_,$i,1) = 'b';
  1093. X            }
  1094. X        }
  1095. X        elsif ($c eq '[' && !$repl) {
  1096. X            $i++ if substr($_,$i,1) eq '^';
  1097. X            $i++ if substr($_,$i,1) eq ']';
  1098. X            $inbracket = 1;
  1099. X        }
  1100. X        elsif ($c eq ']') {
  1101. X            $inbracket = 0;
  1102. X        }
  1103. X        elsif (!$repl && index("()+",$c) >= 0) {
  1104. X            substr($_, $i, 0) = '\\';
  1105. X            $i++;
  1106. X            $len++;
  1107. X        }
  1108. X        }
  1109. X        &Die("Malformed substitution at line $.\n")
  1110. X          unless $end;
  1111. X        $pat = substr($_, 0, $repl + 1);
  1112. X        $repl = substr($_, $repl+1, $end-$repl-1);
  1113. X        $end = substr($_, $end + 1, 1000);
  1114. X        $dol = '$';
  1115. X        $repl =~ s/\$/\\$/;
  1116. X        $repl =~ s'&'$&'g;
  1117. X        $repl =~ s/[\\]([0-9])/$dol$1/g;
  1118. X        $subst = "$pat$repl$delim";
  1119. X        $cmd = '';
  1120. X        while ($end) {
  1121. X        if ($end =~ s/^g//) {
  1122. X            $subst .= 'g';
  1123. X            next;
  1124. X        }
  1125. X        if ($end =~ s/^p//) {
  1126. X            $cmd .= ' && (print)';
  1127. X            next;
  1128. X        }
  1129. X        if ($end =~ s/^w[ \t]*//) {
  1130. X            $fh = &make_filehandle($end);
  1131. X            $cmd .= " && (print $fh \$_)";
  1132. X            $end = '';
  1133. X            next;
  1134. X        }
  1135. X        &Die("Unrecognized substitution command".
  1136. X          "($end) at line $.\n");
  1137. X        }
  1138. X        chop ($_ = <<"EOT");
  1139. X<<--#ifdef TSEEN
  1140. X$subst && \$tflag++$cmd;
  1141. X<<--#else
  1142. X$subst$cmd;
  1143. X<<--#endif
  1144. XEOT
  1145. X        next;
  1146. X    }
  1147. X
  1148. X    if (/^p/) {
  1149. X        $_ = 'print;';
  1150. X        next;
  1151. X    }
  1152. X
  1153. X    if (/^w/) {
  1154. X        s/^w[ \t]*//;
  1155. X        $fh = &make_filehandle($_);
  1156. X        $_ = "print $fh \$_;";
  1157. X        next;
  1158. X    }
  1159. X
  1160. X    if (/^r/) {
  1161. X        $appendseen++;
  1162. X        s/^r[ \t]*//;
  1163. X        $file = $_;
  1164. X        $_ = "\$atext .= `cat $file 2>/dev/null`;";
  1165. X        next;
  1166. X    }
  1167. X
  1168. X    if (/^P/) {
  1169. X        $_ = 'print $1 if /(^.*\n)/;';
  1170. X        next;
  1171. X    }
  1172. X
  1173. X    if (/^D/) {
  1174. X        chop($_ = <<'EOT');
  1175. Xs/^.*\n//;
  1176. Xredo LINE if $_;
  1177. Xnext LINE;
  1178. XEOT
  1179. X        next;
  1180. X    }
  1181. X
  1182. X    if (/^N/) {
  1183. X        chop($_ = <<'EOT');
  1184. X$_ .= <>;
  1185. X<<--#ifdef TSEEN
  1186. X$tflag = '';
  1187. X<<--#endif
  1188. XEOT
  1189. X        next;
  1190. X    }
  1191. X
  1192. X    if (/^h/) {
  1193. X        $_ = '$hold = $_;';
  1194. X        next;
  1195. X    }
  1196. X
  1197. X    if (/^H/) {
  1198. X        $_ = '$hold .= $_ ? $_ : "\n";';
  1199. X        next;
  1200. X    }
  1201. X
  1202. X    if (/^g/) {
  1203. X        $_ = '$_ = $hold;';
  1204. X        next;
  1205. X    }
  1206. X
  1207. X    if (/^G/) {
  1208. X        $_ = '$_ .= $hold ? $hold : "\n";';
  1209. X        next;
  1210. X    }
  1211. X
  1212. X    if (/^x/) {
  1213. X        $_ = '($_, $hold) = ($hold, $_);';
  1214. X        next;
  1215. X    }
  1216. X
  1217. X    if (/^b$/) {
  1218. X        $_ = 'next LINE;';
  1219. X        next;
  1220. X    }
  1221. X
  1222. X    if (/^b/) {
  1223. X        s/^b[ \t]*//;
  1224. X        $lab = &make_label($_);
  1225. X        if ($lab eq $toplabel) {
  1226. X        $_ = 'redo LINE;';
  1227. X        } else {
  1228. X        $_ = "goto $lab;";
  1229. X        }
  1230. X        next;
  1231. X    }
  1232. X
  1233. X    if (/^t$/) {
  1234. X        $_ = 'next LINE if $tflag;';
  1235. X        $tseen++;
  1236. X        next;
  1237. X    }
  1238. X
  1239. X    if (/^t/) {
  1240. X        s/^t[ \t]*//;
  1241. X        $lab = &make_label($_);
  1242. X        $_ = q/if ($tflag) {$tflag = ''; /;
  1243. X        if ($lab eq $toplabel) {
  1244. X        $_ .= 'redo LINE;}';
  1245. X        } else {
  1246. X        $_ .= "goto $lab;}";
  1247. X        }
  1248. X        $tseen++;
  1249. X        next;
  1250. X    }
  1251. X
  1252. X    if (/^=/) {
  1253. X        $_ = 'print "$.\n";';
  1254. X        next;
  1255. X    }
  1256. X
  1257. X    if (/^q/) {
  1258. X        chop($_ = <<'EOT');
  1259. Xclose(ARGV);
  1260. X@ARGV = ();
  1261. Xnext LINE;
  1262. XEOT
  1263. X        next;
  1264. X    }
  1265. X    } continue {
  1266. X    if ($space) {
  1267. X        s/^/$space/;
  1268. X        s/(\n)(.)/$1$space$2/g;
  1269. X    }
  1270. X    last;
  1271. X    }
  1272. X    $_;
  1273. X}
  1274. X
  1275. Xsub fetchpat {
  1276. X    local($outer) = @_;
  1277. X    local($addr) = $outer;
  1278. X    local($inbracket);
  1279. X    local($prefix,$delim,$ch);
  1280. X
  1281. X    # Process pattern one potential delimiter at a time.
  1282. X
  1283. X    DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
  1284. X    $prefix = $1;
  1285. X    $delim = $2;
  1286. X    if ($delim eq '\\') {
  1287. X        s/(.)//;
  1288. X        $ch = $1;
  1289. X        $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
  1290. X        $ch = 'b' if $ch =~ /^[<>]$/;
  1291. X        $delim .= $ch;
  1292. X    }
  1293. X    elsif ($delim eq '[') {
  1294. X        $inbracket = 1;
  1295. X        s/^\^// && ($delim .= '^');
  1296. X        s/^]// && ($delim .= ']');
  1297. X    }
  1298. X    elsif ($delim eq ']') {
  1299. X        $inbracket = 0;
  1300. X    }
  1301. X    elsif ($inbracket || $delim ne $outer) {
  1302. X        $delim = '\\' . $delim;
  1303. X    }
  1304. X    $addr .= $prefix;
  1305. X    $addr .= $delim;
  1306. X    if ($delim eq $outer && !$inbracket) {
  1307. X        last DELIM;
  1308. X    }
  1309. X    }
  1310. X    $addr;
  1311. X}
  1312. X
  1313. X!NO!SUBS!
  1314. Xchmod 755 s2p
  1315. X$eunicefix s2p
  1316. !STUFFY!FUNK!
  1317. echo Extracting x2p/a2p.y
  1318. sed >x2p/a2p.y <<'!STUFFY!FUNK!' -e 's/X//'
  1319. X%{
  1320. X/* $Header: a2p.y,v 4.0 91/03/20 01:57:21 lwall Locked $
  1321. X *
  1322. X *    Copyright (c) 1989, Larry Wall
  1323. X *
  1324. X *    You may distribute under the terms of the GNU General Public License
  1325. X *    as specified in the README file that comes with the perl 3.0 kit.
  1326. X *
  1327. X * $Log:    a2p.y,v $
  1328. X * Revision 4.0  91/03/20  01:57:21  lwall
  1329. X * 4.0 baseline.
  1330. X * 
  1331. X */
  1332. X
  1333. X#include "INTERN.h"
  1334. X#include "a2p.h"
  1335. X
  1336. Xint root;
  1337. Xint begins = Nullop;
  1338. Xint ends = Nullop;
  1339. X
  1340. X%}
  1341. X%token BEGIN END
  1342. X%token REGEX
  1343. X%token SEMINEW NEWLINE COMMENT
  1344. X%token FUN1 FUNN GRGR
  1345. X%token PRINT PRINTF SPRINTF SPLIT
  1346. X%token IF ELSE WHILE FOR IN
  1347. X%token EXIT NEXT BREAK CONTINUE RET
  1348. X%token GETLINE DO SUB GSUB MATCH
  1349. X%token FUNCTION USERFUN DELETE
  1350. X
  1351. X%right ASGNOP
  1352. X%right '?' ':'
  1353. X%left OROR
  1354. X%left ANDAND
  1355. X%left IN
  1356. X%left NUMBER VAR SUBSTR INDEX
  1357. X%left MATCHOP
  1358. X%left RELOP '<' '>'
  1359. X%left OR
  1360. X%left STRING
  1361. X%left '+' '-'
  1362. X%left '*' '/' '%'
  1363. X%right UMINUS
  1364. X%left NOT
  1365. X%right '^'
  1366. X%left INCR DECR
  1367. X%left FIELD VFIELD
  1368. X
  1369. X%%
  1370. X
  1371. Xprogram    : junk hunks
  1372. X        { root = oper4(OPROG,$1,begins,$2,ends); }
  1373. X    ;
  1374. X
  1375. Xbegin    : BEGIN '{' maybe states '}' junk
  1376. X        { begins = oper4(OJUNK,begins,$3,$4,$6); in_begin = FALSE;
  1377. X            $$ = Nullop; }
  1378. X    ;
  1379. X
  1380. Xend    : END '{' maybe states '}'
  1381. X        { ends = oper3(OJUNK,ends,$3,$4); $$ = Nullop; }
  1382. X    | end NEWLINE
  1383. X        { $$ = $1; }
  1384. X    ;
  1385. X
  1386. Xhunks    : hunks hunk junk
  1387. X        { $$ = oper3(OHUNKS,$1,$2,$3); }
  1388. X    | /* NULL */
  1389. X        { $$ = Nullop; }
  1390. X    ;
  1391. X
  1392. Xhunk    : patpat
  1393. X        { $$ = oper1(OHUNK,$1); need_entire = TRUE; }
  1394. X    | patpat '{' maybe states '}'
  1395. X        { $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); }
  1396. X    | FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}'
  1397. X        { fixfargs($2,$4,0); $$ = oper5(OUSERDEF,$2,$4,$6,$8,$9); }
  1398. X    | '{' maybe states '}'
  1399. X        { $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); }
  1400. X    | begin
  1401. X    | end
  1402. X    ;
  1403. X
  1404. Xarg_list: expr_list
  1405. X        { $$ = rememberargs($$); }
  1406. X    ;
  1407. X
  1408. Xpatpat    : cond
  1409. X        { $$ = oper1(OPAT,$1); }
  1410. X    | cond ',' cond
  1411. X        { $$ = oper2(ORANGE,$1,$3); }
  1412. X    ;
  1413. X
  1414. Xcond    : expr
  1415. X    | match
  1416. X    | rel
  1417. X    | compound_cond
  1418. X    ;
  1419. X
  1420. Xcompound_cond
  1421. X    : '(' compound_cond ')'
  1422. X        { $$ = oper1(OCPAREN,$2); }
  1423. X    | cond ANDAND maybe cond
  1424. X        { $$ = oper3(OCANDAND,$1,$3,$4); }
  1425. X    | cond OROR maybe cond
  1426. X        { $$ = oper3(OCOROR,$1,$3,$4); }
  1427. X    | NOT cond
  1428. X        { $$ = oper1(OCNOT,$2); }
  1429. X    ;
  1430. X
  1431. Xrel    : expr RELOP expr
  1432. X        { $$ = oper3(ORELOP,$2,$1,$3); }
  1433. X    | expr '>' expr
  1434. X        { $$ = oper3(ORELOP,string(">",1),$1,$3); }
  1435. X    | expr '<' expr
  1436. X        { $$ = oper3(ORELOP,string("<",1),$1,$3); }
  1437. X    | '(' rel ')'
  1438. X        { $$ = oper1(ORPAREN,$2); }
  1439. X    ;
  1440. X
  1441. Xmatch    : expr MATCHOP expr
  1442. X        { $$ = oper3(OMATCHOP,$2,$1,$3); }
  1443. X    | expr MATCHOP REGEX
  1444. X        { $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); }
  1445. X    | REGEX        %prec MATCHOP
  1446. X        { $$ = oper1(OREGEX,$1); }
  1447. X    | '(' match ')'
  1448. X        { $$ = oper1(OMPAREN,$2); }
  1449. X    ;
  1450. X
  1451. Xexpr    : term
  1452. X        { $$ = $1; }
  1453. X    | expr term
  1454. X        { $$ = oper2(OCONCAT,$1,$2); }
  1455. X    | variable ASGNOP cond
  1456. X        { $$ = oper3(OASSIGN,$2,$1,$3);
  1457. X            if ((ops[$1].ival & 255) == OFLD)
  1458. X                lval_field = TRUE;
  1459. X            if ((ops[$1].ival & 255) == OVFLD)
  1460. X                lval_field = TRUE;
  1461. X        }
  1462. X    ;
  1463. X
  1464. Xterm    : variable
  1465. X        { $$ = $1; }
  1466. X    | NUMBER
  1467. X        { $$ = oper1(ONUM,$1); }
  1468. X    | STRING
  1469. X        { $$ = oper1(OSTR,$1); }
  1470. X    | term '+' term
  1471. X        { $$ = oper2(OADD,$1,$3); }
  1472. X    | term '-' term
  1473. X        { $$ = oper2(OSUBTRACT,$1,$3); }
  1474. X    | term '*' term
  1475. X        { $$ = oper2(OMULT,$1,$3); }
  1476. X    | term '/' term
  1477. X        { $$ = oper2(ODIV,$1,$3); }
  1478. X    | term '%' term
  1479. X        { $$ = oper2(OMOD,$1,$3); }
  1480. X    | term '^' term
  1481. X        { $$ = oper2(OPOW,$1,$3); }
  1482. X    | term IN VAR
  1483. X        { $$ = oper2(ODEFINED,aryrefarg($3),$1); }
  1484. X    | term '?' term ':' term
  1485. X        { $$ = oper3(OCOND,$1,$3,$5); }
  1486. X    | variable INCR
  1487. X        { $$ = oper1(OPOSTINCR,$1); }
  1488. X    | variable DECR
  1489. X        { $$ = oper1(OPOSTDECR,$1); }
  1490. X    | INCR variable
  1491. X        { $$ = oper1(OPREINCR,$2); }
  1492. X    | DECR variable
  1493. X        { $$ = oper1(OPREDECR,$2); }
  1494. X    | '-' term %prec UMINUS
  1495. X        { $$ = oper1(OUMINUS,$2); }
  1496. X    | '+' term %prec UMINUS
  1497. X        { $$ = oper1(OUPLUS,$2); }
  1498. X    | '(' cond ')'
  1499. X        { $$ = oper1(OPAREN,$2); }
  1500. X    | GETLINE
  1501. X        { $$ = oper0(OGETLINE); }
  1502. X    | GETLINE VAR
  1503. X        { $$ = oper1(OGETLINE,$2); }
  1504. X    | GETLINE '<' expr
  1505. X        { $$ = oper3(OGETLINE,Nullop,string("<",1),$3);
  1506. X            if (ops[$3].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
  1507. X    | GETLINE VAR '<' expr
  1508. X        { $$ = oper3(OGETLINE,$2,string("<",1),$4);
  1509. X            if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
  1510. X    | term 'p' GETLINE
  1511. X        { $$ = oper3(OGETLINE,Nullop,string("|",1),$1);
  1512. X            if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
  1513. X    | term 'p' GETLINE VAR
  1514. X        { $$ = oper3(OGETLINE,$4,string("|",1),$1);
  1515. X            if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
  1516. X    | FUN1
  1517. X        { $$ = oper0($1); need_entire = do_chop = TRUE; }
  1518. X    | FUN1 '(' ')'
  1519. X        { $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; }
  1520. X    | FUN1 '(' expr ')'
  1521. X        { $$ = oper1($1,$3); }
  1522. X    | FUNN '(' expr_list ')'
  1523. X        { $$ = oper1($1,$3); }
  1524. X    | USERFUN '(' expr_list ')'
  1525. X        { $$ = oper2(OUSERFUN,$1,$3); }
  1526. X    | SPRINTF expr_list
  1527. X        { $$ = oper1(OSPRINTF,$2); }
  1528. X    | SUBSTR '(' expr ',' expr ',' expr ')'
  1529. X        { $$ = oper3(OSUBSTR,$3,$5,$7); }
  1530. X    | SUBSTR '(' expr ',' expr ')'
  1531. X        { $$ = oper2(OSUBSTR,$3,$5); }
  1532. X    | SPLIT '(' expr ',' VAR ',' expr ')'
  1533. X        { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),$7); }
  1534. X    | SPLIT '(' expr ',' VAR ',' REGEX ')'
  1535. X        { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),oper1(OREGEX,$7));}
  1536. X    | SPLIT '(' expr ',' VAR ')'
  1537. X        { $$ = oper2(OSPLIT,$3,aryrefarg(numary($5))); }
  1538. X    | INDEX '(' expr ',' expr ')'
  1539. X        { $$ = oper2(OINDEX,$3,$5); }
  1540. X    | MATCH '(' expr ',' REGEX ')'
  1541. X        { $$ = oper2(OMATCH,$3,oper1(OREGEX,$5)); }
  1542. X    | MATCH '(' expr ',' expr ')'
  1543. X        { $$ = oper2(OMATCH,$3,$5); }
  1544. X    | SUB '(' expr ',' expr ')'
  1545. X        { $$ = oper2(OSUB,$3,$5); }
  1546. X    | SUB '(' REGEX ',' expr ')'
  1547. X        { $$ = oper2(OSUB,oper1(OREGEX,$3),$5); }
  1548. X    | GSUB '(' expr ',' expr ')'
  1549. X        { $$ = oper2(OGSUB,$3,$5); }
  1550. X    | GSUB '(' REGEX ',' expr ')'
  1551. X        { $$ = oper2(OGSUB,oper1(OREGEX,$3),$5); }
  1552. X    | SUB '(' expr ',' expr ',' expr ')'
  1553. X        { $$ = oper3(OSUB,$3,$5,$7); }
  1554. X    | SUB '(' REGEX ',' expr ',' expr ')'
  1555. X        { $$ = oper3(OSUB,oper1(OREGEX,$3),$5,$7); }
  1556. X    | GSUB '(' expr ',' expr ',' expr ')'
  1557. X        { $$ = oper3(OGSUB,$3,$5,$7); }
  1558. X    | GSUB '(' REGEX ',' expr ',' expr ')'
  1559. X        { $$ = oper3(OGSUB,oper1(OREGEX,$3),$5,$7); }
  1560. X    ;
  1561. X
  1562. Xvariable: VAR
  1563. X        { $$ = oper1(OVAR,$1); }
  1564. X    | VAR '[' expr_list ']'
  1565. X        { $$ = oper2(OVAR,aryrefarg($1),$3); }
  1566. X    | FIELD
  1567. X        { $$ = oper1(OFLD,$1); }
  1568. X    | VFIELD term
  1569. X        { $$ = oper1(OVFLD,$2); }
  1570. X    ;
  1571. X
  1572. Xexpr_list
  1573. X    : expr
  1574. X    | clist
  1575. X    | /* NULL */
  1576. X        { $$ = Nullop; }
  1577. X    ;
  1578. X
  1579. Xclist    : expr ',' maybe expr
  1580. X        { $$ = oper3(OCOMMA,$1,$3,$4); }
  1581. X    | clist ',' maybe expr
  1582. X        { $$ = oper3(OCOMMA,$1,$3,$4); }
  1583. X    | '(' clist ')'        /* these parens are invisible */
  1584. X        { $$ = $2; }
  1585. X    ;
  1586. X
  1587. Xjunk    : junk hunksep
  1588. X        { $$ = oper2(OJUNK,$1,$2); }
  1589. X    | /* NULL */
  1590. X        { $$ = Nullop; }
  1591. X    ;
  1592. X
  1593. Xhunksep : ';'
  1594. X        { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
  1595. X    | SEMINEW
  1596. X        { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
  1597. X    | NEWLINE
  1598. X        { $$ = oper0(ONEWLINE); }
  1599. X    | COMMENT
  1600. X        { $$ = oper1(OCOMMENT,$1); }
  1601. X    ;
  1602. X
  1603. Xmaybe    : maybe nlstuff
  1604. X        { $$ = oper2(OJUNK,$1,$2); }
  1605. X    | /* NULL */
  1606. X        { $$ = Nullop; }
  1607. X    ;
  1608. X
  1609. Xnlstuff : NEWLINE
  1610. X        { $$ = oper0(ONEWLINE); }
  1611. X    | COMMENT
  1612. X        { $$ = oper1(OCOMMENT,$1); }
  1613. X    ;
  1614. X
  1615. Xseparator
  1616. X    : ';' maybe
  1617. X        { $$ = oper2(OJUNK,oper0(OSEMICOLON),$2); }
  1618. X    | SEMINEW maybe
  1619. X        { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
  1620. X    | NEWLINE maybe
  1621. X        { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
  1622. X    | COMMENT maybe
  1623. X        { $$ = oper2(OJUNK,oper1(OSCOMMENT,$1),$2); }
  1624. X    ;
  1625. X
  1626. Xstates    : states statement
  1627. X        { $$ = oper2(OSTATES,$1,$2); }
  1628. X    | /* NULL */
  1629. X        { $$ = Nullop; }
  1630. X    ;
  1631. X
  1632. Xstatement
  1633. X    : simple separator maybe
  1634. X        { $$ = oper2(OJUNK,oper2(OSTATE,$1,$2),$3); }
  1635. X    | ';' maybe
  1636. X        { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),$2)); }
  1637. X    | SEMINEW maybe
  1638. X        { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),$2)); }
  1639. X    | compound
  1640. X    ;
  1641. X
  1642. Xsimpnull: simple
  1643. X    | /* NULL */
  1644. X        { $$ = Nullop; }
  1645. X    ;
  1646. X
  1647. Xsimple
  1648. X    : expr
  1649. X    | PRINT expr_list redir expr
  1650. X        { $$ = oper3(OPRINT,$2,$3,$4);
  1651. X            do_opens = TRUE;
  1652. X            saw_ORS = saw_OFS = TRUE;
  1653. X            if (!$2) need_entire = TRUE;
  1654. X            if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
  1655. X    | PRINT expr_list
  1656. X        { $$ = oper1(OPRINT,$2);
  1657. X            if (!$2) need_entire = TRUE;
  1658. X            saw_ORS = saw_OFS = TRUE;
  1659. X        }
  1660. X    | PRINTF expr_list redir expr
  1661. X        { $$ = oper3(OPRINTF,$2,$3,$4);
  1662. X            do_opens = TRUE;
  1663. X            if (!$2) need_entire = TRUE;
  1664. X            if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
  1665. X    | PRINTF expr_list
  1666. X        { $$ = oper1(OPRINTF,$2);
  1667. X            if (!$2) need_entire = TRUE;
  1668. X        }
  1669. X    | BREAK
  1670. X        { $$ = oper0(OBREAK); }
  1671. X    | NEXT
  1672. X        { $$ = oper0(ONEXT); }
  1673. X    | EXIT
  1674. X        { $$ = oper0(OEXIT); }
  1675. X    | EXIT expr
  1676. X        { $$ = oper1(OEXIT,$2); }
  1677. X    | CONTINUE
  1678. X        { $$ = oper0(OCONTINUE); }
  1679. X    | RET
  1680. X        { $$ = oper0(ORETURN); }
  1681. X    | RET expr
  1682. X        { $$ = oper1(ORETURN,$2); }
  1683. X    | DELETE VAR '[' expr ']'
  1684. X        { $$ = oper2(ODELETE,aryrefarg($2),$4); }
  1685. X    ;
  1686. X
  1687. Xredir    : '>'    %prec FIELD
  1688. X        { $$ = oper1(OREDIR,string(">",1)); }
  1689. X    | GRGR
  1690. X        { $$ = oper1(OREDIR,string(">>",2)); }
  1691. X    | '|'
  1692. X        { $$ = oper1(OREDIR,string("|",1)); }
  1693. X    ;
  1694. X
  1695. Xcompound
  1696. X    : IF '(' cond ')' maybe statement
  1697. X        { $$ = oper2(OIF,$3,bl($6,$5)); }
  1698. X    | IF '(' cond ')' maybe statement ELSE maybe statement
  1699. X        { $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); }
  1700. X    | WHILE '(' cond ')' maybe statement
  1701. X        { $$ = oper2(OWHILE,$3,bl($6,$5)); }
  1702. X    | DO maybe statement WHILE '(' cond ')'
  1703. X        { $$ = oper2(ODO,bl($3,$2),$6); }
  1704. X    | FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement
  1705. X        { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); }
  1706. X    | FOR '(' simpnull ';'  ';' simpnull ')' maybe statement
  1707. X        { $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); }
  1708. X    | FOR '(' expr ')' maybe statement
  1709. X        { $$ = oper2(OFORIN,$3,bl($6,$5)); }
  1710. X    | '{' maybe states '}' maybe
  1711. X        { $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); }
  1712. X    ;
  1713. X
  1714. X%%
  1715. X#include "a2py.c"
  1716. !STUFFY!FUNK!
  1717. echo Extracting t/op/sort.t
  1718. sed >t/op/sort.t <<'!STUFFY!FUNK!' -e 's/X//'
  1719. X#!./perl
  1720. X
  1721. X# $Header: sort.t,v 4.0 91/03/20 01:54:38 lwall Locked $
  1722. X
  1723. Xprint "1..8\n";
  1724. X
  1725. Xsub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; }
  1726. X
  1727. X@harry = ('dog','cat','x','Cain','Abel');
  1728. X@george = ('gone','chased','yz','Punished','Axed');
  1729. X
  1730. X$x = join('', sort @harry);
  1731. Xprint ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n");
  1732. X
  1733. X$x = join('', sort reverse @harry);
  1734. Xprint ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n");
  1735. X
  1736. X$x = join('', sort @george, 'to', @harry);
  1737. Xprint ($x eq 'AbelAxedCainPunishedcatchaseddoggonetoxyz'?"ok 3\n":"not ok 3\n");
  1738. X
  1739. X@a = ();
  1740. X@b = reverse @a;
  1741. Xprint ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n");
  1742. X
  1743. X@a = (1);
  1744. X@b = reverse @a;
  1745. Xprint ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n");
  1746. X
  1747. X@a = (1,2);
  1748. X@b = reverse @a;
  1749. Xprint ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n");
  1750. X
  1751. X@a = (1,2,3);
  1752. X@b = reverse @a;
  1753. Xprint ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n");
  1754. X
  1755. X@a = (1,2,3,4);
  1756. X@b = reverse @a;
  1757. Xprint ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n");
  1758. !STUFFY!FUNK!
  1759. echo " "
  1760. echo "End of kit 27 (of 36)"
  1761. cat /dev/null >kit27isdone
  1762. run=''
  1763. config=''
  1764. 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
  1765.     if test -f kit${iskit}isdone; then
  1766.     run="$run $iskit"
  1767.     else
  1768.     todo="$todo $iskit"
  1769.     fi
  1770. done
  1771. case $todo in
  1772.     '')
  1773.     echo "You have run all your kits.  Please read README and then type Configure."
  1774.     for combo in *:AA; do
  1775.         if test -f "$combo"; then
  1776.         realfile=`basename $combo :AA`
  1777.         cat $realfile:[A-Z][A-Z] >$realfile
  1778.         rm -rf $realfile:[A-Z][A-Z]
  1779.         fi
  1780.     done
  1781.     rm -rf kit*isdone
  1782.     chmod 755 Configure
  1783.     ;;
  1784.     *)  echo "You have run$run."
  1785.     echo "You still need to run$todo."
  1786.     ;;
  1787. esac
  1788. : Someone might mail this, so...
  1789. exit
  1790.  
  1791. exit 0 # Just in case...
  1792. -- 
  1793. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1794. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1795. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1796. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1797.