![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to terminal.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to terminal.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 root 1: ;; Terminal emulator for GNU Emacs.
2: ;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.
3: ;; Written by Richard Mlynarik, November 1986.
4:
5: ;; This file is part of GNU Emacs.
6:
7: ;; GNU Emacs is free software; you can redistribute it and/or modify
8: ;; it under the terms of the GNU General Public License as published by
9: ;; the Free Software Foundation; either version 1, or (at your option)
10: ;; any later version.
11:
12: ;; GNU Emacs is distributed in the hope that it will be useful,
13: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: ;; GNU General Public License for more details.
16:
17: ;; You should have received a copy of the GNU General Public License
18: ;; along with GNU Emacs; see the file COPYING. If not, write to
19: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21: ;;>>TODO
22: ;;>> terminfo?
23: ;;>> ** Nothing can be done about emacs' meta-lossage **
24: ;;>> (without redoing keymaps `sanely' -- ask Mly for details)
25:
26: ;;>> One probably wants to do setenv MORE -c when running with
27: ;;>> more-processing enabled.
28:
29: (provide 'terminal)
30: (require 'ehelp)
31:
32: (defvar terminal-escape-char ?\C-^
33: "*All characters except for this are passed verbatim through the
34: terminal-emulator. This character acts as a prefix for commands
35: to the emulator program itself. Type this character twice to send
36: it through the emulator. Type ? after typing it for a list of
37: possible commands.
38: This variable is local to each terminal-emulator buffer.")
39:
40: (defvar terminal-scrolling t
41: "*If non-nil, the terminal-emulator will `scroll' when output occurs
42: past the bottom of the screen. If nil, output will `wrap' to the top
43: of the screen.
44: This variable is local to each terminal-emulator buffer.")
45:
46: (defvar terminal-more-processing t
47: "*If non-nil, do more-processing.
48: This variable is local to each terminal-emulator buffer.")
49:
50: ;; If you are the sort of loser who uses scrolling without more breaks
51: ;; and expects to actually see anything, you should probably set this to
52: ;; around 400
53: (defvar terminal-redisplay-interval 5000
54: "*Maximum number of characters which will be processed by the
55: terminal-emulator before a screen redisplay is forced.
56: Set this to a large value for greater throughput,
57: set it smaller for more frequent updates but overall slower
58: performance.")
59:
60: (defvar terminal-more-break-insertion
61: "*** More break -- Press space to continue ***")
62:
63: (defvar terminal-escape-map nil)
64: (defvar terminal-map nil)
65: (defvar terminal-more-break-map nil)
66: (if terminal-map
67: nil
68: (let ((map (make-keymap)))
69: (fillarray map 'te-pass-through)
70: ;(define-key map "\C-l"
71: ; '(lambda () (interactive) (te-pass-through) (redraw-display)))
72: (setq terminal-map map)))
73:
74: ;(setq terminal-escape-map nil)
75: (if terminal-escape-map
76: nil
77: (let ((map (make-keymap)))
78: ;(fillarray map 'te-escape-extended-command-unread)
79: (fillarray map 'undefined)
80: (let ((s "0"))
81: (while (<= (aref s 0) ?9)
82: (define-key map s 'digit-argument)
83: (aset s 0 (1+ (aref s 0)))))
84: (define-key map "b" 'switch-to-buffer)
85: (define-key map "o" 'other-window)
86: (define-key map "e" 'te-set-escape-char)
87: (define-key map "\C-l" 'redraw-display)
88: (define-key map "\C-o" 'te-flush-pending-output)
89: (define-key map "m" 'te-toggle-more-processing)
90: (define-key map "x" 'te-escape-extended-command)
91: (define-key map "?" 'te-escape-help)
92: (define-key map (char-to-string help-char) 'te-escape-help)
93: (setq terminal-escape-map map)))
94:
95: (defvar te-escape-command-alist ())
96: ;(setq te-escape-command-alist ())
97: (if te-escape-command-alist
98: nil
99: (setq te-escape-command-alist
100: '(("Set Escape Character" . te-set-escape-char)
101: ("Refresh" . redraw-display)
102: ("Record Output" . te-set-output-log)
103: ("Photo" . te-set-output-log)
104: ("Tofu" . te-tofu) ;; confuse the uninitiated
105: ("Stuff Input" . te-stuff-string)
106: ("Flush Pending Output" . te-flush-pending-output)
107: ("Enable More Processing" . te-enable-more-processing)
108: ("Disable More Processing" . te-disable-more-processing)
109: ("Scroll at end of page" . te-do-scrolling)
110: ("Wrap at end of page" . te-do-wrapping)
111: ("Switch To Buffer" . switch-to-buffer)
112: ("Other Window" . other-window)
113: ("Kill Buffer" . kill-buffer)
114: ("Help" . te-escape-help)
115: ("Set Redisplay Interval" . te-set-redisplay-interval)
116: )))
117:
118: ;(setq terminal-more-break-map nil)
119: (if terminal-more-break-map
120: nil
121: (let ((map (make-keymap)))
122: (fillarray map 'te-more-break-unread)
123: (define-key map (char-to-string help-char) 'te-more-break-help)
124: (define-key map " " 'te-more-break-resume)
125: (define-key map "\C-l" 'redraw-display)
126: (define-key map "\C-o" 'te-more-break-flush-pending-output)
127: ;;>>> this isn't right
128: ;(define-key map "\^?" 'te-more-break-flush-pending-output) ;DEL
129: (define-key map "\r" 'te-more-break-advance-one-line)
130:
131: (setq terminal-more-break-map map)))
132:
133:
134: ;;;; escape map
135:
136: (defun te-escape ()
137: (interactive)
138: (let (s
139: (local (current-local-map))
140: (global (current-global-map)))
141: (unwind-protect
142: (progn
143: (use-global-map terminal-escape-map)
144: (use-local-map terminal-escape-map)
145: (setq s (read-key-sequence
146: (if prefix-arg
147: (format "Emacs Terminal escape> %d "
148: (prefix-numeric-value prefix-arg))
149: "Emacs Terminal escape> "))))
150: (use-global-map global)
151: (use-local-map local))
152: (message "")
153: (cond ((string= s (make-string 1 terminal-escape-char))
154: (setq last-command-char terminal-escape-char)
155: (let ((terminal-escape-char -259))
156: (te-pass-through)))
157: ((setq s (lookup-key terminal-escape-map s))
158: (call-interactively s)))))
159:
160: (defun te-escape-help ()
161: "Provide help on commands available after terminal-escape-char is typed."
162: (interactive)
163: (message "Terminal emulator escape help...")
164: (let ((char (single-key-description terminal-escape-char)))
165: (with-electric-help
166: (function (lambda ()
167: (princ (format "Terminal-emulator escape, invoked by \"%s\"
168: Type \"%s\" twice to send a single \"%s\" through.
169:
170: Other chars following \"%s\" are interpreted as follows:\n"
171: char char char char))
172:
173: (princ (substitute-command-keys "\\{terminal-escape-map}\n"))
174: (princ (format "\nSubcommands of \"%s\" (%s)\n"
175: (where-is-internal 'te-escape-extended-command
176: terminal-escape-map t)
177: 'te-escape-extended-command))
178: (let ((l (if (fboundp 'sortcar)
179: (sortcar (copy-sequence te-escape-command-alist)
180: 'string<)
181: (sort (copy-sequence te-escape-command-alist)
182: (function (lambda (a b)
183: (string< (car a) (car b))))))))
184: (while l
185: (let ((doc (or (documentation (cdr (car l)))
186: "Not documented")))
187: (if (string-match "\n" doc)
188: ;; just use first line of documentation
189: (setq doc (substring doc 0 (match-beginning 0))))
190: (princ " \"")
191: (princ (car (car l)))
192: (princ "\":\n ")
193: (princ doc)
194: (write-char ?\n))
195: (setq l (cdr l))))
196: nil)))))
197:
198:
199:
200: (defun te-escape-extended-command ()
201: (interactive)
202: (let ((c (let ((completion-ignore-case t))
203: (completing-read "terminal command: "
204: te-escape-command-alist
205: nil t))))
206: (if c
207: (catch 'foo
208: (setq c (downcase c))
209: (let ((l te-escape-command-alist))
210: (while l
211: (if (string= c (downcase (car (car l))))
212: (throw 'foo (call-interactively (cdr (car l))))
213: (setq l (cdr l)))))))))
214:
215: ;; not used.
216: (defun te-escape-extended-command-unread ()
217: (interactive)
218: (setq unread-command-char last-input-char)
219: (te-escape-extended-command))
220:
221: (defun te-set-escape-char (c)
222: "Change the terminal-emulator escape character."
223: (interactive "cSet escape character to: ")
224: (let ((o terminal-escape-char))
225: (message (if (= o c)
226: "\"%s\" is escape char"
227: "\"%s\" is now escape; \"%s\" passes though")
228: (single-key-description c)
229: (single-key-description o))
230: (setq terminal-escape-char c)))
231:
232:
233: (defun te-stuff-string (string)
234: "Read a string to send to through the terminal emulator
235: as though that string had been typed on the keyboard.
236:
237: Very poor man's file transfer protocol."
238: (interactive "sStuff string: ")
239: (process-send-string te-process string))
240:
241: (defun te-set-output-log (name)
242: "Record output from the terminal emulator in a buffer."
243: (interactive (list (if te-log-buffer
244: nil
245: (read-buffer "Record output in buffer: "
246: (format "%s output-log"
247: (buffer-name (current-buffer)))
248: nil))))
249: (if (or (null name) (equal name ""))
250: (progn (setq te-log-buffer nil)
251: (message "Output logging off."))
252: (if (get-buffer name)
253: nil
254: (save-excursion
255: (set-buffer (get-buffer-create name))
256: (fundamental-mode)
257: (buffer-flush-undo (current-buffer))
258: (erase-buffer)))
259: (setq te-log-buffer (get-buffer name))
260: (message "Recording terminal emulator output into buffer \"%s\""
261: (buffer-name te-log-buffer))))
262:
263: (defun te-tofu ()
264: "Discontinue output log."
265: (interactive)
266: (te-set-output-log nil))
267:
268:
269: (defun te-toggle (sym arg)
270: (set sym (cond ((not (numberp arg)) arg)
271: ((= arg 1) (not (symbol-value sym)))
272: ((< arg 0) nil)
273: (t t))))
274:
275: (defun te-toggle-more-processing (arg)
276: (interactive "p")
277: (message (if (te-toggle 'terminal-more-processing arg)
278: "More processing on" "More processing off"))
279: (if terminal-more-processing (setq te-more-count -1)))
280:
281: (defun te-toggle-scrolling (arg)
282: (interactive "p")
283: (message (if (te-toggle 'terminal-scrolling arg)
284: "Scroll at end of page" "Wrap at end of page")))
285:
286: (defun te-enable-more-processing ()
287: "Enable ** MORE ** processing"
288: (interactive)
289: (te-toggle-more-processing t))
290:
291: (defun te-disable-more-processing ()
292: "Disable ** MORE ** processing"
293: (interactive)
294: (te-toggle-more-processing nil))
295:
296: (defun te-do-scrolling ()
297: "Scroll at end of page (yuck)"
298: (interactive)
299: (te-toggle-scrolling t))
300:
301: (defun te-do-wrapping ()
302: "Wrap to top of window at end of page"
303: (interactive)
304: (te-toggle-scrolling nil))
305:
306:
307: (defun te-set-redisplay-interval (arg)
308: "Set the maximum interval (in output characters) between screen updates.
309: Set this number to large value for greater throughput,
310: set it smaller for more frequent updates (but overall slower performance."
311: (interactive "NMax number of output chars between redisplay updates: ")
312: (setq arg (max arg 1))
313: (setq terminal-redisplay-interval arg
314: te-redisplay-count 0))
315:
316: ;;;; more map
317:
318: ;; every command -must- call te-more-break-unwind
319: ;; or grave lossage will result
320:
321: (put 'te-more-break-unread 'suppress-keymap t)
322: (defun te-more-break-unread ()
323: (interactive)
324: (if (= last-input-char terminal-escape-char)
325: (call-interactively 'te-escape)
326: (message "Continuing from more break (\"%s\" typed, %d chars output pending...)"
327: (single-key-description last-input-char)
328: (te-pending-output-length))
329: (setq te-more-count 259259)
330: (te-more-break-unwind)
331: (let ((terminal-more-processing nil))
332: (te-pass-through))))
333:
334: (defun te-more-break-resume ()
335: "Proceed past the **MORE** break,
336: allowing the next page of output to appear"
337: (interactive)
338: (message "Continuing from more break")
339: (te-more-break-unwind))
340:
341: (defun te-more-break-help ()
342: "Provide help on commands available in a terminal-emulator **MORE** break"
343: (interactive)
344: (message "Terminal-emulator more break help...")
345: (sit-for 0)
346: (with-electric-help
347: (function (lambda ()
348: (princ "Terminal-emulator more break.\n\n")
349: (princ (format "Type \"%s\" (te-more-break-resume)\n%s\n"
350: (where-is-internal 'te-more-break-resume
351: terminal-more-break-map t)
352: (documentation 'te-more-break-resume)))
353: (princ (substitute-command-keys "\\{terminal-more-break-map}\n"))
354: (princ "Any other key is passed through to the program
355: running under the terminal emulator and disables more processing until
356: all pending output has been dealt with.")
357: nil))))
358:
359:
360: (defun te-more-break-advance-one-line ()
361: "Allow one more line of text to be output before doing another more break."
362: (interactive)
363: (setq te-more-count 1)
364: (te-more-break-unwind))
365:
366: (defun te-more-break-flush-pending-output ()
367: "Discard any output which has been received by the terminal emulator but
368: not yet proceesed and then proceed from the more break."
369: (interactive)
370: (te-more-break-unwind)
371: (te-flush-pending-output))
372:
373: (defun te-flush-pending-output ()
374: "Discard any as-yet-unprocessed output which has been received by
375: the terminal emulator."
376: (interactive)
377: ;; this could conceivably be confusing in the presence of
378: ;; escape-sequences spanning process-output chunks
379: (if (null (cdr te-pending-output))
380: (message "(There is no output pending)")
381: (let ((length (te-pending-output-length)))
382: (message "Flushing %d chars of pending output" length)
383: (setq te-pending-output
384: (list 0 (format "\n*** %d chars of pending output flushed ***\n"
385: length)))
386: (te-update-pending-output-display)
387: (te-process-output nil)
388: (sit-for 0))))
389:
390:
391: (defun te-pass-through ()
392: "Send the last character typed through the terminal-emulator
393: without any interpretation"
394: (interactive)
395: (if (eql last-input-char terminal-escape-char)
396: (call-interactively 'te-escape)
397: (and terminal-more-processing
398: (null (cdr te-pending-output))
399: (te-set-more-count nil))
400: (send-string te-process (make-string 1 last-input-char))
401: (te-process-output t)))
402:
403: (defun te-set-window-start ()
404: (let* ((w (get-buffer-window (current-buffer)))
405: (h (if w (window-height w))))
406: (cond ((not w)) ; buffer not displayed
407: ((>= h (/ (- (point) (point-min)) (1+ te-width)))
408: ;; this is the normal case
409: (set-window-start w (point-min)))
410: ;; this happens if some vandal shrinks our window.
411: ((>= h (/ (- (point-max) (point)) (1+ te-width)))
412: (set-window-start w (- (point-max) (* h (1+ te-width)) -1)))
413: ;; I give up.
414: (t nil))))
415:
416: (defun te-pending-output-length ()
417: (let ((length (car te-pending-output))
418: (tem (cdr te-pending-output)))
419: (while tem
420: (setq length (+ length (length (car tem))) tem (cdr tem)))
421: length))
422:
423: ;;;; more break hair
424:
425: (defun te-more-break ()
426: (te-set-more-count t)
427: (make-local-variable 'te-more-old-point)
428: (setq te-more-old-point (point))
429: (make-local-variable 'te-more-old-local-map)
430: (setq te-more-old-local-map (current-local-map))
431: (use-local-map terminal-more-break-map)
432: (make-local-variable 'te-more-old-filter)
433: (setq te-more-old-filter (process-filter te-process))
434: (make-local-variable 'te-more-old-mode-line-format)
435: (setq te-more-old-mode-line-format mode-line-format
436: mode-line-format (list "-- **MORE** "
437: mode-line-buffer-identification
438: "%-"))
439: (set-process-filter te-process
440: (function (lambda (process string)
441: (save-excursion
442: (set-buffer (process-buffer process))
443: (setq te-pending-output (nconc te-pending-output
444: (list string))))
445: (te-update-pending-output-display))))
446: (te-update-pending-output-display)
447: (if (eq (window-buffer (selected-window)) (current-buffer))
448: (message "More break "))
449: (or (eobp)
450: (null terminal-more-break-insertion)
451: (save-excursion
452: (forward-char 1)
453: (delete-region (point) (+ (point) te-width))
454: (insert terminal-more-break-insertion)))
455: (run-hooks 'terminal-more-break-hook)
456: (sit-for 0) ;get display to update
457: (throw 'te-process-output t))
458:
459: (defun te-more-break-unwind ()
460: (use-local-map te-more-old-local-map)
461: (set-process-filter te-process te-more-old-filter)
462: (goto-char te-more-old-point)
463: (setq mode-line-format te-more-old-mode-line-format)
464: (set-buffer-modified-p (buffer-modified-p))
465: (let ((buffer-read-only nil))
466: (cond ((eobp))
467: (terminal-more-break-insertion
468: (forward-char 1)
469: (delete-region (point)
470: (+ (point) (length terminal-more-break-insertion)))
471: (insert-char ?\ te-width)
472: (goto-char te-more-old-point)))
473: (setq te-more-old-point nil)
474: (let ((te-more-count 259259))
475: (te-newline)))
476: ;(sit-for 0)
477: (te-process-output t))
478:
479: (defun te-set-more-count (newline)
480: (let ((line (/ (- (point) (point-min)) (1+ te-width))))
481: (if newline (setq line (1+ line)))
482: (cond ((= line te-height)
483: (setq te-more-count te-height))
484: ;>>>> something is strange. Investigate this!
485: ((= line (1- te-height))
486: (setq te-more-count te-height))
487: ((or (< line (/ te-height 2))
488: (> (- te-height line) 10))
489: ;; break at end of this page
490: (setq te-more-count (- te-height line)))
491: (t
492: ;; migrate back towards top (ie bottom) of screen.
493: (setq te-more-count (- te-height
494: (if (> te-height 10) 2 1)))))))
495:
496:
497: ;;;; More or less straight-forward terminal escapes
498:
499: ;; ^j, meaning `newline' to non-display programs.
500: ;; (Who would think of ever writing a system which doesn't understand
501: ;; display terminals natively? Un*x: The Operating System of the Future.)
502: (defun te-newline ()
503: "Move down a line, optionally do more processing, perhaps wrap/scroll,
504: move to start of new line, clear to end of line."
505: (end-of-line)
506: (cond ((not terminal-more-processing))
507: ((< (setq te-more-count (1- te-more-count)) 0)
508: (te-set-more-count t))
509: ((eql te-more-count 0)
510: ;; this doesn't return
511: (te-more-break)))
512: (if (eobp)
513: (progn
514: (delete-region (point-min) (+ (point-min) te-width))
515: (goto-char (point-min))
516: (if terminal-scrolling
517: (progn (delete-char 1)
518: (goto-char (point-max))
519: (insert ?\n))))
520: (forward-char 1)
521: (delete-region (point) (+ (point) te-width)))
522: (insert-char ?\ te-width)
523: (beginning-of-line)
524: (te-set-window-start))
525:
526: ;; ^p ^j
527: ;; Handle the `do' or `nl' termcap capability.
528: ;;>> I am not sure why this broken, obsolete, capability is here.
529: ;;>> Perhaps it is for VIle. No comment was made about why it
530: ;;>> was added (in "Sun Dec 6 01:22:27 1987 Richard Stallman")
531: (defun te-down-vertically-or-scroll ()
532: "Move down a line vertically, or scroll at bottom."
533: (let ((column (current-column)))
534: (end-of-line)
535: (if (eobp)
536: (progn
537: (delete-region (point-min) (+ (point-min) te-width))
538: (goto-char (point-min))
539: (delete-char 1)
540: (goto-char (point-max))
541: (insert ?\n)
542: (insert-char ?\ te-width)
543: (beginning-of-line))
544: (forward-line 1))
545: (move-to-column column))
546: (te-set-window-start))
547:
548: ; ^p = x+32 y+32
549: (defun te-move-to-position ()
550: ;; must offset by #o40 since cretinous unix won't send a 004 char through
551: (let ((y (- (te-get-char) 32))
552: (x (- (te-get-char) 32)))
553: (if (or (> x te-width)
554: (> y te-height))
555: () ;(error "fucked %d %d" x y)
556: (goto-char (+ (point-min) x (* y (1+ te-width))))
557: ;(te-set-window-start?)
558: ))
559: (setq te-more-count -1))
560:
561:
562:
563: ;; ^p c
564: (defun te-clear-rest-of-line ()
565: (save-excursion
566: (let ((n (- (point) (progn (end-of-line) (point)))))
567: (delete-region (point) (+ (point) n))
568: (insert-char ?\ (- n)))))
569:
570:
571: ;; ^p C
572: (defun te-clear-rest-of-screen ()
573: (save-excursion
574: (te-clear-rest-of-line)
575: (while (progn (end-of-line) (not (eobp)))
576: (forward-char 1) (end-of-line)
577: (delete-region (- (point) te-width) (point))
578: (insert-char ?\ te-width))))
579:
580:
581: ;; ^p ^l
582: (defun te-clear-screen ()
583: ;; regenerate buffer to compensate for (nonexistent!!) bugs.
584: (erase-buffer)
585: (let ((i 0))
586: (while (< i te-height)
587: (setq i (1+ i))
588: (insert-char ?\ te-width)
589: (insert ?\n)))
590: (delete-region (1- (point-max)) (point-max))
591: (goto-char (point-min))
592: (setq te-more-count -1))
593:
594:
595: ;; ^p ^o count+32
596: (defun te-insert-lines ()
597: (if (not (bolp))
598: ();(error "fooI")
599: (save-excursion
600: (let* ((line (- te-height (/ (- (point) (point-min)) (1+ te-width)) -1))
601: (n (min (- (te-get-char) ?\ ) line))
602: (i 0))
603: (delete-region (- (point-max) (* n (1+ te-width))) (point-max))
604: (if (eql (point) (point-max)) (insert ?\n))
605: (while (< i n)
606: (setq i (1+ i))
607: (insert-char ?\ te-width)
608: (or (eql i line) (insert ?\n))))))
609: (setq te-more-count -1))
610:
611:
612: ;; ^p ^k count+32
613: (defun te-delete-lines ()
614: (if (not (bolp))
615: ();(error "fooD")
616: (let* ((line (- te-height (/ (- (point) (point-min)) (1+ te-width)) -1))
617: (n (min (- (te-get-char) ?\ ) line))
618: (i 0))
619: (delete-region (point)
620: (min (+ (point) (* n (1+ te-width))) (point-max)))
621: (save-excursion
622: (goto-char (point-max))
623: (while (< i n)
624: (setq i (1+ i))
625: (insert-char ?\ te-width)
626: (or (eql i line) (insert ?\n))))))
627: (setq te-more-count -1))
628:
629: ;; ^p ^a
630: (defun te-beginning-of-line ()
631: (beginning-of-line))
632:
633: ;; ^p ^b
634: (defun te-backward-char ()
635: (if (not (bolp))
636: (backward-char 1)))
637:
638: ;; ^p ^f
639: (defun te-forward-char ()
640: (if (not (eolp))
641: (forward-char 1)))
642:
643:
644: ;; 0177
645: (defun te-delete ()
646: (if (bolp)
647: ()
648: (delete-region (1- (point)) (point))
649: (insert ?\ )
650: (forward-char -1)))
651:
652: ;; ^p ^g
653: (defun te-beep ()
654: (beep))
655:
656:
657: ;; ^p _ count+32
658: (defun te-insert-spaces ()
659: (let* ((p (point))
660: (n (min (- (te-get-char) 32)
661: (- (progn (end-of-line) (point)) p))))
662: (if (<= n 0)
663: nil
664: (delete-char (- n))
665: (goto-char p)
666: (insert-char ?\ n))
667: (goto-char p)))
668:
669: ;; ^p d count+32 (should be ^p ^d but cretinous un*x won't send ^d chars!!!)
670: (defun te-delete-char ()
671: (let* ((p (point))
672: (n (min (- (te-get-char) 32)
673: (- (progn (end-of-line) (point)) p))))
674: (if (<= n 0)
675: nil
676: (insert-char ?\ n)
677: (goto-char p)
678: (delete-char n))
679: (goto-char p)))
680:
681:
682:
683: ;; disgusting unix-required shit
684: ;; Are we living twenty years in the past yet?
685:
686: (defun te-losing-unix ()
687: ;(what lossage)
688: ;(message "fucking-unix: %d" char)
689: )
690:
691: ;; ^i
692: (defun te-output-tab ()
693: (let* ((p (point))
694: (x (- p (progn (beginning-of-line) (point))))
695: (l (min (- 8 (logand x 7))
696: (progn (end-of-line) (- (point) p)))))
697: (goto-char (+ p l))))
698:
699: ;; Also:
700: ;; ^m => beginning-of-line (for which it -should- be using ^p ^a, right?!!)
701: ;; ^g => te-beep (for which it should use ^p ^g)
702: ;; ^h => te-backward-char (for which it should use ^p ^b)
703:
704:
705:
706: (defun te-filter (process string)
707: (let* ((obuf (current-buffer))
708: (m meta-flag))
709: ;; can't use save-excursion, as that preserves point, which we don't want
710: (unwind-protect
711: (progn
712: (set-buffer (process-buffer process))
713: (goto-char te-saved-point)
714: (and (bufferp te-log-buffer)
715: (if (null (buffer-name te-log-buffer))
716: ;; killed
717: (setq te-log-buffer nil)
718: (set-buffer te-log-buffer)
719: (goto-char (point-max))
720: (insert string)
721: (set-buffer (process-buffer process))))
722: (setq te-pending-output (nconc te-pending-output (list string)))
723: (te-update-pending-output-display)
724: ;; this binding is needed because emacs looks at meta-flag when
725: ;; the keystroke is read from the keyboard, not when it is about
726: ;; to be fed into a keymap (or returned by read-char)
727: ;; There still could be some screws, though.
728: (let ((meta-flag m))
729: (te-process-output (eq (current-buffer)
730: (window-buffer (selected-window)))))
731: (set-buffer (process-buffer process))
732: (setq te-saved-point (point)))
733: (set-buffer obuf))))
734:
735: ;; fucking unix has -such- braindamaged lack of tty control...
736: (defun te-process-output (preemptable)
737: ;;>> There seems no good reason to ever disallow preemption
738: (setq preemptable t)
739: (catch 'te-process-output
740: (let ((buffer-read-only nil)
741: (string nil) ostring start char (matchpos nil))
742: (while (cdr te-pending-output)
743: (setq ostring string
744: start (car te-pending-output)
745: string (car (cdr te-pending-output))
746: char (aref string start))
747: (if (eql (setq start (1+ start)) (length string))
748: (progn (setq te-pending-output
749: (cons 0 (cdr (cdr te-pending-output)))
750: start 0
751: string (car (cdr te-pending-output)))
752: (te-update-pending-output-display))
753: (setcar te-pending-output start))
754: (if (and (> char ?\037) (< char ?\377))
755: (cond ((eolp)
756: ;; unread char
757: (if (eql start 0)
758: (setq te-pending-output
759: (cons 0 (cons (make-string 1 char)
760: (cdr te-pending-output))))
761: (setcar te-pending-output (1- start)))
762: (te-newline))
763: ((null string)
764: (delete-char 1) (insert char)
765: (te-redisplay-if-necessary 1))
766: (t
767: (let ((end (or (and (eq ostring string) matchpos)
768: (setq matchpos (string-match
769: "[\000-\037\177-\377]"
770: string start))
771: (length string))))
772: (delete-char 1) (insert char)
773: (setq char (point)) (end-of-line)
774: (setq end (min end (+ start (- (point) char))))
775: (goto-char char)
776: (if (eql end matchpos) (setq matchpos nil))
777: (delete-region (point) (+ (point) (- end start)))
778: (insert (if (and (eql start 0)
779: (eql end (length string)))
780: string
781: (substring string start end)))
782: (if (eql end (length string))
783: (setq te-pending-output
784: (cons 0 (cdr (cdr te-pending-output))))
785: (setcar te-pending-output end))
786: (te-redisplay-if-necessary (1+ (- end start))))))
787: ;; I suppose if I split the guts of this out into a separate
788: ;; function we could trivially emulate different terminals
789: ;; Who cares in any case? (Apart from stupid losers using rlogin)
790: (funcall
791: (if (eql char ?\^p)
792: (or (cdr (assq (te-get-char)
793: '((?= . te-move-to-position)
794: (?c . te-clear-rest-of-line)
795: (?C . te-clear-rest-of-screen)
796: (?\C-o . te-insert-lines)
797: (?\C-k . te-delete-lines)
798: ;; not necessary, but help sometimes.
799: (?\C-a . te-beginning-of-line)
800: (?\C-b . te-backward-char)
801: ;; should be C-d, but un*x
802: ;; pty's won't send \004 through!
803: ;; Can you believe this?
804: (?d . te-delete-char)
805: (?_ . te-insert-spaces)
806: ;; random
807: (?\C-f . te-forward-char)
808: (?\C-g . te-beep)
809: (?\C-j . te-down-vertically-or-scroll)
810: (?\C-l . te-clear-screen)
811: )))
812: 'te-losing-unix)
813: (or (cdr (assq char
814: '((?\C-j . te-newline)
815: (?\177 . te-delete)
816: ;; Did I ask to be sent these characters?
817: ;; I don't remember doing so, either.
818: ;; (Perhaps some operating system or
819: ;; other is completely incompetent...)
820: (?\C-m . te-beginning-of-line) ;fuck me harder
821: (?\C-g . te-beep) ;again and again!
822: (?\C-h . te-backward-char) ;wa12id!!
823: (?\C-i . te-output-tab)))) ;(spiked)
824: 'te-losing-unix))) ;That feels better
825: (te-redisplay-if-necessary 1))
826: (and preemptable
827: (input-pending-p)
828: ;; preemptable output! Oh my!!
829: (throw 'te-process-output t)))))
830: ;; We must update window-point in every window displaying our buffer
831: (let* ((s (selected-window))
832: (w s))
833: (while (not (eq s (setq w (next-window w))))
834: (if (eq (window-buffer w) (current-buffer))
835: (set-window-point w (point))))))
836:
837: (defun te-get-char ()
838: (if (cdr te-pending-output)
839: (let ((start (car te-pending-output))
840: (string (car (cdr te-pending-output))))
841: (prog1 (aref string start)
842: (if (eql (setq start (1+ start)) (length string))
843: (setq te-pending-output (cons 0 (cdr (cdr te-pending-output))))
844: (setcar te-pending-output start))))
845: (catch 'char
846: (let ((filter (process-filter te-process)))
847: (unwind-protect
848: (progn
849: (set-process-filter te-process
850: (function (lambda (p s)
851: (or (eql (length s) 1)
852: (setq te-pending-output (list 1 s)))
853: (throw 'char (aref s 0)))))
854: (accept-process-output te-process))
855: (set-process-filter te-process filter))))))
856:
857:
858: (defun te-redisplay-if-necessary (length)
859: (and (<= (setq te-redisplay-count (- te-redisplay-count length)) 0)
860: (eq (current-buffer) (window-buffer (selected-window)))
861: (waiting-for-user-input-p)
862: (progn (te-update-pending-output-display)
863: (sit-for 0)
864: (setq te-redisplay-count terminal-redisplay-interval))))
865:
866: (defun te-update-pending-output-display ()
867: (if (null (cdr te-pending-output))
868: (setq te-pending-output-info "")
869: (let ((length (te-pending-output-length)))
870: (if (< length 1500)
871: (setq te-pending-output-info "")
872: (setq te-pending-output-info (format "(%dK chars output pending) "
873: (/ (+ length 512) 1024))))))
874: ;; update mode line
875: (set-buffer-modified-p (buffer-modified-p)))
876:
877:
878: (defun te-sentinel (process message)
879: (cond ((eq (process-status process) 'run))
880: ((null (buffer-name (process-buffer process)))) ;deleted
881: (t (let ((b (current-buffer)))
882: (save-excursion
883: (set-buffer (process-buffer process))
884: (setq buffer-read-only nil)
885: (fundamental-mode)
886: (goto-char (point-max))
887: (delete-blank-lines)
888: (delete-horizontal-space)
889: (insert "\n*******\n" message "*******\n"))
890: (if (and (eq b (process-buffer process))
891: (waiting-for-user-input-p))
892: (progn (goto-char (point-max))
893: (recenter -1)))))))
894:
895: (defvar te-stty-string "stty -nl new dec echo"
896: "Command string (to be interpreted by \"sh\") which sets the modes
897: of the virtual terminal to be appropriate for interactive use.")
898:
899: (defvar explicit-shell-file-name nil
900: "*If non-nil, is file name to use for explicitly requested inferior shell.")
901:
902: (defun terminal-emulator (buffer program args &optional width height)
903: "Under a display-terminal emulator in BUFFER, run PROGRAM on arguments ARGS.
904: ARGS is a list of argument-strings. Remaining arguments are WIDTH and HEIGHT.
905: BUFFER's contents are made an image of the display generated by that program,
906: and any input typed when BUFFER is the current Emacs buffer is sent to that
907: program an keyboard input.
908:
909: Interactively, BUFFER defaults to \"*terminal*\" and PROGRAM and ARGS
910: are parsed from an input-string using your usual shell.
911: WIDTH and HEIGHT are determined from the size of the current window
912: -- WIDTH will be one less than the window's width, HEIGHT will be its height.
913:
914: To switch buffers and leave the emulator, or to give commands
915: to the emulator itself (as opposed to the program running under it),
916: type Control-^. The following character is an emulator command.
917: Type Control-^ twice to send it to the subprogram.
918: This escape character may be changed using the variable `terminal-escape-char'.
919:
920: `Meta' characters may not currently be sent through the terminal emulator.
921:
922: Here is a list of some of the variables which control the behaviour
923: of the emulator -- see their documentation for more information:
924: terminal-escape-char, terminal-scrolling, terminal-more-processing,
925: terminal-redisplay-interval.
926:
927: This function calls the value of terminal-mode-hook if that exists
928: and is non-nil after the terminal buffer has been set up and the
929: subprocess started.
930:
931: Presently with `termcap' only; if somebody sends us code to make this
932: work with `terminfo' we will try to use it."
933: (interactive
934: (cons (save-excursion
935: (set-buffer (get-buffer-create "*terminal*"))
936: (buffer-name (if (or (not (boundp 'te-process))
937: (null te-process)
938: (not (eq (process-status te-process)
939: 'run)))
940: (current-buffer)
941: (generate-new-buffer "*terminal*"))))
942: (append
943: (let* ((default-s
944: ;; Default shell is same thing M-x shell uses.
945: (or explicit-shell-file-name
946: (getenv "ESHELL")
947: (getenv "SHELL")
948: "/bin/sh"))
949: (s (read-string
950: (format "Run program in emulator: (default %s) "
951: default-s))))
952: (if (equal s "")
953: (list default-s '())
954: (te-parse-program-and-args s))))))
955: (switch-to-buffer buffer)
956: (if (null width) (setq width (- (window-width (selected-window)) 1)))
957: (if (null height) (setq height (- (window-height (selected-window)) 1)))
958: (terminal-mode)
959: (setq te-width width te-height height)
960: (setq mode-line-buffer-identification
961: (list (format "Emacs terminal %dx%d: %%b " te-width te-height)
962: 'te-pending-output-info))
963: (let ((buffer-read-only nil))
964: (te-clear-screen))
965: (let (process)
966: (while (setq process (get-buffer-process (current-buffer)))
967: (if (y-or-n-p (format "Kill process %s? " (process-name process)))
968: (delete-process process)
969: (error "Process %s not killed" (process-name process)))))
970: (condition-case err
971: (let ((termcap
972: ;; Because of Unix Brain Death(tm), we can't change
973: ;; the terminal type of a running process, and so
974: ;; terminal size and scrollability are wired-down
975: ;; at this point. ("Detach? What's that?")
976: (concat (format "emacs-virtual:co#%d:li#%d:%s"
977: ;; Sigh. These can't be dynamically changed.
978: te-width te-height (if terminal-scrolling
979: "" "ns:"))
980: ;;-- Basic things
981: ;; cursor-motion, bol, forward/backward char
982: "cm=^p=%+ %+ :cr=^p^a:le=^p^b:nd=^p^f:"
983: ;; newline, clear eof/eof, audible bell
984: "nw=^j:ce=^pc:cd=^pC:cl=^p^l:bl=^p^g:"
985: ;; insert/delete char/line
986: "IC=^p_%+ :DC=^pd%+ :AL=^p^o%+ :DL=^p^k%+ :"
987: ;;-- Not-widely-known (ie nonstandard) flags, which mean
988: ;; o writing in the last column of the last line
989: ;; doesn't cause idiotic scrolling, and
990: ;; o don't use idiotische c-s/c-q sogenannte
991: ;; ``flow control'' auf keinen Fall.
992: "LP:NF:"
993: ;;-- For stupid or obsolete programs
994: "ic=^p_!:dc=^pd!:al=^p^o!:dl=^p^k!:ho=^p= :"
995: ;;-- For disgusting programs.
996: ;; (VI? What losers need these, I wonder?)
997: "im=:ei=:dm=:ed=:mi:do=^p^j:nl=^p^j:bs:")))
998: (if (fboundp 'start-subprocess)
999: ;; this winning function would do everything, except that
1000: ;; rms doesn't want it.
1001: (setq te-process (start-subprocess "terminal-emulator"
1002: program args
1003: 'channel-type 'terminal
1004: 'filter 'te-filter
1005: 'buffer (current-buffer)
1006: 'sentinel 'te-sentinel
1007: 'modify-environment
1008: (list (cons "TERM" "emacs-virtual")
1009: (cons "TERMCAP" termcap))))
1010: ;; so instead we resort to this...
1011: (setq te-process (start-process "terminal-emulator" (current-buffer)
1012: "/bin/sh" "-c"
1013: ;; Yuck!!! Start a shell to set some terminal
1014: ;; control characteristics. Then start the
1015: ;; "env" program to setup the terminal type
1016: ;; Then finally start the program we wanted.
1017: (format "%s; exec %s TERM=emacs-virtual %s %s"
1018: te-stty-string
1019: (te-quote-arg-for-sh
1020: (concat exec-directory "env"))
1021: (te-quote-arg-for-sh
1022: (concat "TERMCAP=" termcap))
1023: (mapconcat 'te-quote-arg-for-sh
1024: (cons program args) " "))))
1025: (set-process-filter te-process 'te-filter)
1026: (set-process-sentinel te-process 'te-sentinel)))
1027: (error (fundamental-mode)
1028: (signal (car err) (cdr err))))
1029: ;; sigh
1030: (if (default-value 'meta-flag)
1031: (progn (message
1032: "Note: Meta key disabled due to maybe-eventually-reparable braindamage")
1033: (sit-for 1)))
1034: (message "Entering emacs terminal-emulator... Type %s %s for help"
1035: (single-key-description terminal-escape-char)
1036: (mapconcat 'single-key-description
1037: (where-is-internal 'te-escape-help
1038: terminal-escape-map
1039: t)
1040: " "))
1041: (setq inhibit-quit t) ;sport death
1042: (use-local-map terminal-map)
1043: (run-hooks 'terminal-mode-hook))
1044:
1045: (defun te-parse-program-and-args (s)
1046: (cond ((string-match "\\`\\([a-zA-Z0-9-+=_.@/:]+[ \t]*\\)+\\'" s)
1047: (let ((l ()) (p 0))
1048: (while p
1049: (setq l (cons (if (string-match
1050: "\\([a-zA-Z0-9-+=_.@/:]+\\)\\([ \t]+\\)*"
1051: s p)
1052: (prog1 (substring s p (match-end 1))
1053: (setq p (match-end 0))
1054: (if (eql p (length s)) (setq p nil)))
1055: (prog1 (substring s p)
1056: (setq p nil)))
1057: l)))
1058: (setq l (nreverse l))
1059: (list (car l) (cdr l))))
1060: ((and (string-match "[ \t]" s) (not (file-exists-p s)))
1061: (list shell-file-name (list "-c" (concat "exec " s))))
1062: (t (list s ()))))
1063:
1064: (put 'terminal-mode 'mode-class 'special)
1065: ;; This is only separated out from function terminal-emulator
1066: ;; to keep the latter a little more managable.
1067: (defun terminal-mode ()
1068: "Set up variables for use f the terminal-emualtor.
1069: One should not call this -- it is an internal function
1070: of the terminal-emulator"
1071: (kill-all-local-variables)
1072: (buffer-flush-undo (current-buffer))
1073: (setq major-mode 'terminal-mode)
1074: (setq mode-name "terminal")
1075: ; (make-local-variable 'Helper-return-blurb)
1076: ; (setq Helper-return-blurb "return to terminal simulator")
1077: (setq mode-line-process '(": %s"))
1078: (setq buffer-read-only t)
1079: (setq truncate-lines t)
1080: (make-local-variable 'terminal-escape-char)
1081: (setq terminal-escape-char (default-value 'terminal-escape-char))
1082: (make-local-variable 'terminal-scrolling)
1083: (setq terminal-scrolling (default-value 'terminal-scrolling))
1084: (make-local-variable 'terminal-more-processing)
1085: (setq terminal-more-processing (default-value 'terminal-more-processing))
1086: (make-local-variable 'terminal-redisplay-interval)
1087: (setq terminal-redisplay-interval (default-value 'terminal-redisplay-interval))
1088: (make-local-variable 'te-width)
1089: (make-local-variable 'te-height)
1090: (make-local-variable 'te-process)
1091: (make-local-variable 'te-pending-output)
1092: (setq te-pending-output (list 0))
1093: (make-local-variable 'te-saved-point)
1094: (setq te-saved-point (point-min))
1095: (make-local-variable 'te-pending-output-info) ;for the mode line
1096: (setq te-pending-output-info "")
1097: (make-local-variable 'inhibit-quit)
1098: ;(setq inhibit-quit t)
1099: (make-local-variable 'te-log-buffer)
1100: (setq te-log-buffer nil)
1101: (make-local-variable 'te-more-count)
1102: (setq te-more-count -1)
1103: (make-local-variable 'te-redisplay-count)
1104: (setq te-redisplay-count terminal-redisplay-interval)
1105: ;;>> Nothing can be done about this without decruftifying
1106: ;;>> emacs keymaps.
1107: (make-local-variable 'meta-flag) ;sigh
1108: (setq meta-flag nil)
1109: ;(use-local-map terminal-mode-map)
1110: ;; terminal-mode-hook is called above in function terminal-emulator
1111: )
1112:
1113: ;;;; what a complete loss
1114:
1115: (defun te-quote-arg-for-sh (fuckme)
1116: (cond ((string-match "\\`[a-zA-Z0-9-+=_.@/:]+\\'"
1117: fuckme)
1118: fuckme)
1119: ((not (string-match "[$]" fuckme))
1120: ;; "[\"\\]" are special to sh and the lisp reader in the same way
1121: (prin1-to-string fuckme))
1122: (t
1123: (let ((harder "")
1124: (cretin 0)
1125: (stupid 0))
1126: (while (cond ((>= cretin (length fuckme))
1127: nil)
1128: ;; this is the set of chars magic with "..." in `sh'
1129: ((setq stupid (string-match "[\"\\$]"
1130: fuckme cretin))
1131: t)
1132: (t (setq harder (concat harder
1133: (substring fuckme cretin)))
1134: nil))
1135: (setq harder (concat harder (substring fuckme cretin stupid)
1136: ;; Can't use ?\\ since `concat'
1137: ;; unfortunately does prin1-to-string
1138: ;; on fixna. Amazing.
1139: "\\"
1140: (substring fuckme
1141: stupid
1142: (1+ stupid)))
1143: cretin (1+ stupid)))
1144: (concat "\"" harder "\"")))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.