terminal.el

早期freebsd实现

      (setq te-pending-output
	    (list 0 (format "\n*** %d chars of pending output flushed ***\n"
			    length)))
      (te-update-pending-output-display)
      (te-process-output nil)
      (sit-for 0))))


(defun te-pass-through ()
  "Send the last character typed through the terminal-emulator
without any interpretation"
  (interactive)
  (if (eql last-input-char terminal-escape-char)
      (call-interactively 'te-escape)
    (and terminal-more-processing
	 (null (cdr te-pending-output))
	 (te-set-more-count nil))
    (send-string te-process (make-string 1 last-input-char))
    (te-process-output t))) 

(defun te-set-window-start ()
  (let* ((w (get-buffer-window (current-buffer)))
	 (h (if w (window-height w))))
    (cond ((not w)) ; buffer not displayed
	  ((>= h (/ (- (point) (point-min)) (1+ te-width)))
	   ;; this is the normal case
	   (set-window-start w (point-min)))
	  ;; this happens if some vandal shrinks our window.
	  ((>= h (/ (- (point-max) (point)) (1+ te-width)))
	   (set-window-start w (- (point-max) (* h (1+ te-width)) -1)))
	  ;; I give up.
	  (t nil))))

(defun te-pending-output-length ()
  (let ((length (car te-pending-output))
	(tem (cdr te-pending-output)))
    (while tem
      (setq length (+ length (length (car tem))) tem (cdr tem)))
    length))

;;;; more break hair

(defun te-more-break ()
  (te-set-more-count t)
  (make-local-variable 'te-more-old-point)
  (setq te-more-old-point (point))
  (make-local-variable 'te-more-old-local-map)
  (setq te-more-old-local-map (current-local-map))
  (use-local-map terminal-more-break-map)
  (make-local-variable 'te-more-old-filter)
  (setq te-more-old-filter (process-filter te-process))
  (make-local-variable 'te-more-old-mode-line-format)
  (setq te-more-old-mode-line-format mode-line-format
	mode-line-format (list "--   **MORE**  "
			       mode-line-buffer-identification
			       "%-"))
  (set-process-filter te-process
    (function (lambda (process string)
		(save-excursion
		  (set-buffer (process-buffer process))
		  (setq te-pending-output (nconc te-pending-output
						 (list string))))
		  (te-update-pending-output-display))))
  (te-update-pending-output-display)
  (if (eq (window-buffer (selected-window)) (current-buffer))
      (message "More break "))
  (or (eobp)
      (null terminal-more-break-insertion)
      (save-excursion
	(forward-char 1)
	(delete-region (point) (+ (point) te-width))
	(insert terminal-more-break-insertion)))
  (run-hooks 'terminal-more-break-hook)
  (sit-for 0) ;get display to update
  (throw 'te-process-output t))

(defun te-more-break-unwind ()
  (use-local-map te-more-old-local-map)
  (set-process-filter te-process te-more-old-filter)
  (goto-char te-more-old-point)
  (setq mode-line-format te-more-old-mode-line-format)
  (set-buffer-modified-p (buffer-modified-p))
  (let ((buffer-read-only nil))
    (cond ((eobp))
	  (terminal-more-break-insertion
	   (forward-char 1)
	   (delete-region (point)
			  (+ (point) (length terminal-more-break-insertion)))
	   (insert-char ?\  te-width)
	   (goto-char te-more-old-point)))
    (setq te-more-old-point nil)
    (let ((te-more-count 259259))
      (te-newline)))
  ;(sit-for 0)
  (te-process-output t))

(defun te-set-more-count (newline)
  (let ((line (/ (- (point) (point-min)) (1+ te-width))))
    (if newline (setq line (1+ line)))
    (cond ((= line te-height)
	   (setq te-more-count te-height))
	  ;>>>> something is strange.  Investigate this!
	  ((= line (1- te-height))
	   (setq te-more-count te-height))
	  ((or (< line (/ te-height 2))
	       (> (- te-height line) 10))
	   ;; break at end of this page
	   (setq te-more-count (- te-height line)))
	  (t
	   ;; migrate back towards top (ie bottom) of screen.
	   (setq te-more-count (- te-height
				  (if (> te-height 10) 2 1)))))))


;;;; More or less straight-forward terminal escapes

;; ^j, meaning `newline' to non-display programs.
;; (Who would think of ever writing a system which doesn't understand
;;  display terminals natively?  Un*x:  The Operating System of the Future.)
(defun te-newline ()
  "Move down a line, optionally do more processing, perhaps wrap/scroll,
move to start of new line, clear to end of line."
  (end-of-line)
  (cond ((not terminal-more-processing))
	((< (setq te-more-count (1- te-more-count)) 0)
	 (te-set-more-count t))
	((eql te-more-count 0)
	 ;; this doesn't return
	 (te-more-break)))
  (if (eobp)
      (progn
	(delete-region (point-min) (+ (point-min) te-width))
	(goto-char (point-min))
	(if terminal-scrolling
	    (progn (delete-char 1)
		   (goto-char (point-max))
		   (insert ?\n))))
    (forward-char 1)
    (delete-region (point) (+ (point) te-width)))
  (insert-char ?\  te-width)
  (beginning-of-line)
  (te-set-window-start))

;; ^p ^j
;; Handle the `do' or `nl' termcap capability.
;;>> I am not sure why this broken, obsolete, capability is here.
;;>> Perhaps it is for VIle.  No comment was made about why it
;;>> was added (in "Sun Dec  6 01:22:27 1987  Richard Stallman")
(defun te-down-vertically-or-scroll ()
  "Move down a line vertically, or scroll at bottom."
  (let ((column (current-column)))
    (end-of-line)
    (if (eobp)
	(progn
	  (delete-region (point-min) (+ (point-min) te-width))
	  (goto-char (point-min))
	  (delete-char 1)
	  (goto-char (point-max))
	  (insert ?\n)
	  (insert-char ?\  te-width)
	  (beginning-of-line))
      (forward-line 1))
    (move-to-column column))
  (te-set-window-start))

; ^p = x+32 y+32
(defun te-move-to-position ()
  ;; must offset by #o40 since cretinous unix won't send a 004 char through
  (let ((y (- (te-get-char) 32))
	(x (- (te-get-char) 32)))
    (if (or (> x te-width)
	    (> y te-height))
	() ;(error "fucked %d %d" x y)
      (goto-char (+ (point-min) x (* y (1+ te-width))))
      ;(te-set-window-start?)
      ))
  (setq te-more-count -1))



;; ^p c
(defun te-clear-rest-of-line ()
  (save-excursion
    (let ((n (- (point) (progn (end-of-line) (point)))))
      (delete-region (point) (+ (point) n))
      (insert-char ?\  (- n)))))


;; ^p C
(defun te-clear-rest-of-screen ()
  (save-excursion
    (te-clear-rest-of-line)
    (while (progn (end-of-line) (not (eobp)))
      (forward-char 1) (end-of-line)
      (delete-region (- (point) te-width) (point))
      (insert-char ?\  te-width))))
      

;; ^p ^l
(defun te-clear-screen ()
  ;; regenerate buffer to compensate for (nonexistent!!) bugs.
  (erase-buffer)
  (let ((i 0))
    (while (< i te-height)
      (setq i (1+ i))
      (insert-char ?\  te-width)
      (insert ?\n)))
  (delete-region (1- (point-max)) (point-max))
  (goto-char (point-min))
  (setq te-more-count -1))


;; ^p ^o count+32
(defun te-insert-lines ()
  (if (not (bolp))
      ();(error "fooI")
    (save-excursion
      (let* ((line (- te-height (/ (- (point) (point-min)) (1+ te-width)) -1))
	     (n (min (- (te-get-char) ?\ ) line))
	     (i 0))
	(delete-region (- (point-max) (* n (1+ te-width))) (point-max))
	(if (eql (point) (point-max)) (insert ?\n))
	(while (< i n)
	  (setq i (1+ i))
	  (insert-char ?\  te-width)
	  (or (eql i line) (insert ?\n))))))
  (setq te-more-count -1))


;; ^p ^k count+32
(defun te-delete-lines ()
  (if (not (bolp))
      ();(error "fooD")
    (let* ((line (- te-height (/ (- (point) (point-min)) (1+ te-width)) -1))
	   (n (min (- (te-get-char) ?\ ) line))
	   (i 0))
      (delete-region (point)
		     (min (+ (point) (* n (1+ te-width))) (point-max)))
      (save-excursion
	(goto-char (point-max))
	(while (< i n)
	  (setq i (1+ i))
	  (insert-char ?\  te-width)
	  (or (eql i line) (insert ?\n))))))
  (setq te-more-count -1))

;; ^p ^a
(defun te-beginning-of-line ()
  (beginning-of-line))

;; ^p ^b
(defun te-backward-char ()
  (if (not (bolp))
      (backward-char 1)))

;; ^p ^f
(defun te-forward-char ()
  (if (not (eolp))
      (forward-char 1)))


;; 0177
(defun te-delete ()
  (if (bolp)
      ()
    (delete-region (1- (point)) (point))
    (insert ?\ )
    (forward-char -1)))

;; ^p ^g
(defun te-beep ()
  (beep))


;; ^p _ count+32
(defun te-insert-spaces ()
  (let* ((p (point))
	 (n (min (- (te-get-char) 32)
		 (- (progn (end-of-line) (point)) p))))
    (if (<= n 0)
	nil
      (delete-char (- n))
      (goto-char p)
      (insert-char ?\  n))
    (goto-char p)))

;; ^p d count+32  (should be ^p ^d but cretinous un*x won't send ^d chars!!!)
(defun te-delete-char ()
  (let* ((p (point))
	 (n (min (- (te-get-char) 32)
		 (- (progn (end-of-line) (point)) p))))
    (if (<= n 0)
	nil
      (insert-char ?\  n)
      (goto-char p)
      (delete-char n))
    (goto-char p)))



;; disgusting unix-required shit
;;  Are we living twenty years in the past yet?

(defun te-losing-unix ()
  ;(what lossage)
  ;(message "fucking-unix: %d" char)
  )

;; ^i
(defun te-output-tab ()
  (let* ((p (point))
	 (x (- p (progn (beginning-of-line) (point))))
	 (l (min (- 8 (logand x 7))
		 (progn (end-of-line) (- (point) p)))))
    (goto-char (+ p l))))

;; Also:
;;  ^m => beginning-of-line (for which it -should- be using ^p ^a, right?!!)
;;  ^g => te-beep (for which it should use ^p ^g)
;;  ^h => te-backward-char (for which it should use ^p ^b)



(defun te-filter (process string)
  (let* ((obuf (current-buffer))
	 (m meta-flag))
    ;; can't use save-excursion, as that preserves point, which we don't want
    (unwind-protect
	(progn
	  (set-buffer (process-buffer process))
	  (goto-char te-saved-point)
	  (and (bufferp te-log-buffer)
	       (if (null (buffer-name te-log-buffer))
		   ;; killed
		   (setq te-log-buffer nil)
		 (set-buffer te-log-buffer)
		 (goto-char (point-max))
		 (insert string)
		 (set-buffer (process-buffer process))))
	  (setq te-pending-output (nconc te-pending-output (list string)))
	  (te-update-pending-output-display)
	  ;; this binding is needed because emacs looks at meta-flag when
	  ;;  the keystroke is read from the keyboard, not when it is about
	  ;;  to be fed into a keymap (or returned by read-char)
	  ;; There still could be some screws, though.
	  (let ((meta-flag m))
	    (te-process-output (eq (current-buffer)
				   (window-buffer (selected-window)))))
	  (set-buffer (process-buffer process))
	  (setq te-saved-point (point)))
      (set-buffer obuf))))

;; fucking unix has -such- braindamaged lack of tty control...
(defun te-process-output (preemptable)
  ;;>> There seems no good reason to ever disallow preemption
  (setq preemptable t)
  (catch 'te-process-output
    (let ((buffer-read-only nil)
	  (string nil) ostring start char (matchpos nil))
      (while (cdr te-pending-output)
	(setq ostring string
	      start (car te-pending-output)
	      string (car (cdr te-pending-output))
	      char (aref string start))
	(if (eql (setq start (1+ start)) (length string))
	    (progn (setq te-pending-output
			   (cons 0 (cdr (cdr te-pending-output)))
			 start 0
			 string (car (cdr te-pending-output)))
		   (te-update-pending-output-display))
	    (setcar te-pending-output start))
	(if (and (> char ?\037) (< char ?\377))
	    (cond ((eolp)
		   ;; unread char
		   (if (eql start 0)
		       (setq te-pending-output
			     (cons 0 (cons (make-string 1 char)
					   (cdr te-pending-output))))
		       (setcar te-pending-output (1- start)))
		   (te-newline))
		  ((null string)
		   (delete-char 1) (insert char)