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