[Emacs-diffs] /srv/bzr/emacs/trunk r112273: faces.el (read-face-name): Do not override value of arg default, call instead face-at-point

[Roland Winkler]

------------------------------------------------------------
revno: 112273
committer: Roland Winkler <address@hidden>
branch nick: trunk
timestamp: Fri 2013-04-12 20:10:09 -0500
message:
  faces.el (read-face-name): Do not override value of arg default, call instead 
face-at-point
modified:
  lisp/ChangeLog
  lisp/cus-edit.el
  lisp/cus-theme.el
  lisp/face-remap.el
  lisp/facemenu.el
  lisp/faces.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2013-04-12 13:56:03 +0000
+++ b/lisp/ChangeLog    2013-04-13 01:10:09 +0000
@@ -1,3 +1,21 @@
+2013-04-12  Roland Winkler  <address@hidden>
+
+       * faces.el (read-face-name): Do not override value of arg default.
+       Allow single faces and strings as default values.  Remove those
+       elements from return value that are not faces.
+       (describe-face): Simplify.
+       (face-at-point): New optional args thing and multiple so that this
+       function can provide the same functionality previously provided by
+       read-face-name.
+       (make-face-bold, make-face-unbold, make-face-italic)
+       (make-face-unitalic, make-face-bold-italic, invert-face)
+       (modify-face, read-face-and-attribute): Use face-at-point.
+
+       * cus-edit.el (customize-face, customize-face-other-window)
+       * cus-theme.el (custom-theme-add-face)
+       * face-remap.el (buffer-face-set)
+       * facemenu.el (facemenu-set-face): Use face-at-point.
+
 2013-04-12  Michael Albinus  <address@hidden>
 
        * info.el (Info-file-list-for-emacs): Add "tramp" and "dbus".

=== modified file 'lisp/cus-edit.el'
--- a/lisp/cus-edit.el  2013-02-12 04:46:18 +0000
+++ b/lisp/cus-edit.el  2013-04-13 01:10:09 +0000
@@ -1319,7 +1319,8 @@
 
 Interactively, when point is on text which has a face specified,
 suggest to customize that face, if it's customizable."
-  (interactive (list (read-face-name "Customize face" "all faces" t)))
+  (interactive (list (read-face-name "Customize face"
+                                     (or (face-at-point t t) "all faces") t)))
   (if (member face '(nil ""))
       (setq face (face-list)))
   (if (and (listp face) (null (cdr face)))
@@ -1350,7 +1351,8 @@
 
 Interactively, when point is on text which has a face specified,
 suggest to customize that face, if it's customizable."
-  (interactive (list (read-face-name "Customize face" "all faces" t)))
+  (interactive (list (read-face-name "Customize face"
+                                     (or (face-at-point t t) "all faces") t)))
   (customize-face face t))
 
 (defalias 'customize-customized 'customize-unsaved)

=== modified file 'lisp/cus-theme.el'
--- a/lisp/cus-theme.el 2013-01-01 09:11:05 +0000
+++ b/lisp/cus-theme.el 2013-04-13 01:10:09 +0000
@@ -263,7 +263,7 @@
 (defun custom-theme-add-face (face &optional spec)
   "Add a widget for FACE (a symbol) to the *New Custom Theme* buffer.
 SPEC, if non-nil, should be a face spec to which to set the widget."
-  (interactive (list (read-face-name "Face name" nil nil) nil))
+  (interactive (list (read-face-name "Face name" (face-at-point t))))
   (unless (or (facep face) spec)
     (error "`%s' has no face definition" face))
   (let ((entry (assq face custom-theme-faces)))

=== modified file 'lisp/face-remap.el'
--- a/lisp/face-remap.el        2013-01-01 09:11:05 +0000
+++ b/lisp/face-remap.el        2013-04-13 01:10:09 +0000
@@ -378,7 +378,7 @@
 
 This function makes the variable `buffer-face-mode-face' buffer
 local, and sets it to FACE."
-  (interactive (list (read-face-name "Set buffer face")))
+  (interactive (list (read-face-name "Set buffer face" (face-at-point t))))
   (while (and (consp specs) (null (cdr specs)))
     (setq specs (car specs)))
   (if (null specs)

=== modified file 'lisp/facemenu.el'
--- a/lisp/facemenu.el  2013-03-27 16:03:15 +0000
+++ b/lisp/facemenu.el  2013-04-13 01:10:09 +0000
@@ -329,7 +329,7 @@
 if `facemenu-listed-faces' says to do that."
   (interactive (list (progn
                       (barf-if-buffer-read-only)
-                      (read-face-name "Use face"))
+                      (read-face-name "Use face" (face-at-point t)))
                     (if (and mark-active (not current-prefix-arg))
                         (region-beginning))
                     (if (and mark-active (not current-prefix-arg))

=== modified file 'lisp/faces.el'
--- a/lisp/faces.el     2013-04-04 02:12:25 +0000
+++ b/lisp/faces.el     2013-04-13 01:10:09 +0000
@@ -757,7 +757,8 @@
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility.
 Use `set-face-attribute' for finer control of the font weight."
-  (interactive (list (read-face-name "Make which face bold")))
+  (interactive (list (read-face-name "Make which face bold"
+                                     (face-at-point t))))
   (set-face-attribute face frame :weight 'bold))
 
 
@@ -765,7 +766,8 @@
   "Make the font of FACE be non-bold, if possible.
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility."
-  (interactive (list (read-face-name "Make which face non-bold")))
+  (interactive (list (read-face-name "Make which face non-bold"
+                                     (face-at-point t))))
   (set-face-attribute face frame :weight 'normal))
 
 
@@ -774,7 +776,8 @@
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility.
 Use `set-face-attribute' for finer control of the font slant."
-  (interactive (list (read-face-name "Make which face italic")))
+  (interactive (list (read-face-name "Make which face italic"
+                                     (face-at-point t))))
   (set-face-attribute face frame :slant 'italic))
 
 
@@ -782,7 +785,8 @@
   "Make the font of FACE be non-italic, if possible.
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility."
-  (interactive (list (read-face-name "Make which face non-italic")))
+  (interactive (list (read-face-name "Make which face non-italic"
+                                     (face-at-point t))))
   (set-face-attribute face frame :slant 'normal))
 
 
@@ -791,7 +795,8 @@
 FRAME nil or not specified means change face on all frames.
 Argument NOERROR is ignored and retained for compatibility.
 Use `set-face-attribute' for finer control of font weight and slant."
-  (interactive (list (read-face-name "Make which face bold-italic")))
+  (interactive (list (read-face-name "Make which face bold-italic"
+                                     (face-at-point t))))
   (set-face-attribute face frame :weight 'bold :slant 'italic))
 
 
@@ -911,7 +916,7 @@
 If FACE specifies neither foreground nor background color,
 set its foreground and background to the background and foreground
 of the default face.  Value is FACE."
-  (interactive (list (read-face-name "Invert face")))
+  (interactive (list (read-face-name "Invert face" (face-at-point t))))
   (let ((fg (face-attribute face :foreground frame))
        (bg (face-attribute face :background frame)))
     (if (not (and (eq fg 'unspecified) (eq bg 'unspecified)))
@@ -929,85 +934,54 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun read-face-name (prompt &optional default multiple)
-  "Read one or more face names, defaulting to the face(s) at point.
-PROMPT should be a prompt string; it should not end in a space or
-a colon.
-
-The optional argument DEFAULT specifies the default face name(s)
-to return if the user just types RET.  If its value is non-nil,
-it should be a list of face names (symbols or strings); in that case,
-the default return value is the `car' of DEFAULT (if the argument
-MULTIPLE is non-nil), or DEFAULT (if MULTIPLE is nil).  See below
-for the meaning of MULTIPLE.
-
-If DEFAULT is nil, the list of default face names is taken from
-the symbol at point and the `read-face-name' property of the text at point,
-or, if that is nil, from the `face' property of the text at point.
+  "Read one or more face names, prompting with PROMPT.
+PROMPT should not end in a space or a colon.
+
+Return DEFAULT if the user enters the empty string.
+If DEFAULT is non-nil, it should be a list of face names (symbols or strings).
+In that case, return the `car' of DEFAULT (if MULTIPLE is non-nil),
+or DEFAULT (if MULTIPLE is nil).  See below for the meaning of MULTIPLE.
+DEFAULT can also be a single face.
 
 This function uses `completing-read-multiple' with \"[ \\t]*,[ \\t]*\"
-as the separator regexp.  Thus, the user may enter multiple face
-names, separated by commas.  The optional argument MULTIPLE
-specifies the form of the return value.  If MULTIPLE is non-nil,
-return a list of face names; if the user entered just one face
-name, the return value would be a list of one face name.
-Otherwise, return a single face name; if the user entered more
-than one face name, return only the first one."
-  ;; Should we better not generate automagically a value for DEFAULT
-  ;; when `read-face-name' was called with DEFAULT being nil?
-  ;; Such magic is somewhat unusual for a function  `read-...'.
-  ;; Also, one cannot skip this magic by means of a suitable
-  ;; value of DEFAULT.  It would be cleaner to use
-  ;; (read-face-name prompt (face-at-point)).
-  (unless default
-    ;; Try to get a default face name from the buffer.
-    (let ((thing (intern-soft (thing-at-point 'symbol))))
-      (if (memq thing (face-list))
-          (setq default (list thing))))
-    ;; Add the named faces that the `read-face-name' or `face' property uses.
-    (let ((faceprop (or (get-char-property (point) 'read-face-name)
-                        (get-char-property (point) 'face))))
-      (if (and (listp faceprop)
-               ;; Don't treat an attribute spec as a list of faces.
-               (not (keywordp (car faceprop)))
-               (not (memq (car faceprop) '(foreground-color 
background-color))))
-          (dolist (face faceprop)
-            (if (symbolp face)
-                (push face default)))
-        (if (symbolp faceprop)
-            (push faceprop default)))
-      (delete-dups default)))
-
-  ;; If we only want one, and the default is more than one,
-  ;; discard the unwanted ones now.
-  (if (and default (not multiple))
-      (setq default (list (car default))))
-
-  (if default
-      (setq default (mapconcat (lambda (f)
-                                 (if (symbolp f) (symbol-name f) f))
-                               default ", ")))
-
-  ;; Build up the completion tables.
-  (let (aliasfaces nonaliasfaces)
+as the separator regexp.  Thus, the user may enter multiple face names,
+separated by commas.
+
+MULTIPLE specifies the form of the return value.  If MULTIPLE is non-nil,
+return a list of face names; if the user entered just one face name,
+return a list of one face name.  Otherwise, return a single face name;
+if the user entered more than one face name, return only the first one."
+  (if (and default (not (stringp default)))
+      (setq default
+            (cond ((symbolp default)
+                   (symbol-name default))
+                  (multiple
+                   (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
+                              default ", "))
+                  ;; If we only want one, and the default is more than one,
+                  ;; discard the unwanted ones.
+                  (t (symbol-name (car default))))))
+
+  (let (aliasfaces nonaliasfaces faces)
+    ;; Build up the completion tables.
     (mapatoms (lambda (s)
-                (if (custom-facep s)
+                (if (facep s)
                     (if (get s 'face-alias)
                         (push (symbol-name s) aliasfaces)
                       (push (symbol-name s) nonaliasfaces)))))
-
-    (let ((faces
-           ;; Read the faces.
-           (mapcar 'intern
-                   (completing-read-multiple
-                    (if default
-                        (format "%s (default `%s'): " prompt default)
-                      (format "%s: " prompt))
-                    (completion-table-in-turn nonaliasfaces aliasfaces)
-                    nil t nil 'face-name-history default))))
-      ;; Return either a list of faces or just one face.
-      (if multiple
-         faces
-       (car faces)))))
+    (dolist (face (completing-read-multiple
+                   (if default
+                       (format "%s (default `%s'): " prompt default)
+                     (format "%s: " prompt))
+                   (completion-table-in-turn nonaliasfaces aliasfaces)
+                   nil t nil 'face-name-history default))
+      ;; Ignore elements that are not faces
+      ;; (for example, because DEFAULT was "all faces")
+      (if (facep face) (push (intern face) faces)))
+    ;; Return either a list of faces or just one face.
+    (if multiple
+        (nreverse faces)
+      (last faces))))
 
 ;; Not defined without X, but behind window-system test.
 (defvar x-bitmap-file-path)
@@ -1235,7 +1209,7 @@
                          :slant (if italic-p 'italic 'normal)
                          :underline underline
                          :inverse-video inverse-p)
-    (setq face (read-face-name "Modify face"))
+    (setq face (read-face-name "Modify face" (face-at-point t)))
     (apply #'set-face-attribute face frame
           (read-all-face-attributes face frame))))
 
@@ -1247,13 +1221,13 @@
 \(a symbol), and NEW-VALUE is value read."
   (cond ((eq attribute :font)
         (let* ((prompt "Set font-related attributes of face")
-               (face (read-face-name prompt))
+               (face (read-face-name prompt (face-at-point t)))
                (font (read-face-font face frame)))
           (list face font)))
        (t
         (let* ((attribute-name (face-descriptive-attribute-name attribute))
                (prompt (format "Set %s of face" attribute-name))
-               (face (read-face-name prompt))
+               (face (read-face-name prompt (face-at-point t)))
                (new-value (read-face-attribute face attribute frame)))
           (list face new-value)))))
 
@@ -1363,8 +1337,7 @@
 If FRAME is t, report on the defaults for face FACE (for new frames).
 If FRAME is omitted or nil, use the selected frame."
   (interactive (list (read-face-name "Describe face"
-                                     (if (eq 'default (face-at-point))
-                                         '(default))
+                                     (or (face-at-point t) 'default)
                                      t)))
   (let* ((attrs '((:family . "Family")
                  (:foundry . "Foundry")
@@ -1879,23 +1852,33 @@
     (when msg (message "Color: `%s'" color))
     color))
 
-
-(defun face-at-point ()
+(defun face-at-point (&optional thing multiple)
   "Return the face of the character after point.
 If it has more than one face, return the first one.
-Return nil if it has no specified face."
-  (let* ((faceprop (or (get-char-property (point) 'read-face-name)
-                       (get-char-property (point) 'face)
-                       'default))
-         (face (cond ((symbolp faceprop) faceprop)
-                     ;; List of faces (don't treat an attribute spec).
-                     ;; Just use the first face.
-                     ((and (consp faceprop) (not (keywordp (car faceprop)))
-                           (not (memq (car faceprop)
-                                     '(foreground-color background-color))))
-                      (car faceprop))
-                     (t nil))))         ; Invalid face value.
-    (if (facep face) face nil)))
+If THING is non-nil try first to get a face name from the buffer.
+IF MULTIPLE is non-nil, return a list of all faces.
+Return nil if there is no face."
+  (let (faces)
+    (if thing
+        ;; Try to get a face name from the buffer.
+        (let ((face (intern-soft (thing-at-point 'symbol))))
+          (if (facep face)
+              (push face faces))))
+    ;; Add the named faces that the `read-face-name' or `face' property uses.
+    (let ((faceprop (or (get-char-property (point) 'read-face-name)
+                        (get-char-property (point) 'face))))
+      (cond ((facep faceprop)
+             (push faceprop faces))
+            ((and (listp faceprop)
+                  ;; Don't treat an attribute spec as a list of faces.
+                  (not (keywordp (car faceprop)))
+                  (not (memq (car faceprop)
+                             '(foreground-color background-color))))
+             (dolist (face faceprop)
+               (if (facep face)
+                   (push face faces))))))
+    (setq faces (delete-dups (nreverse faces)))
+    (if multiple faces (car faces))))
 
 (defun foreground-color-at-point ()
   "Return the foreground color of the character after point."