terminal.el

早期freebsd实现

		   (te-redisplay-if-necessary 1))
		  (t
		   (let ((end (or (and (eq ostring string) matchpos)
				  (setq matchpos (string-match
						   "[\000-\037\177-\377]"
						   string start))
				  (length string))))
		     (delete-char 1) (insert char)
		     (setq char (point)) (end-of-line)
		     (setq end (min end (+ start (- (point) char))))
		     (goto-char char)
		     (if (eql end matchpos) (setq matchpos nil))
		     (delete-region (point) (+ (point) (- end start)))
		     (insert (if (and (eql start 0)
				      (eql end (length string)))
				 string
			         (substring string start end)))
		     (if (eql end (length string))
			 (setq te-pending-output
			       (cons 0 (cdr (cdr te-pending-output))))
		         (setcar te-pending-output end))
		     (te-redisplay-if-necessary (1+ (- end start))))))
	  ;; I suppose if I split the guts of this out into a separate
	  ;;  function we could trivially emulate different terminals
	  ;; Who cares in any case?  (Apart from stupid losers using rlogin)
	  (funcall
	    (if (eql char ?\^p)
	        (or (cdr (assq (te-get-char)
			       '((?= . te-move-to-position)
				 (?c . te-clear-rest-of-line)
				 (?C . te-clear-rest-of-screen)
				 (?\C-o . te-insert-lines)
				 (?\C-k . te-delete-lines)
				 ;; not necessary, but help sometimes.
				 (?\C-a . te-beginning-of-line)
				 (?\C-b . te-backward-char)
				 ;; should be C-d, but un*x
				 ;;  pty's won't send \004 through!
                                 ;; Can you believe this?
				 (?d . te-delete-char)
				 (?_ . te-insert-spaces)
				 ;; random
				 (?\C-f . te-forward-char)
				 (?\C-g . te-beep)
				 (?\C-j . te-down-vertically-or-scroll)
				 (?\C-l . te-clear-screen)
				 )))
		    'te-losing-unix)
	        (or (cdr (assq char
			       '((?\C-j . te-newline)
				 (?\177 . te-delete)
				 ;; Did I ask to be sent these characters?
				 ;; I don't remember doing so, either.
				 ;; (Perhaps some operating system or
				 ;; other is completely incompetent...)
				 (?\C-m . te-beginning-of-line) ;fuck me harder
				 (?\C-g . te-beep)             ;again and again!
				 (?\C-h . te-backward-char)     ;wa12id!!
				 (?\C-i . te-output-tab))))     ;(spiked)
		    'te-losing-unix)))		      ;That feels better
	  (te-redisplay-if-necessary 1))
	(and preemptable
	     (input-pending-p)
	     ;; preemptable output!  Oh my!!
	     (throw 'te-process-output t)))))
  ;; We must update window-point in every window displaying our buffer
  (let* ((s (selected-window))
	 (w s))
    (while (not (eq s (setq w (next-window w))))
      (if (eq (window-buffer w) (current-buffer))
	  (set-window-point w (point))))))

(defun te-get-char ()
  (if (cdr te-pending-output)
      (let ((start (car te-pending-output))
	    (string (car (cdr te-pending-output))))
	(prog1 (aref string start)
	  (if (eql (setq start (1+ start)) (length string))
	      (setq te-pending-output (cons 0 (cdr (cdr te-pending-output))))
	      (setcar te-pending-output start))))
    (catch 'char
      (let ((filter (process-filter te-process)))
	(unwind-protect
	    (progn
	      (set-process-filter te-process
				  (function (lambda (p s)
                                    (or (eql (length s) 1)
                                        (setq te-pending-output (list 1 s)))
                                    (throw 'char (aref s 0)))))
	      (accept-process-output te-process))
	  (set-process-filter te-process filter))))))


(defun te-redisplay-if-necessary (length)
  (and (<= (setq te-redisplay-count (- te-redisplay-count length)) 0)
       (eq (current-buffer) (window-buffer (selected-window)))
       (waiting-for-user-input-p)
       (progn (te-update-pending-output-display)
	      (sit-for 0)
	      (setq te-redisplay-count terminal-redisplay-interval))))

(defun te-update-pending-output-display ()
  (if (null (cdr te-pending-output))
      (setq te-pending-output-info "")      
    (let ((length (te-pending-output-length)))
      (if (< length 1500)
	  (setq te-pending-output-info "")
	(setq te-pending-output-info (format "(%dK chars output pending) "
					     (/ (+ length 512) 1024))))))
  ;; update mode line
  (set-buffer-modified-p (buffer-modified-p)))


(defun te-sentinel (process message)
  (cond ((eq (process-status process) 'run))
	((null (buffer-name (process-buffer process)))) ;deleted
	(t (let ((b (current-buffer)))
	     (save-excursion
	       (set-buffer (process-buffer process))
	       (setq buffer-read-only nil)
	       (fundamental-mode)
	       (goto-char (point-max))
	       (delete-blank-lines)
	       (delete-horizontal-space)
	       (insert "\n*******\n" message "*******\n"))
	     (if (and (eq b (process-buffer process))
		      (waiting-for-user-input-p))
		 (progn (goto-char (point-max))
			(recenter -1)))))))

(defvar te-stty-string "stty -nl new dec echo"
  "Command string (to be interpreted by \"sh\") which sets the modes
of the virtual terminal to be appropriate for interactive use.")

(defvar explicit-shell-file-name nil
  "*If non-nil, is file name to use for explicitly requested inferior shell.")

(defun terminal-emulator (buffer program args &optional width height)
  "Under a display-terminal emulator in BUFFER, run PROGRAM on arguments ARGS.
ARGS is a list of argument-strings.  Remaining arguments are WIDTH and HEIGHT.
BUFFER's contents are made an image of the display generated by that program,
and any input typed when BUFFER is the current Emacs buffer is sent to that
program an keyboard input.

Interactively, BUFFER defaults to \"*terminal*\" and PROGRAM and ARGS
are parsed from an input-string using your usual shell.
WIDTH and HEIGHT are determined from the size of the current window
-- WIDTH will be one less than the window's width, HEIGHT will be its height.

To switch buffers and leave the emulator, or to give commands
to the emulator itself (as opposed to the program running under it),
type Control-^.  The following character is an emulator command.
Type Control-^ twice to send it to the subprogram.
This escape character may be changed using the variable `terminal-escape-char'.

`Meta' characters may not currently be sent through the terminal emulator.

Here is a list of some of the variables which control the behaviour
of the emulator -- see their documentation for more information:
terminal-escape-char, terminal-scrolling, terminal-more-processing,
terminal-redisplay-interval.

This function calls the value of terminal-mode-hook if that exists
and is non-nil after the terminal buffer has been set up and the
subprocess started.

Presently with `termcap' only; if somebody sends us code to make this
work with `terminfo' we will try to use it."
  (interactive
    (cons (save-excursion
	    (set-buffer (get-buffer-create "*terminal*"))
	    (buffer-name (if (or (not (boundp 'te-process))
				 (null te-process)
				 (not (eq (process-status te-process)
					  'run)))
			     (current-buffer)
			   (generate-new-buffer "*terminal*"))))
	  (append
	    (let* ((default-s
		     ;; Default shell is same thing M-x shell uses.
		     (or explicit-shell-file-name
			 (getenv "ESHELL")
			 (getenv "SHELL")
			 "/bin/sh"))
		   (s (read-string
		       (format "Run program in emulator: (default %s) "
			       default-s))))
	      (if (equal s "")
		  (list default-s '())
		(te-parse-program-and-args s))))))
  (switch-to-buffer buffer)
  (if (null width) (setq width (- (window-width (selected-window)) 1)))
  (if (null height) (setq height (- (window-height (selected-window)) 1)))
  (terminal-mode)
  (setq te-width width te-height height)
  (setq mode-line-buffer-identification
	(list (format "Emacs terminal %dx%d: %%b  " te-width te-height)
	      'te-pending-output-info))
  (let ((buffer-read-only nil))
    (te-clear-screen))
  (let (process)
    (while (setq process (get-buffer-process (current-buffer)))
      (if (y-or-n-p (format "Kill process %s? " (process-name process)))
	  (delete-process process)
	(error "Process %s not killed" (process-name process)))))
  (condition-case err
      (let ((termcap
             ;; Because of Unix Brain Death(tm), we can't change
             ;;  the terminal type of a running process, and so
             ;;  terminal size and scrollability are wired-down
             ;;  at this point.  ("Detach?  What's that?")
             (concat (format "emacs-virtual:co#%d:li#%d:%s"
                             ;; Sigh.  These can't be dynamically changed.
                             te-width te-height (if terminal-scrolling
                                                    "" "ns:"))
                     ;;-- Basic things
                     ;; cursor-motion, bol, forward/backward char
                     "cm=^p=%+ %+ :cr=^p^a:le=^p^b:nd=^p^f:"
                     ;; newline, clear eof/eof, audible bell
                     "nw=^j:ce=^pc:cd=^pC:cl=^p^l:bl=^p^g:"
                     ;; insert/delete char/line
                     "IC=^p_%+ :DC=^pd%+ :AL=^p^o%+ :DL=^p^k%+ :"
                     ;;-- Not-widely-known (ie nonstandard) flags, which mean
                     ;; o writing in the last column of the last line
                     ;;   doesn't cause idiotic scrolling, and
                     ;; o don't use idiotische c-s/c-q sogenannte
                     ;;   ``flow control'' auf keinen Fall.
                     "LP:NF:"
                     ;;-- For stupid or obsolete programs
                     "ic=^p_!:dc=^pd!:al=^p^o!:dl=^p^k!:ho=^p=  :"
                     ;;-- For disgusting programs.
                     ;; (VI? What losers need these, I wonder?)
                     "im=:ei=:dm=:ed=:mi:do=^p^j:nl=^p^j:bs:")))
	(if (fboundp 'start-subprocess)
	    ;; this winning function would do everything, except that
	    ;;  rms doesn't want it.
	    (setq te-process (start-subprocess "terminal-emulator"
			       program args
			       'channel-type 'terminal
			       'filter 'te-filter
			       'buffer (current-buffer)
			       'sentinel 'te-sentinel
			       'modify-environment
			         (list (cons "TERM" "emacs-virtual")
				       (cons "TERMCAP" termcap))))
	  ;; so instead we resort to this...
	  (setq te-process (start-process "terminal-emulator" (current-buffer)
			     "/bin/sh" "-c"
			     ;; Yuck!!! Start a shell to set some terminal
			     ;; control characteristics.  Then start the
			     ;; "env" program to setup the terminal type
			     ;; Then finally start the program we wanted.
			     (format "%s; exec %s TERM=emacs-virtual %s %s"
                                     te-stty-string
				     (te-quote-arg-for-sh
				       (concat exec-directory "env"))
				     (te-quote-arg-for-sh
				       (concat "TERMCAP=" termcap))
				     (mapconcat 'te-quote-arg-for-sh
						(cons program args) " "))))
	  (set-process-filter te-process 'te-filter)
	  (set-process-sentinel te-process 'te-sentinel)))
    (error (fundamental-mode)
	   (signal (car err) (cdr err))))
  ;; sigh
  (if (default-value 'meta-flag)
      (progn (message
 "Note:  Meta key disabled due to maybe-eventually-reparable braindamage")
	     (sit-for 1)))
  (message "Entering emacs terminal-emulator...  Type %s %s for help"
	   (single-key-description terminal-escape-char)
	   (mapconcat 'single-key-description
		      (where-is-internal 'te-escape-help
					 terminal-escape-map
					 t)
		      " "))
  (setq inhibit-quit t)			;sport death
  (use-local-map terminal-map)
  (run-hooks 'terminal-mode-hook))

(defun te-parse-program-and-args (s)
  (cond ((string-match "\\`\\([a-zA-Z0-9-+=_.@/:]+[ \t]*\\)+\\'" s)
	 (let ((l ()) (p 0))
	   (while p
	     (setq l (cons (if (string-match
				"\\([a-zA-Z0-9-+=_.@/:]+\\)\\([ \t]+\\)*"
				s p)
			       (prog1 (substring s p (match-end 1))
				 (setq p (match-end 0))
				 (if (eql p (length s)) (setq p nil)))
			       (prog1 (substring s p)
				 (setq p nil)))
			   l)))
	   (setq l (nreverse l))
	   (list (car l) (cdr l))))
	((and (string-match "[ \t]" s) (not (file-exists-p s)))
	 (list shell-file-name (list "-c" (concat "exec " s))))
	(t (list s ()))))

(put 'terminal-mode 'mode-class 'special)
;; This is only separated out from function terminal-emulator
;; to keep the latter a little more managable.
(defun terminal-mode ()
  "Set up variables for use f the terminal-emualtor.
One should not call this -- it is an internal function
of the terminal-emulator"
  (kill-all-local-variables)
  (buffer-flush-undo (current-buffer))
  (setq major-mode 'terminal-mode)
  (setq mode-name "terminal")
; (make-local-variable 'Helper-return-blurb)
; (setq Helper-return-blurb "return to terminal simulator")
  (setq mode-line-process '(": %s"))
  (setq buffer-read-only t)
  (setq truncate-lines t)
  (make-local-variable 'terminal-escape-char)
  (setq terminal-escape-char (default-value 'terminal-escape-char))
  (make-local-variable 'terminal-scrolling)
  (setq terminal-scrolling (default-value 'terminal-scrolling))
  (make-local-variable 'terminal-more-processing)
  (setq terminal-more-processing (default-value 'terminal-more-processing))
  (make-local-variable 'terminal-redisplay-interval)
  (setq terminal-redisplay-interval (default-value 'terminal-redisplay-interval))
  (make-local-variable 'te-width)
  (make-local-variable 'te-height)
  (make-local-variable 'te-process)
  (make-local-variable 'te-pending-output)
  (setq te-pending-output (list 0))
  (make-local-variable 'te-saved-point)
  (setq te-saved-point (point-min))
  (make-local-variable 'te-pending-output-info) ;for the mode line
  (setq te-pending-output-info "")
  (make-local-variable 'inhibit-quit)
  ;(setq inhibit-quit t)
  (make-local-variable 'te-log-buffer)
  (setq te-log-buffer nil)
  (make-local-variable 'te-more-count)
  (setq te-more-count -1)
  (make-local-variable 'te-redisplay-count)
  (setq te-redisplay-count terminal-redisplay-interval)
  ;;>> Nothing can be done about this without decruftifying
  ;;>>  emacs keymaps.
  (make-local-variable 'meta-flag) ;sigh
  (setq meta-flag nil)
  ;(use-local-map terminal-mode-map)
  ;; terminal-mode-hook is called above in function terminal-emulator
  )

;;;; what a complete loss

(defun te-quote-arg-for-sh (fuckme)
  (cond ((string-match "\\`[a-zA-Z0-9-+=_.@/:]+\\'"
		       fuckme)
	 fuckme)
	((not (string-match "[$]" fuckme))
	 ;; "[\"\\]" are special to sh and the lisp reader in the same way
	 (prin1-to-string fuckme))
	(t
	 (let ((harder "")
	       (cretin 0)
	       (stupid 0))
	   (while (cond ((>= cretin (length fuckme))
			 nil)
			;; this is the set of chars magic with "..." in `sh'
			((setq stupid (string-match "[\"\\$]"
						    fuckme cretin))
			 t)
			(t (setq harder (concat harder
						(substring fuckme cretin)))
			   nil))
	     (setq harder (concat harder (substring fuckme cretin stupid)
                                  ;; Can't use ?\\ since `concat'
                                  ;; unfortunately does prin1-to-string
                                  ;; on fixna.  Amazing.
				  "\\"
				  (substring fuckme
					     stupid
					     (1+ stupid)))
		   cretin (1+ stupid)))
	   (concat "\"" harder "\"")))))