]> git.eshelyaron.com Git - emacs.git/commitdiff
Merge with HEAD.
authorDave Love <fx@gnu.org>
Wed, 17 Jan 2001 20:37:48 +0000 (20:37 +0000)
committerDave Love <fx@gnu.org>
Wed, 17 Jan 2001 20:37:48 +0000 (20:37 +0000)
lisp/cus-edit.el
lisp/cus-face.el

index a90b1204fbacbd1f38966c869ff65a5a2c9f410f..08689d2747ae6cda3399e8e71f7b40920c92a84a 100644 (file)
@@ -1297,7 +1297,15 @@ Un-customize all values in this buffer.  They get their standard settings."
   (widget-insert "   ")
   (widget-create 'push-button
                 :tag "Finish"
-                :help-echo "Bury or kill the buffer."
+                :help-echo
+                (lambda (&rest ignore)
+                  (cond
+                   ((eq custom-buffer-done-function
+                        'custom-bury-buffer)
+                    "Bury this buffer")
+                   ((eq custom-buffer-done-function 'kill-buffer)
+                    "Kill this buffer")
+                   (t "Finish with this buffer")))
                 :action #'Custom-buffer-done)
   (widget-insert "\n\n")
   (message "Creating customization items...")
@@ -1315,18 +1323,18 @@ Un-customize all values in this buffer.  They get their standard settings."
          (let ((count 0)
                (length (length options)))
            (mapcar (lambda (entry)
-                       (prog2
-                           (message "Creating customization items ...%2d%%"
-                                    (/ (* 100.0 count) length))
-                           (widget-create (nth 1 entry)
+                     (prog2
+                         (message "Creating customization items ...%2d%%"
+                                  (/ (* 100.0 count) length))
+                         (widget-create (nth 1 entry)
                                         :tag (custom-unlispify-tag-name
                                               (nth 0 entry))
                                         :value (nth 0 entry))
-                         (setq count (1+ count))
-                         (unless (eq (preceding-char) ?\n)
-                           (widget-insert "\n"))
-                         (widget-insert "\n")))
-                     options))))
+                       (setq count (1+ count))
+                       (unless (eq (preceding-char) ?\n)
+                         (widget-insert "\n"))
+                       (widget-insert "\n")))
+                   options))))
   (unless (eq (preceding-char) ?\n)
     (widget-insert "\n"))
   (message "Creating customization items ...%2d%%done" 100)
@@ -2386,7 +2394,7 @@ Optional EVENT is the location for the menu."
           (error "Cannot set hidden variable"))
          ((setq val (widget-apply child :validate))
           (goto-char (widget-get val :from))
-          (error "%s" (widget-get val :error)))
+          (error "Saving %s: %s" symbol (widget-get val :error)))
          ((memq form '(lisp mismatch))
           (when (equal comment "")
             (setq comment nil)
@@ -2617,6 +2625,57 @@ Match frames with dark backgrounds.")
 (defconst custom-face-selected (widget-convert 'custom-face-selected)
   "Converted version of the `custom-face-selected' widget.")
 
+(defun custom-filter-face-spec (spec filter-index default-filter)
+  "Return a canonicalized version of SPEC using.
+FILTER-INDEX is the index in the entry for each attribute in
+`custom-face-attributes' at which the appropriate filter function can be
+found, and DEFAULT-FILTER is the filter to apply for attributes that
+don't specify one."
+  (mapcar (lambda (entry)
+           ;; Filter a single face-spec entry
+           (let ((tests (car entry))
+                 (unfiltered-attrs
+                  ;; Handle both old- and new-style attribute syntax
+                  (if (listp (car (cdr entry)))
+                      (car (cdr entry))
+                    (cdr entry)))
+                 (filtered-attrs nil))
+             ;; Filter each face attribute
+             (while unfiltered-attrs
+               (let* ((attr (pop unfiltered-attrs))
+                      (pre-filtered-value (pop unfiltered-attrs))
+                      (filter
+                       (or (nth filter-index (assq attr custom-face-attributes))
+                           default-filter))
+                      (filtered-value
+                       (if filter
+                           (funcall filter pre-filtered-value)
+                         pre-filtered-value)))
+                 (push filtered-value filtered-attrs)
+                 (push attr filtered-attrs)))
+             ;;
+             (list tests filtered-attrs)))
+         spec))
+
+(defun custom-pre-filter-face-spec (spec)
+  "Return SPEC changed as necessary for editing by the face customization widget.
+SPEC must be a full face spec."
+  (custom-filter-face-spec
+   spec 2
+   (lambda (value)
+     (cond ((eq value 'unspecified) nil)
+          ((eq value nil) 'off)
+          (t value)))))
+
+(defun custom-post-filter-face-spec (spec)
+  "Return the customized SPEC in a form suitable for setting the face."
+  (custom-filter-face-spec
+   spec 3
+   (lambda (value)
+     (cond ((eq value nil) 'unspecified)
+          ((eq value 'off) nil)
+          (t value)))))
+
 (defun custom-face-value-create (widget)
   "Create a list of the display specifications for WIDGET."
   (let ((buttons (widget-get widget :buttons))
@@ -2639,10 +2698,12 @@ Match frames with dark backgrounds.")
          (t
           ;; Create tag.
           (insert tag)
+          (widget-specify-sample widget begin (point))
           (if (eq custom-buffer-style 'face)
               (insert " ")
-            (widget-specify-sample widget begin (point))
-            (insert ": "))
+            (if (string-match "face\\'" tag)
+                (insert ":")
+              (insert " face: ")))
           ;; Sample.
           (push (widget-create-child-and-convert widget 'item
                                                  :format "(%{%t%})"
@@ -2703,6 +2764,7 @@ Match frames with dark backgrounds.")
               ;; edit it as the user has specified it.
               (if (not (face-spec-match-p symbol spec (selected-frame)))
                   (setq spec (list (list t (face-attr-construct symbol (selected-frame))))))
+              (setq spec (custom-pre-filter-face-spec spec))
               (setq edit (widget-create-child-and-convert
                           widget
                           (cond ((and (eq form 'selected)
@@ -2816,7 +2878,7 @@ Optional EVENT is the location for the menu."
   "Make the face attributes in WIDGET take effect."
   (let* ((symbol (widget-value widget))
         (child (car (widget-get widget :children)))
-        (value (widget-value child))
+        (value (custom-post-filter-face-spec (widget-value child)))
         (comment-widget (widget-get widget :comment-widget))
         (comment (widget-value comment-widget)))
     (when (equal comment "")
@@ -2824,7 +2886,11 @@ Optional EVENT is the location for the menu."
       ;; Make the comment invisible by hand if it's empty
       (custom-comment-hide comment-widget))
     (put symbol 'customized-face value)
-    (face-spec-set symbol value)
+    (if (face-spec-choose value)
+       (face-spec-set symbol value)
+      ;; face-set-spec ignores empty attribute lists, so just give it
+      ;; something harmless instead.
+      (face-spec-set symbol '((t :foreground unspecified))))
     (put symbol 'customized-face-comment comment)
     (put symbol 'face-comment comment)
     (custom-face-state-set widget)
@@ -2911,7 +2977,7 @@ restoring it to the state of a face that has never been customized."
   :convert-widget 'widget-value-convert-widget
   :button-prefix 'widget-push-button-prefix
   :button-suffix 'widget-push-button-suffix
-  :format "%t: %[select face%] %v"
+  :format "%{%t%}: %[select face%] %v"
   :tag "Face"
   :value 'default
   :value-create 'widget-face-value-create
@@ -3487,7 +3553,7 @@ or (if there were none) at the end of the buffer."
        (princ "\n"))
       (princ "(custom-set-variables
   ;; custom-set-variables was added by Custom -- don't edit or cut/paste it!
-  ;; Your init file must only contain one such instance.\n")
+  ;; Your init file should contain only one such instance.\n")
       (mapcar
        (lambda (symbol)
         (let ((spec (car-safe (get symbol 'theme-value)))
@@ -3558,7 +3624,7 @@ or (if there were none) at the end of the buffer."
        (princ "\n"))
       (princ "(custom-set-faces
   ;; custom-set-faces was added by Custom -- don't edit or cut/paste it!
-  ;; Your init file must only contain one such instance.\n")
+  ;; Your init file should contain only one such instance.\n")
       (mapcar
        (lambda (symbol)
         (let ((theme-spec (car-safe (get symbol 'theme-face)))
@@ -3757,14 +3823,9 @@ Otherwise the menu will be named `Customize'.
 The format is suitable for use with `easy-menu-define'."
   (unless name
     (setq name "Customize"))
-  ;; Fixme: sort out use of :filter in Emacs 21.
-  (if nil ;(string-match "XEmacs" emacs-version)
-      ;; We can delay it under XEmacs.
-      `(,name
-       :filter (lambda (&rest junk)
-                 (cdr (custom-menu-create ',symbol))))
-    ;; But we must create it now under Emacs.
-    (cons name (cdr (custom-menu-create symbol)))))
+  `(,name
+    :filter (lambda (&rest junk)
+             (custom-menu-create ',symbol))))
 
 ;;; The Custom Mode.
 
index b51ba8fee66aff0b821c921d85fc46a8c483b25e..8d61ebddb2a8c695160c103afcd69bd0ea7c14da 100644 (file)
@@ -1,6 +1,6 @@
 ;;; cus-face.el -- customization support for faces.
 ;;
-;; Copyright (C) 1996, 1997, 1999, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1999, 2000, 2001 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Maintainer: FSF
      (choice :tag "Font family"
             :help-echo "Font family or fontset alias name."
             (const :tag "*" nil)
-            (string :tag "Family"))
-     (lambda (face value &optional frame)
-       (set-face-attribute face frame :family (or value 'unspecified)))
-     (lambda (face &optional frame)
-       (let ((family (face-attribute face :family frame)))
-        (if (eq family 'unspecified) nil family))))
+            (string :tag "Family")))
     
     (:width
      (choice :tag "Width"
             (const :tag "semiexpanded" semi-expanded)
             (const :tag "ultracondensed" ultra-condensed)
             (const :tag "ultraexpanded" ultra-expanded)
-            (const :tag "wide" extra-expanded))
-     (lambda (face value &optional frame)
-       (set-face-attribute face frame :width (or value 'unspecified)))
-     (lambda (face &optional frame)
-       (let ((width (face-attribute face :width frame)))
-        (if (eq width 'unspecified) nil width))))
+            (const :tag "wide" extra-expanded)))
     
     (:height
      (choice :tag "Height"
             :help-echo "Face's font height."
             (const :tag "*" nil)
-            (integer :tag "Height in 1/10 pt"))
+            (integer :tag "Height in 1/10 pt")
+            (number :tag "Scale" 1.0))
      (lambda (face value &optional frame)
        (set-face-attribute face frame :height (or value 'unspecified)))
      (lambda (face &optional frame)
             (const :tag "semibold" semi-bold)
             (const :tag "semilight" semi-light)
             (const :tag "ultralight" ultra-light)
-            (const :tag "ultrabold" ultra-bold))
-     (lambda (face value &optional frame)
-       (set-face-attribute face frame :weight (or value 'unspecified)))
-     (lambda (face &optional frame)
-       (let ((weight (face-attribute face :weight frame)))
-        (if (eq weight 'unspecified) nil weight))))
+            (const :tag "ultrabold" ultra-bold)))
     
     (:slant
      (choice :tag "Slant"
             (const :tag "*" nil)
             (const :tag "italic" italic)
             (const :tag "oblique" oblique)
-            (const :tag "normal" normal))
-     (lambda (face value &optional frame)
-       (set-face-attribute face frame :slant (or value 'unspecified)))
-     (lambda (face &optional frame)
-       (let ((slant (face-attribute face :slant frame)))
-        (if (eq slant 'unspecified) nil slant))))
+            (const :tag "normal" normal)))
     
     (:underline
      (choice :tag "Underline"
             (const :tag "*" nil)
             (const :tag "On" t)
             (const :tag "Off" off)
-            (color :tag "Colored"))
-     (lambda (face value &optional frame)
-       (cond ((eq value 'off) (setq value nil))
-            ((null value) (setq value 'unspecified)))
-       (set-face-attribute face frame :underline value))
-     (lambda (face &optional frame)
-       (let ((underline (face-attribute face :underline frame)))
-        (cond ((eq underline 'unspecified) nil)
-              ((null underline) 'off)))))
+            (color :tag "Colored")))
     
     (:overline
      (choice :tag "Overline"
             (const :tag "*" nil)
             (const :tag "On" t)
             (const :tag "Off" off)
-            (color :tag "Colored"))
-     (lambda (face value &optional frame)
-       (cond ((eq value 'off) (setq value nil))
-            ((null value) (setq value 'unspecified)))
-       (set-face-attribute face frame :overline value))
-     (lambda (face &optional frame)
-       (let ((overline (face-attribute face :overline frame)))
-        (cond ((eq overline 'unspecified) nil)
-              ((null overline) 'off)))))
+            (color :tag "Colored")))
     
     (:strike-through
      (choice :tag "Strike-through"
             (const :tag "*" nil)
             (const :tag "On" t)
             (const :tag "Off" off)
-            (color :tag "Colored"))
-     (lambda (face value &optional frame)
-       (cond ((eq value 'off) (setq value nil))
-            ((null value) (setq value 'unspecified)))
-       (set-face-attribute face frame :strike-through value))
-     (lambda (face &optional frame)
-       (let ((value (face-attribute face :strike-through frame)))
-        (cond ((eq value 'unspecified) (setq value nil))
-              ((null value) (setq value 'off)))
-        value)))
+            (color :tag "Colored")))
     
     (:box
      ;; Fixme: this can probably be done better.
      (choice :tag "Box around text"
             :help-echo "Control box around text."
-            (const :tag "*" t)
-            (const :tag "Off" nil)
+            (const :tag "*" nil)
+            (const :tag "Off" off)
             (list :tag "Box"
-                  :value (:line-width 2 :color "grey75"
-                                      :style released-button)
+                  :value (:line-width 2 :color "grey75" :style released-button)
                   (const :format "" :value :line-width)
                   (integer :tag "Width")
                   (const :format "" :value :color)
                           (const :tag "Raised" released-button)
                           (const :tag "Sunken" pressed-button)
                           (const :tag "None" nil))))
-     (lambda (face value &optional frame)
-       (set-face-attribute face frame :box value))
-     (lambda (face &optional frame)
-       (let ((value (face-attribute face :box frame)))
-        (if (consp value)
-            (list :line-width (or (plist-get value :line-width) 1)
-                  :color (plist-get value :color)
-                  :style (plist-get value :style))
-          value))))
+     ;; filter to make value suitable for customize
+     (lambda (real-value)
+       (if (null real-value)
+          'off
+        (let ((lwidth
+               (or (and (consp real-value) (plist-get real-value :line-width))
+                   (and (integerp real-value) real-value)
+                   1))
+              (color
+               (or (and (consp real-value) (plist-get real-value :color))
+                   (and (stringp real-value) real-value)
+                   nil))
+              (style
+               (and (consp real-value) (plist-get real-value :style))))
+          (list :line-width lwidth :color color :style style))))
+     ;; filter to make customized-value suitable for storing
+     (lambda (cus-value)
+       (cond ((null cus-value)
+             'unspecified)
+            ((eq cus-value 'off)
+             nil)
+            (t
+             (let ((lwidth (plist-get cus-value :line-width))
+                   (color (plist-get cus-value :color))
+                   (style (plist-get cus-value :style)))
+               (cond ((and (null color) (null style))
+                      lwidth)
+                     ((and (null lwidth) (null style))
+                      ;; actually can't happen, because LWIDTH is always an int
+                      color)
+                     (t
+                      ;; Keep as a plist, but remove null entries
+                      (nconc (and lwidth `(:line-width ,lwidth))
+                             (and color  `(:color ,color))
+                             (and style  `(:style ,style))))))))))
     
     (:inverse-video
      (choice :tag "Inverse-video"
             :help-echo "Control whether text should be in inverse-video."
             (const :tag "*" nil)
             (const :tag "On" t)
-            (const :tag "Off" off))
-     (lambda (face value &optional frame)
-       (cond ((eq value 'off) (setq value nil))
-            ((null value) (setq value 'unspecified)))
-       (set-face-attribute face frame :inverse-video value))
-     (lambda (face &optional frame)
-       (let ((value (face-attribute face :inverse-video frame)))
-        (cond ((eq value 'unspecified)
-               nil)
-              ((null value)'off)))))
+            (const :tag "Off" off)))
     
     (:foreground
      (choice :tag "Foreground"
             :help-echo "Set foreground color."
             (const :tag "*" nil)
-            (color :tag "Color"))
-     (lambda (face value &optional frame)
-       (set-face-attribute face frame :foreground (or value 'unspecified)))
-     (lambda (face &optional frame)
-       (let ((value (face-attribute face :foreground frame)))
-        (if (eq value 'unspecified) nil value))))
+            (color :tag "Color")))
     
     (:background
      (choice :tag "Background"
             :help-echo "Set background color."
             (const :tag "*" nil)
-            (color :tag "Color"))
-     (lambda (face value &optional frame)
-       (set-face-attribute face frame :background (or value 'unspecified)))
-     (lambda (face &optional frame)
-       (let ((value (face-attribute face :background frame)))
-        (if (eq value 'unspecified) nil value))))
+            (color :tag "Color")))
     
     (:stipple
      (choice :tag "Stipple"
-            :help-echo "Name of background bitmap file."
+            :help-echo "Background bit-mask"
             (const :tag "*" nil)
-            (file :tag "File" :must-match t))
-     (lambda (face value &optional frame)
-       (set-face-attribute face frame :stipple (or value 'unspecified)))
-     (lambda (face &optional frame)
-       (let ((value (face-attribute face :stipple frame)))
-        (if (eq value 'unspecified) nil value)))))
+            (const :tag "None" off)
+            (file :tag "File"
+                  :help-echo "Name of bitmap file."
+                  :must-match t)))
+
+    (:inherit
+     (repeat :tag "Inherit"
+            :help-echo "List of faces to inherit attributes from."
+            (face :Tag "Face" default))
+     ;; filter to make value suitable for customize
+     (lambda (real-value)
+       (cond ((or (null real-value) (eq real-value 'unspecified))
+             nil)
+            ((symbolp real-value)
+             (list real-value))
+            (t
+             real-value)))
+     ;; filter to make customized-value suitable for storing
+     (lambda (cus-value)
+       (if (and (consp cus-value) (null (cdr cus-value)))
+          (car cus-value)
+        cus-value))))
        
   "Alist of face attributes.
 
-The elements are of the form (KEY TYPE SET GET), where KEY is the name
-of the attribute, TYPE is a widget type for editing the attibute, SET
-is a function for setting the attribute value, and GET is a function
-for getting the attribute value.
+The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
+where KEY is the name of the attribute, TYPE is a widget type for
+editing the attribute, PRE-FILTER is a function to make the attribute's
+value suitable for the customization widget, and POST-FILTER is a
+function to make the customized value suitable for storing.  PRE-FILTER
+and POST-FILTER are optional.
+
+The PRE-FILTER should take a single argument, the attribute value as
+stored, and should return a value for customization (using the
+customization type TYPE).
 
-The SET function should take three arguments, the face to modify, the
-value of the attribute, and optionally the frame where the face should
-be changed.
+The POST-FILTER should also take a single argument, the value after
+being customized, and should return a value suitable for setting the
+given face attribute.")
 
 The GET function should take two arguments, the face to examine, and
 optionally the frame where the face should be examined.")