(facemenu-read-color, list-colors-display)

(facemenu-get-face): Treat all non-nil window-system values alike.
(facemenu-color-equal): Special case for MSDOS.

1 files changed, 87 insertions, 41 deletions

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 3275fbb3e46..3e85ada0812 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -238,6 +238,22 @@ when they are created.")
 requested in `facemenu-keybindings'.")
 (defalias 'facemenu-keymap facemenu-keymap)
 
+
+(defvar facemenu-add-face-function nil
+  "Function called at beginning of text to change or `nil'.
+This function is passed the FACE to set and END of text to change, and must
+return a string which is inserted.  It may set `facemenu-end-add-face'.")
+
+(defvar facemenu-end-add-face nil
+  "String to insert or function called at end of text to change or `nil'.
+This function is passed the FACE to set, and must return a string which is
+inserted.")
+
+(defvar facemenu-remove-face-function nil
+  "When non-`nil' function called to remove faces.
+This function is passed the START and END of text to change.
+May also be `t' meaning to use `facemenu-add-face-function'.")
+
 ;;; Internal Variables
 
 (defvar facemenu-color-alist nil
@@ -280,7 +296,7 @@ typing a character to insert cancels the specification."
       (let ((start (or start (region-beginning)))
             (end (or end (region-end))))
         (facemenu-add-face face start end))
-    (facemenu-self-insert-face face)))
+    (facemenu-add-face face)))
 
 ;;;###autoload
 (defun facemenu-set-foreground (color &optional start end)
@@ -333,15 +349,7 @@ typing a character to insert cancels the specification."
   (facemenu-get-face face)
   (if start 
       (facemenu-add-face face start end)
-    (facemenu-self-insert-face face)))
-
-(defun facemenu-self-insert-face (face)
-  (setq self-insert-face (if (eq last-command self-insert-face-command)
-                             (cons face (if (listp self-insert-face)
-                                            self-insert-face
-                                          (list self-insert-face)))
-                           face)
-        self-insert-face-command this-command))
+    (facemenu-add-face face)))
 
 ;;;###autoload
 (defun facemenu-set-invisible (start end)
@@ -396,22 +404,28 @@ These special properties include `invisible', `intangible' and `read-only'."
 (defun list-text-properties-at (p)
   "Pop up a buffer listing text-properties at LOCATION."
   (interactive "d")
-  (let ((props (text-properties-at p)))
+  (let ((props (text-properties-at p))
+        str)
     (if (null props)
         (message "None")
-      (with-output-to-temp-buffer "*Text Properties*"
-        (princ (format "Text properties at %d:\n\n" p))
-        (while props
-          (princ (format "%-20s %S\n"
-                         (car props) (car (cdr props))))
-          (setq props (cdr (cdr props))))))))
+      (if (and (not (cdr (cdr props)))
+               (< (length (setq str (format "Text property at %d:  %s  %S"
+                                            p (car props) (car (cdr props)))))
+                  (frame-width)))
+          (message str)
+        (with-output-to-temp-buffer "*Text Properties*"
+          (princ (format "Text properties at %d:\n\n" p))
+          (while props
+            (princ (format "%-20s %S\n"
+                           (car props) (car (cdr props))))
+            (setq props (cdr (cdr props)))))))))
 
 ;;;###autoload
 (defun facemenu-read-color (&optional prompt)
   "Read a color using the minibuffer."
   (let ((col (completing-read (or prompt "Color: ") 
                               (or facemenu-color-alist
-                                  (if (or (eq window-system 'x) (eq window-system 'win32))
+                                  (if window-system
                                       (mapcar 'list (x-defined-colors))))
                               nil t)))
     (if (equal "" col)
@@ -425,7 +439,7 @@ If the optional argument LIST is non-nil, it should be a list of
 colors to display.  Otherwise, this command computes a list
 of colors that the current display can handle."
   (interactive)
-  (if (and (null list) (or (eq window-system 'x) (eq window-system 'win32)))
+  (if (and (null list) window-system)
       (progn
         (setq list (x-defined-colors))
         ;; Delete duplicate colors.
@@ -461,31 +475,61 @@ color names mean.  It returns nil if the colors differ or if it can't
 determine the correct answer."
   (cond ((equal a b) t)
         ((and (or (eq window-system 'x) (eq window-system 'win32))
-              (equal (x-color-values a) (x-color-values b))))))
+              (equal (x-color-values a) (x-color-values b))))
+        ((eq window-system 'pc)
+         (and (x-color-defined-p a) (x-color-defined-p b)
+              (eq (msdos-color-translate a) (msdos-color-translate b))))))
 
-(defun facemenu-add-face (face start end)
+(defun facemenu-add-face (face &optional start end)
   "Add FACE to text between START and END.
-For each section of that region that has a different face property, FACE will
-be consed onto it, and other faces that are completely hidden by that will be
-removed from the list.
+If START is `nil' or START to END is empty, add FACE to next typed character
+instead.  For each section of that region that has a different face property,
+FACE will be consed onto it, and other faces that are completely hidden by
+that will be removed from the list.
+If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-`nil'
+they are used to set the face information.
 
 As a special case, if FACE is `default', then the region is left with NO face
 text property.  Otherwise, selecting the default face would not have any
-effect."
-  (interactive "*xFace:\nr")
-  (if (eq face 'default)
-      (remove-text-properties start end '(face default))
-    (let ((part-start start) part-end)
-      (while (not (= part-start end))
-        (setq part-end (next-single-property-change part-start 'face nil end))
-        (let ((prev (get-text-property part-start 'face)))
-          (put-text-property part-start part-end 'face
-                             (if (null prev)
-                                 face
-                               (facemenu-active-faces
-                                (cons face
-                                      (if (listp prev) prev (list prev)))))))
-        (setq part-start part-end)))))
+effect.  See `facemenu-remove-face-function'."
+  (interactive "*xFace: \nr")
+  (if (and (eq face 'default)
+           (not (eq facemenu-remove-face-function t)))
+      (if facemenu-remove-face-function
+          (funcall facemenu-remove-face-function start end)
+        (remove-text-properties start end '(face default)))
+    (if facemenu-add-face-function
+        (save-excursion
+          (if end (goto-char end))
+          (save-excursion
+            (if start (goto-char start))
+            (insert-before-markers
+             (funcall facemenu-add-face-function face end)))
+          (if facemenu-end-add-face
+              (insert (if (stringp facemenu-end-add-face)
+                          facemenu-end-add-face
+                        (funcall facemenu-end-add-face face)))))
+      (if (and start (< start end))
+          (let ((part-start start) part-end)
+            (while (not (= part-start end))
+              (setq part-end (next-single-property-change part-start 'face
+                                                          nil end))
+              (let ((prev (get-text-property part-start 'face)))
+                (put-text-property part-start part-end 'face
+                                   (if (null prev)
+                                       face
+                                     (facemenu-active-faces
+                                      (cons face
+                                            (if (listp prev)
+                                                prev
+                                              (list prev)))))))
+              (setq part-start part-end)))
+        (setq self-insert-face (if (eq last-command self-insert-face-command)
+                                   (cons face (if (listp self-insert-face)
+                                                  self-insert-face
+                                                (list self-insert-face)))
+                                 face)
+              self-insert-face-command this-command)))))
 
 (defun facemenu-active-faces (face-list &optional frame)
   "Return from FACE-LIST those faces that would be used for display.
@@ -520,10 +564,12 @@ or nil if given a bad color."
                  (color (substring name 3)))
             (cond ((string-match "^fg:" name)
                    (set-face-foreground face color)
-                   (and (or (eq window-system 'x) (eq window-system 'win32)) (x-color-defined-p color)))
+                   (and window-system
+                        (x-color-defined-p color)))
                   ((string-match "^bg:" name)
                    (set-face-background face color)
-                   (and (or (eq window-system 'x) (eq window-system 'win32)) (x-color-defined-p color)))
+                   (and window-system
+                        (x-color-defined-p color)))
                   (t))))
       symbol))