LM *!«»
(defvar glyphs-allow-string-glyphs (not window-system))
(defvar glyphs-allow-face-glyphs
(or window-system
(>= emacs-major-version 21)))
(defvar glyphs-allow-string-glyphs-in-dangerous-positions
(cond ((= emacs-major-version 20)
(>= emacs-minor-version 4))
((= emacs-major-version 21)
(>= emacs-minor-version 3))))
(defvar glyphs-allow-vt-chars (not window-system))
(defvar glyphs-allow-utf8-chars (equal (getenv "TERM") "linux"))
(defvar glyphs-prefer-string-glyphs nil)
(defvar glyphs-face-to-colorstr-alist ())
(defun glyphs-make-string (colorstr char encode-utf8)
(let ((str (if encode-utf8
(format "\e%%G\xef%c%c\e%%@"
(+ 128 (logand (lsh char -6) 7))
(+ 128 (logand char 63)))
(format "%c" char))))
(if colorstr
(setq str (format "\e[%sm%s\e[m" colorstr str)))
str))
(defun glyphs-set-string-glyph (position colorstr char encode-utf8)
(let ((str (glyphs-make-string colorstr char encode-utf8)))
(aset standard-display-table
position (vector (create-glyph str)))
str))
(defun glyphs-char-type (char)
(cond ((or (and (>= char 32) (<= char 126))
(and (>= char 160) (<= char 255)))
'normal)
((and (>= char 128) (<= char 159) (not (= char 155)))
'vt)
(t 'utf8)))
(defun glyphs-set-string-glyph-safe (position colorstr char)
(if glyphs-allow-string-glyphs
(let ((char-type (glyphs-char-type char)))
(if (and (cond ((eq char-type 'normal) t)
((eq char-type 'vt) glyphs-allow-vt-chars)
((eq char-type 'utf8) glyphs-allow-utf8-chars))
(cond ((and (>= position 128) (<= position 159))
glyphs-allow-string-glyphs-in-dangerous-positions)
(t t)))
(glyphs-set-string-glyph position colorstr char
(eq char-type 'utf8))))))
(defun glyphs-set-face-glyph (position face char)
(aset standard-display-table
position (vector (if face (logior char (ash (face-id face) 19))
char))))
(defun glyphs-set-face-glyph-safe (position face char)
(if (and glyphs-allow-face-glyphs
(eq (glyphs-char-type char) 'normal))
(glyphs-set-face-glyph position face char)))
(defun glyphs-define-face (face &optional bg fg bold colorstr)
(make-face face)
(if fg (set-face-foreground face fg))
(if bg (set-face-background face bg))
(if bold (set-face-bold-p face bold))
(setq glyphs-face-to-colorstr-alist
(cons (cons face colorstr) glyphs-face-to-colorstr-alist)))
(defun glyphs-colorstr-for (face)
(cdr (assoc face glyphs-face-to-colorstr-alist)))
(defun ee-faceid-to-face (faceid facelist)
(if facelist
(if (= faceid (face-id (car facelist)))
(car facelist)
(ee-faceid-to-face faceid (cdr facelist)))))
(defun ee-faceandchar-to-list (n)
(let* ((faceid (ash n -19))
(face (ee-faceid-to-face faceid (face-list)))
(char (logand n 524287))
(charstr (format "%c" char)))
`(,n -> (,faceid -> ,face) (,char = ,charstr))))
(defun ee-n-to-stringglyph (n)
(if (and glyph-table (< n (length glyph-table)))
(let ((s (aref glyph-table n)))
`(,n -> ,s))))
(defun find-eglyph (pos)
(let* ((posstr (format "%c" pos))
(v (aref standard-display-table pos))
(descr
(if (arrayp v)
(let ((v0 (aref v 0)))
(or (ee-n-to-stringglyph v0)
(ee-faceandchar-to-list v0)))
'(no glyph))))
`((,pos = ,posstr) -> ,v ,descr)))
*«
««»»
(defun glyphs-set-safe-1 (face pos char)
(if glyphs-prefer-string-glyphs
(or (glyphs-set-string-glyph-safe pos (glyphs-colorstr-for face) char)
(glyphs-set-face-glyph-safe position face char))
(or (glyphs-set-face-glyph-safe position face char)
(glyphs-set-string-glyph-safe pos (glyphs-colorstr-for face) char))))
(defun glyphs-set (face position char &rest rest)
(let ((rslt (glyphs-set-safe-1 face position char)))
(if rest (apply 'glyphs-set face rest)
rslt)))
(defun glyphs-set-basic ()
(standard-display-8bit 160 254)
(glyphs-define-face 'glyphs-face-red nil "red" nil "31")
(glyphs-define-face 'glyphs-face-blue nil "blue" nil "34")
(glyphs-define-face 'glyphs-face-bluebg "blue" nil nil "44")
(glyphs-define-face 'glyphs-face-yellow-on-red "red" "yellow" t "1;33;41")
(glyphs-define-face 'glyphs-face-bang "red" "blue" nil "1;31;41")
(glyphs-set 'glyphs-face-bluebg 8 ?\ )
(glyphs-set 'glyphs-face-blue 13 ?M)
(glyphs-set 'glyphs-face-red 15 ?*)
(glyphs-set 'glyphs-face-bang 155 ?!)
(glyphs-set 'glyphs-face-yellow-on-red ?\^L ?L)
(glyphs-set 'glyphs-face-green ?« ?« ?» ?»)
)
(defface glyphs-face-green
'((((class color) (background dark)) (:foreground "green"))
(((class color) (background light)) (:foreground "forest green"))
(t (:bold t)))
"Face for the glyphs `<<' and `>>'.")
LM*!«»
«»