Commits

Anonymous committed 893b3f4

ANSI color support

Comments (0)

Files changed (4)

+1998-04-19  Attila Fülöp  <atf@loa.neuro.biologie.fu-berlin.de> <attilaf@zedat.fu-berlin.de>
+
+	* term.el (term-mode): Added support for ansi colors.
+
 1998-01-24  SL Baur  <steve@altair.xemacs.org>
 
 	* Makefile (VERSION): Update to package standard 1.0.
 # the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 # Boston, MA 02111-1307, USA.
 
-VERSION = 1.03
+VERSION = 1.04
 AUTHOR_VERSION =
 MAINTAINER = XEmacs Development Team <xemacs-beta@xemacs.org>
 PACKAGE = eterm
 
 Compared to terminal.el:
 * Uses standard ANSI (vt102) escape sequences.
-* High-lighting (inverse video, underline, bold) are supported.
+* High-lighting (inverse video, underline, bold, ansi colors) are supported.
 * Fully integrated into shell mode.
 * Can switch back and forth between character mode (acts like xterm)
   and line mode (acts like old shell mode).
 
 ;; Author: Per Bothner <bothner@cygnus.com>
 ;; Based on comint mode written by: Olin Shivers <shivers@cs.cmu.edu>
+;; Extended by Attila Fülöp <atf@loa.neuro.biologie.fu-berlin.de> 
+;;   <attilaf@zedat.fu-berlin.de> to support ANSI colors (c) 1998 ~~~
 ;; Keyword: processes
 
 ;; This file is part of GNU Emacs.
 ;;		we want suppressed.
 (defvar term-terminal-parameter)
 (defvar term-terminal-previous-parameter)
-(defvar term-current-face 'default)
+(defvar term-current-face 'term-default-face)
+;; need to keep track of atrributes and back/foreground colors for ansi color sup. ~~~
+(defvar term-terminal-previous-previous-parameter)
+(defvar term-current-fi 0)
+(defvar term-current-fg 0)
+(defvar term-current-bg 7)
+(defvar term-fg)
+(defvar term-bg)
+(defvar term-attr)
+(defvar term-fi)
+(defvar term-tcf)
+(defvar term-fnts)
+(defvar tps)
+(defvar ttp)
+(defvar iii) 
+ ;; ~~~
+
 (defvar term-scroll-start 0) ;; Top-most line (inclusive) of scrolling region.
 (defvar term-scroll-end) ;; Number of line (zero-based) after scrolling region.
 (defvar term-pager-count nil) ;; If nil, paging is disabled.
     (make-local-variable 'term-pending-delete-marker)
     (setq term-pending-delete-marker (make-marker))
     (make-local-variable 'term-current-face)
+    (make-local-variable 'term-current-bg) ;; ~~~
+    (make-local-variable 'term-current-fg) ;; ~~~
+    (make-local-variable 'term-current-fi) ;; ~~~
+    (make-local-variable 'term-tcf) ;; array of color faces ~~~
+    ;; (make-local-variable 'termfnts) -- nop global
+
     (make-local-variable 'term-pending-frame)
+
     (setq term-pending-frame nil)
     (run-hooks 'term-mode-hook)
     (term-if-xemacs
 	(setq term-input-ring (make-ring term-input-ring-size)))
     (term-update-mode-line))
 
+
+  ;; ~~~ ansi color stuff: we use a  font for each color and attr (normal bold ul inverted)
+  ;; since this makes up to 8*8*4 = 256 fonts we allocate the fonts uppon first request.
+  ;; see below for more comment
+
+  ;; make faces if they dont exis
+  (cond ((eq (find-face 'red) nil)
+	 (make-face 'red)
+	 (set-face-foreground 'red "red")))
+  (cond ((eq (find-face 'green) nil)
+	 (make-face 'green)
+	 (set-face-foreground 'green "green")))
+  (cond ((eq (find-face 'yellow) nil)
+	 (make-face 'yellow)
+	 (set-face-foreground 'yellow "yellow")))
+  (cond ((eq (find-face 'blue) nil)
+	 (make-face 'blue)
+	 (set-face-foreground 'blue "blue")))
+  (cond ((eq (find-face 'magenta) nil)
+	 (make-face 'magenta )
+	 (set-face-foreground 'magenta "magenta")))
+  (cond ((eq (find-face 'cyan) nil)
+	 (make-face 'cyan)
+	 (set-face-foreground 'cyan "cyan")))
+  (cond ((eq (find-face 'white) nil)
+	 (make-face 'white )
+	 (set-face-foreground 'white "white")))
+
+  ;; use this fonts to tweak the appearance of the ansi colors the term shows
+  ;; the names are quite intuitive
+  (setq term-tcf [default red green yellow blue magenta cyan white])
+  (setq term-fnts [ ;; normal
+	term-default-face term-red-face term-green-face term-yellow-face 
+	term-blue-face term-magenta-face term-cyan-face term-white-face
+	;; bold
+	term-default-bold-face term-red-bold-face term-green-bold-face term-yellow-bold-face 
+	term-blue-bold-face term-magenta-bold-face term-cyan-bold-face term-white-bold-face
+	;; underlined
+	term-default-ul-face term-red-ul-face term-green-ul-face term-yellow-ul-face 
+	term-blue-ul-face term-magenta-ul-face term-cyan-ul-face term-white-ul-face
+	;; inverted
+	term-default-inv-face term-red-inv-face term-green-inv-face term-yellow-inv-face 
+	term-blue-inv-face term-magenta-inv-face term-cyan-inv-face term-white-inv-face
+	])
+
+
+  ;; fixme how to set background pixmap/color, foreground of whole frame/window ?
+  (setq term-do-invert nil)
+  ;; (setq term-font "vga")
+
+  (setq fi 0)
+  (while (< fi 8)
+    (cond ((eq (find-face (aref term-fnts fi)) nil)
+	   (copy-face (aref term-tcf fi) (aref term-fnts fi))))
+    (cond ((and (eq 0 fi) term-do-invert)
+	   (invert-face 'term-default-face)
+	   ))
+    (cond ((boundp 'term-font)
+	   (set-face-font (aref term-fnts fi) term-font)
+	   ))
+    (cond ((eq (find-face (aref term-fnts (+ fi 8))) nil)
+	   (copy-face (aref term-fnts fi) (aref term-fnts (+ fi 8)))
+	   (set-face-parent (aref term-fnts (+ fi 8)) (aref term-fnts fi)) 
+	   (make-face-bold (aref term-fnts (+ fi 8)))
+	   ))
+    (cond ((eq (find-face (aref term-fnts (+ fi 16))) nil)
+	   (copy-face (aref term-fnts fi) (aref term-fnts (+ fi 16)))
+	   (set-face-parent (aref term-fnts (+ fi 16)) (aref term-fnts fi)) 
+	   (set-face-underline-p (aref term-fnts (+ fi 16)) t)
+	   ))
+    (cond ((eq (find-face (aref term-fnts (+ fi 24))) nil)
+	   (copy-face (aref term-fnts fi) (aref term-fnts (+ fi 24)))
+	   ;; (set-face-parent (aref term-fnts (+ fi 24)) (aref term-fnts fi)) 
+	   (invert-face (aref term-fnts (+ fi 24)))
+	   ))
+    (setq fi (1+ fi))
+    )
+  (set-face-background 'term-white-inv-face (face-background 'term-default-face))
+
+ (setq term-fnts-tmp-faces [
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 
+	nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
+	])
+
+;; ~~~ end ansi color stuff 
+
+
+
+
+
 (if term-mode-map
     nil
   (setq term-mode-map (make-sparse-keymap))
   (define-key term-mode-map "\C-c\C-j" 'term-line-mode)
   (define-key term-mode-map "\C-c\C-q" 'term-pager-toggle)
 
-  (copy-face 'default 'term-underline-face)
-  (set-face-underline-p 'term-underline-face t)
-
 ;  ;; completion:
 ;  (define-key term-mode-map [menu-bar completion] 
 ;    (cons "Complete" (make-sparse-keymap "Complete")))
 		     (cond ((eq char ?\133) ;; ?\133 = ?[
 			    (make-local-variable 'term-terminal-parameter)
 			    (make-local-variable 'term-terminal-previous-parameter)
+			    (make-local-variable 'term-terminal-previous-previous-parameter)   ;; ~~~
 			    (setq term-terminal-parameter 0)
-			    (setq term-terminal-previous-parameter 0)
+			    (setq term-terminal-previous-parameter -1)
+			    (setq term-terminal-previous-previous-parameter -1)  ;; ~~~
 			    (setq term-terminal-state 3))
 			   ((eq char ?D) ;; scroll forward
 			    (term-handle-deferred-scroll)
 			    (setq term-terminal-parameter
 				  (+ (* 10 term-terminal-parameter) (- char ?0))))
 			   ((eq char ?\073 ) ; ?;
+			    ;; ~~~ we need three params for ANSI colors
+			    (setq term-terminal-previous-previous-parameter
+					 term-terminal-previous-parameter) ;; ~~~
 			    (setq term-terminal-previous-parameter
 				  term-terminal-parameter)
 			    (setq term-terminal-parameter 0))
 	   (setq term-insert-mode nil))
 	  ((eq term-terminal-parameter 47)
 	   (term-switch-to-alternate-sub-buffer nil))))
+
    ;; \E[m - Set/reset standard mode
+   ;; ~~~ and handle ansi colours; added isb isb@loa.neuro.biologie.fu-berlin.de ~~~
+   ;; we can have up to 3 params: attributes 0-8; fg color 30 - 37; bg color 40 - 47; 
+   ;; since this makes up to 8*8*4 = 256 faces we allocate the faces upon first request.
+   ;; (this may be ugly lisp code but as an 'everything but a lisp' hacker i am just happy to get things going)
+   ;; The face stuff seems to be quite slow. If you use a lot of faces (eg start BitchX) things slow down
+   ;; On a pentium 133 this code is at 3s - 5s per redraw. On 5 - 10 times faster machine it may be usable 
+   ;; Tools like color-ls and similar, which dont use backgrounds colors excessively, on the other
+   ;; hand are usable on a p133
+
    ((eq char ?m)
-    (cond ((eq term-terminal-parameter 7)
-	   (setq term-current-face 'highlight))
-	  ((eq term-terminal-parameter 4)
-	   (setq term-current-face 'term-underline-face))
-	  ((eq term-terminal-parameter 1)
-	   (setq term-current-face 'bold))
-	  (t (setq term-current-face 'default))))
+    (make-local-variable 'term-fg)
+    (make-local-variable 'term-bg)
+    (make-local-variable 'term-attr)
+    (make-local-variable 'term-fi)
+    (make-local-variable 'tps)
+    (make-local-variable 'ttp)
+    (make-local-variable 'iii)
+
+    (setq term-fg term-current-fg)
+    (setq term-bg term-current-bg)
+    (setq term-fi term-current-fi)
+    (setq term-attr -1)
+    (setq ttp 0)
+    (setq iii 0)
+    (setq term-f-change nil)
+
+    (setq tps [ term-terminal-parameter term-terminal-previous-parameter
+					term-terminal-previous-previous-parameter ])
+    (while (< iii 3)
+      (setq ttp (eval (aref tps iii)))
+      (cond ((and (>= ttp 0) (<= ttp 8))
+	     ;; ~~~ attr found 
+	     (setq term-attr ttp)
+	     )
+	    ((and (>= ttp 30) (<= ttp 37))
+	     ;; found fg. color
+	     (setq term-fg (- ttp 30 ))
+	     )
+	    ((and (>= ttp 40) (<= ttp 47))
+	     ;; found bg. color
+	     (setq term-bg (- ttp 40 ))
+	     ))
+      (setq iii (+ iii 1))
+      )
+
+    ;; process attr. We support bold, underlined, and inversed. Not sup: blink, concealed 
+    (cond ((eq term-attr 0) ;; ^[[x;0m resets only font attribute whereas  ^[[0m or ^[[m resets everything
+	   (setq term-fi 0)    ;; Is this right? Just a guess
+	   (cond ((and (eq term-terminal-previous-parameter -1) (eq term-terminal-previous-previous-parameter -1))
+		  (setq term-fg 0)
+		  (setq term-bg 7)
+		  (setq term-f-change t)
+		  ; (message "%s %d %d %d" "0m found" term-attr term-terminal-previous-parameter 
+		  ;	   term-terminal-previous-previous-parameter)
+		  ;  ))
+	   )))
+	  ((eq term-attr 1) ;; bold -> take bold font
+	   (setq term-fi 1)
+	   )
+	  ((eq term-attr 4) ;; underscore
+	   (setq term-fi 2)
+	   )
+	  ((eq term-attr 5) ;; blink
+	   )
+	  ((eq term-attr 7) ;; reverse
+	   (setq term-fi 3)
+	   )
+	  ((eq term-attr 8) ;; concealed ??
+	   )
+	  )
+    (cond ((or term-f-change
+	       (not (eq term-current-fi term-fi)) 
+	       (not (eq term-current-bg term-bg)) 
+	       (not (eq term-current-fg term-fg))
+	       )
+	   ;; found font change, test if if we alread created this font
+	   (cond ((eq (aref term-fnts-tmp-faces (+ (* term-fi 8 8)  (* term-bg 8) term-fg)) nil)
+		  ;; new face, create it
+		  (setq bxt-tmp-face (make-symbol (concat "zzterm-" (int-to-string term-fi) "-" 
+						(int-to-string term-fg) "-"	(int-to-string term-bg) "-face")))
+
+		  ;; (message "%s %s %d %d %d  -- %d" "Setting current faces" (symbol-name bxt-tmp-face) 
+		  ;;	    term-fi term-fg term-bg
+		  ;;	    (+ (* term-fi 8 8)  (* term-bg 8) term-fg) bxt-tmp-face)
+
+		  (make-empty-face bxt-tmp-face 
+				   "Do not mess with this, use term-color-spec-face instead" nil)  ;;t)
+		  (copy-face (aref term-fnts (+ term-fg (* term-fi 8))) bxt-tmp-face)
+		  (set-face-parent bxt-tmp-face (aref term-fnts (+ term-fg (* term-fi 8)))) 
+		  (set-face-background bxt-tmp-face (face-background (aref term-fnts (+ term-bg (* 3 8)))))
+		  ;; (set-face-doc-string bxt-tmp-face "Do not mess with this.")
+		  (aset term-fnts-tmp-faces  (+ (* term-fi 8 8)  (* term-bg 8) term-fg) bxt-tmp-face)
+
+		  ))
+	   (setq term-current-face (aref term-fnts-tmp-faces (+ (* term-fi 8 8)  (* term-bg 8) term-fg))) 
+	   ))
+    (setq term-current-fi term-fi)
+    (setq term-current-fg term-fg)
+    (setq term-current-bg term-bg)
+    ;; (message " ")
+
+    )
+;; ~~~ ansi colors done
+
+;   ((eq char ?m)
+;    (cond ((eq term-terminal-parameter 7) 
+;	   (setq term-current-face 'highlight))
+;	  ((eq term-terminal-parameter 4)
+;	   (setq term-current-face 'term-underline-face))
+;	  ((eq term-terminal-parameter 1)
+;	   (setq term-current-face 'bold))
+;	  (t (setq term-current-face 'default)))))
+
    ;; \E[6n - Report cursor position
    ((eq char ?n)
     (term-handle-deferred-scroll)