X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b61dfbe20b281b3960be19896b44faf25d0e06d2..a3dae87a1b5405d2bffde7c2d829a5dbfc7ff274:/lisp/facemenu.el

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 20b86676ea..1b42aa9ea7 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -1,10 +1,10 @@
 ;;; facemenu.el --- create a face menu for interactively adding fonts to text
 
-;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1996, 2001-2011 Free Software Foundation, Inc.
 
 ;; Author: Boris Goldowsky <boris@gnu.org>
 ;; Keywords: faces
+;; Package: emacs
 
 ;; This file is part of GNU Emacs.
 
@@ -357,7 +357,7 @@ inserted.  Moving point or switching buffers before
 typing a character to insert cancels the specification."
   (interactive (list (progn
 		       (barf-if-buffer-read-only)
-		       (facemenu-read-color "Foreground color: "))
+		       (read-color "Foreground color: "))
 		     (if (and mark-active (not current-prefix-arg))
 			 (region-beginning))
 		     (if (and mark-active (not current-prefix-arg))
@@ -379,7 +379,7 @@ inserted.  Moving point or switching buffers before
 typing a character to insert cancels the specification."
   (interactive (list (progn
 		       (barf-if-buffer-read-only)
-		       (facemenu-read-color "Background color: "))
+		       (read-color "Background color: "))
 		     (if (and mark-active (not current-prefix-arg))
 			 (region-beginning))
 		     (if (and mark-active (not current-prefix-arg))
@@ -461,42 +461,7 @@ These special properties include `invisible', `intangible' and `read-only'."
     (remove-text-properties
      start end '(invisible nil intangible nil read-only nil))))
 
-(defun facemenu-read-color (&optional prompt)
-  "Read a color using the minibuffer."
-  (let* ((completion-ignore-case t)
-	 (color-list (or facemenu-color-alist (defined-colors)))
-	 (completer
-	  (lambda (string pred all-completions)
-	    (if all-completions
-		(or (all-completions string color-list pred)
-		    (if (color-defined-p string)
-			(list string)))
-	      (or (try-completion string color-list pred)
-		  (if (color-defined-p string)
-		      string)))))
-	 (col (completing-read (or prompt "Color: ") completer nil t)))
-    (if (equal "" col)
-	nil
-      col)))
-
-(defun color-rgb-to-hsv (r g b)
-  "For R, G, B color components return a list of hue, saturation, value.
-R, G, B input values should be in [0..65535] range.
-Output values for hue are integers in [0..360] range.
-Output values for saturation and value are integers in [0..100] range."
-  (let* ((r (/ r 65535.0))
-	 (g (/ g 65535.0))
-	 (b (/ b 65535.0))
-	 (max (max r g b))
-	 (min (min r g b))
-	 (h (cond ((= max min) 0)
-		  ((= max r) (mod (+ (* 60 (/ (- g b) (- max min))) 360) 360))
-		  ((= max g) (+ (* 60 (/ (- b r) (- max min))) 120))
-		  ((= max b) (+ (* 60 (/ (- r g) (- max min))) 240))))
-	 (s (cond ((= max 0) 0)
-		  (t (- 1 (/ min max)))))
-	 (v max))
-    (list (round h) (round s 0.01) (round v 0.01))))
+(defalias 'facemenu-read-color 'read-color)
 
 (defcustom list-colors-sort nil
   "Color sort order for `list-colors-display'.
@@ -524,6 +489,7 @@ and excludes grayscale colors."
   "Return a list of keys for sorting colors depending on `list-colors-sort'.
 COLOR is the name of the color.  When return value is nil,
 filter out the color from the output."
+  (require 'color)
   (cond
    ((null list-colors-sort) color)
    ((eq list-colors-sort 'name)
@@ -533,12 +499,12 @@ filter out the color from the output."
    ((eq (car-safe list-colors-sort) 'rgb-dist)
     (color-distance color (cdr list-colors-sort)))
    ((eq list-colors-sort 'hsv)
-    (apply 'color-rgb-to-hsv (color-values color)))
+    (apply 'color-rgb-to-hsv (color-name-to-rgb color)))
    ((eq (car-safe list-colors-sort) 'hsv-dist)
-    (let* ((c-rgb (color-values color))
+    (let* ((c-rgb (color-name-to-rgb color))
 	   (c-hsv (apply 'color-rgb-to-hsv c-rgb))
 	   (o-hsv (apply 'color-rgb-to-hsv
-			 (color-values (cdr list-colors-sort)))))
+			 (color-name-to-rgb (cdr list-colors-sort)))))
       (unless (and (eq (nth 0 c-rgb) (nth 1 c-rgb)) ; exclude grayscale
 		   (eq (nth 1 c-rgb) (nth 2 c-rgb)))
 	;; 3D Euclidean distance (sqrt is not needed for sorting)
@@ -596,17 +562,17 @@ You can change the color sort order by customizing `list-colors-sort'."
       (let ((lc (nthcdr (1- (display-color-cells)) list)))
 	(if lc
 	    (setcdr lc nil)))))
-  (let ((buf (get-buffer-create "*Colors*")))
-    (with-current-buffer buf
+  (unless buffer-name
+    (setq buffer-name "*Colors*"))
+  (with-help-window buffer-name
+    (with-current-buffer standard-output
       (erase-buffer)
-      (setq truncate-lines t)
-      ;; Display buffer before generating content to allow
-      ;; `list-colors-print' to get the right window-width.
-      (pop-to-buffer buf)
       (list-colors-print list callback)
-      (set-buffer-modified-p nil)))
-  (if callback
-      (message "Click on a color to select it.")))
+      (set-buffer-modified-p nil)
+      (setq truncate-lines t)))
+  (when callback
+    (pop-to-buffer buffer-name)
+    (message "Click on a color to select it.")))
 
 (defun list-colors-print (list &optional callback)
   (let ((callback-fn
@@ -623,30 +589,19 @@ You can change the color sort order by customizing `list-colors-sort'."
       (let* ((opoint (point))
 	     (color-values (color-values (car color)))
 	     (light-p (>= (apply 'max color-values)
-			  (* (car (color-values "white")) .5)))
-	     (max-len (max (- (window-width) 33) 20)))
+			  (* (car (color-values "white")) .5))))
 	(insert (car color))
 	(indent-to 22)
 	(put-text-property opoint (point) 'face `(:background ,(car color)))
 	(put-text-property
 	 (prog1 (point)
 	   (insert " ")
-	   (if (cdr color)
-	       ;; Insert as many color names as possible, fitting max-len.
-	       (let ((names (list (car color)))
-		     (others (cdr color))
-		     (len (length (car color)))
-		     newlen)
-		 (while (and others
-			     (< (setq newlen (+ len 2 (length (car others))))
-				max-len))
-		   (setq len newlen)
-		   (push (pop others) names))
-		 (insert (mapconcat 'identity (nreverse names) ", ")))
-	     (insert (car color))))
+	   ;; Insert all color names.
+	   (insert (mapconcat 'identity color ",")))
 	 (point)
 	 'face (list :foreground (car color)))
-	(indent-to (max (- (window-width) 8) 44))
+	(insert (propertize " " 'display '(space :align-to (- right 9))))
+	(insert " ")
 	(insert (propertize
 		 (apply 'format "#%02x%02x%02x"
 			(mapcar (lambda (c) (lsh c -8))
@@ -654,7 +609,7 @@ You can change the color sort order by customizing `list-colors-sort'."
 		 'mouse-face 'highlight
 		 'help-echo
 		 (let ((hsv (apply 'color-rgb-to-hsv
-				   (color-values (car color)))))
+				   (color-name-to-rgb (car color)))))
 		   (format "H:%d S:%d V:%d"
 			   (nth 0 hsv) (nth 1 hsv) (nth 2 hsv)))))
 	(when callback
@@ -699,6 +654,22 @@ determine the correct answer."
   (cond ((equal a b) t)
 	((equal (color-values a) (color-values b)))))
 
+
+(defvar facemenu-self-insert-data nil)
+
+(defun facemenu-post-self-insert-function ()
+  (when (and (car facemenu-self-insert-data)
+             (eq last-command (cdr facemenu-self-insert-data)))
+    (put-text-property (1- (point)) (point)
+                       'face (car facemenu-self-insert-data))
+    (setq facemenu-self-insert-data nil))
+  (remove-hook 'post-self-insert-hook 'facemenu-post-self-insert-function))
+
+(defun facemenu-set-self-insert-face (face)
+  "Arrange for the next self-inserted char to have face `face'."
+  (setq facemenu-self-insert-data (cons face this-command))
+  (add-hook 'post-self-insert-hook 'facemenu-post-self-insert-function))
+
 (defun facemenu-add-face (face &optional start end)
   "Add FACE to text between START and END.
 If START is nil or START to END is empty, add FACE to next typed character
@@ -712,51 +683,52 @@ 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.  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)
-	(if (and start (< start end))
-	    (remove-text-properties start end '(face default))
-	  (setq self-insert-face 'default
-		self-insert-face-command this-command)))
-    (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)))))
+  (cond
+   ((and (eq face 'default)
+         (not (eq facemenu-remove-face-function t)))
+    (if facemenu-remove-face-function
+        (funcall facemenu-remove-face-function start end)
       (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)))
-				      ;; Specify the selected frame
-				      ;; because nil would mean to use
-				      ;; the new-frame default settings,
-				      ;; and those are usually nil.
-				      (selected-frame)))))
-	      (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))))
+          (remove-text-properties start end '(face default))
+        (facemenu-set-self-insert-face 'default))))
+   (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))))))
+   ((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)))
+                                ;; Specify the selected frame
+                                ;; because nil would mean to use
+                                ;; the new-frame default settings,
+                                ;; and those are usually nil.
+                                (selected-frame)))))
+        (setq part-start part-end))))
+   (t
+    (facemenu-set-self-insert-face
+     (if (eq last-command (cdr facemenu-self-insert-data))
+         (cons face (if (listp (car facemenu-self-insert-data))
+                        (car facemenu-self-insert-data)
+                      (list (car facemenu-self-insert-data))))
+       face))))
   (unless (facemenu-enable-faces-p)
     (message "Font-lock mode will override any faces you set in this buffer")))
 
@@ -853,19 +825,13 @@ MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'.
 Return the event type (a symbol) of the added menu entry.
 
 This is called whenever you use a new color."
-  (let (symbol docstring)
+  (let (symbol)
     (unless (color-defined-p color)
       (error "Color `%s' undefined" color))
     (cond ((eq menu 'facemenu-foreground-menu)
-	   (setq docstring
-		 (format "Select foreground color %s for subsequent insertion."
-			 color)
-		 symbol (intern (concat "fg:" color))))
+	   (setq symbol (intern (concat "fg:" color))))
 	  ((eq menu 'facemenu-background-menu)
-	   (setq docstring
-		 (format "Select background color %s for subsequent insertion."
-			 color)
-		 symbol (intern (concat "bg:" color))))
+	   (setq symbol (intern (concat "bg:" color))))
 	  (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'")))
     (unless (facemenu-iterate ; Check if color is already in the menu.
 	     (lambda (m) (and (listp m)
@@ -908,5 +874,4 @@ Returns the non-nil value it found, or nil if all were nil."
 
 (provide 'facemenu)
 
-;; arch-tag: 85f6d02b-9085-420e-b651-0678f0e9c7eb
 ;;; facemenu.el ends here