lisp/cus-face.el

   1 ;;; cus-face.el -- XEmacs specific custom support.
   2 ;;
   3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   6 ;; Keywords: help, faces
   7 ;; Version: 1.71
   8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
   9
  10 ;;; Commentary:
  11 ;;
  12 ;; See `custom.el'.
  13
  14 ;;; Code:
  15
  16 (require 'custom)
  17
  18 (eval-and-compile (require 'cl))
  19
  20 ;;; Compatibility.
  21
  22 (if (string-match "XEmacs" emacs-version)
  23     (defun custom-face-background (face &optional frame)
  24       ;; Specifiers suck!
  25       "Return the background color name of face FACE, or nil if unspecified."
  26       (color-instance-name (specifier-instance (face-background face) frame)))
  27   (defalias 'custom-face-background 'face-background))
  28
  29 (if (string-match "XEmacs" emacs-version)
  30     (defun custom-face-foreground (face &optional frame)
  31       ;; Specifiers suck!
  32       "Return the background color name of face FACE, or nil if unspecified."
  33       (color-instance-name (specifier-instance (face-foreground face) frame)))
  34   (defalias 'custom-face-foreground 'face-foreground))
  35
  36 (defalias 'custom-face-font-name (if (string-match "XEmacs" emacs-version)
  37                                      'face-font-name
  38                                    'face-font))
  39
  40 (eval-and-compile
  41   (unless (fboundp 'frame-property)
  42     ;; XEmacs function missing in Emacs 19.34.
  43     (defun frame-property (frame property &optional default)
  44       "Return FRAME's value for property PROPERTY."
  45       (or (cdr (assq property (frame-parameters frame)))
  46           default)))
  47
  48   (unless (fboundp 'face-doc-string)
  49     ;; XEmacs function missing in Emacs.
  50     (defun face-doc-string (face)
  51       "Get the documentation string for FACE."
  52       (get face 'face-doc-string)))
  53
  54   (unless (fboundp 'set-face-doc-string)
  55     ;; XEmacs function missing in Emacs.
  56     (defun set-face-doc-string (face string)
  57       "Set the documentation string for FACE to STRING."
  58       (put face 'face-doc-string string)))
  59
  60   (when (and (not (fboundp 'set-face-stipple))
  61              (fboundp 'set-face-background-pixmap))
  62     ;; Emacs function missing in XEmacs 19.15.
  63     (defun set-face-stipple (face pixmap &optional frame)
  64       ;; Written by Kyle Jones.
  65       "Change the stipple pixmap of face FACE to PIXMAP.
  66 PIXMAP should be a string, the name of a file of pixmap data.
  67 The directories listed in the `x-bitmap-file-path' variable are searched.
  68
  69 Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT DATA)
  70 where WIDTH and HEIGHT are the size in pixels,
  71 and DATA is a string, containing the raw bits of the bitmap.
  72
  73 If the optional FRAME argument is provided, change only
  74 in that frame; otherwise change each frame."
  75       (while (not (find-face face))
  76         (setq face (signal 'wrong-type-argument (list 'facep face))))
  77       (while (cond ((stringp pixmap)
  78                     (unless (file-readable-p pixmap)
  79                       (setq pixmap (vector 'xbm ':file pixmap)))
  80                     nil)
  81                    ((and (consp pixmap) (= (length pixmap) 3))
  82                     (setq pixmap (vector 'xbm ':data pixmap))
  83                     nil)
  84                    (t t))
  85         (setq pixmap (signal 'wrong-type-argument
  86                              (list 'stipple-pixmap-p pixmap))))
  87       (while (and frame (not (framep frame)))
  88         (setq frame (signal 'wrong-type-argument (list 'framep frame))))
  89       (set-face-background-pixmap face pixmap frame))))
  90
  91 (unless (fboundp 'x-color-values)
  92   ;; Emacs function missing in XEmacs 19.14.
  93   (defun x-color-values  (color &optional frame)
  94     "Return a description of the color named COLOR on frame FRAME.
  95 The value is a list of integer RGB values--(RED GREEN BLUE).
  96 These values appear to range from 0 to 65280 or 65535, depending
  97 on the system; white is (65280 65280 65280) or (65535 65535 65535).
  98 If FRAME is omitted or nil, use the selected frame."
  99     (color-instance-rgb-components (make-color-instance color))))
 100
 101 ;; XEmacs and Emacs have different definitions of `facep'.
 102 ;; The Emacs definition is the useful one, so emulate that.
 103 (cond ((not (fboundp 'facep))
 104        (defun custom-facep (face)
 105          "No faces"
 106          nil))
 107       ((string-match "XEmacs" emacs-version)
 108        (defalias 'custom-facep 'find-face))
 109       (t
 110        (defalias 'custom-facep 'facep)))
 111
 112 (unless (fboundp 'make-empty-face)
 113   ;; This should be moved to `faces.el'.
 114   (if (string-match "XEmacs" emacs-version)
 115       ;; Give up for old XEmacs pre 19.15/20.1.
 116       (defalias 'make-empty-face 'make-face)
 117     ;; Define for Emacs pre 19.35.
 118     (defun make-empty-face (name)
 119       "Define a new FACE on all frames, ignoring X resources."
 120       (interactive "SMake face: ")
 121       (or (internal-find-face name)
 122           (let ((face (make-vector 8 nil)))
 123             (aset face 0 'face)
 124             (aset face 1 name)
 125             (let* ((frames (frame-list))
 126                    (inhibit-quit t)
 127                    (id (internal-next-face-id)))
 128               (make-face-internal id)
 129               (aset face 2 id)
 130               (while frames
 131                 (set-frame-face-alist (car frames)
 132                                       (cons (cons name (copy-sequence face))
 133                                             (frame-face-alist (car frames))))
 134                 (setq frames (cdr frames)))
 135               (setq global-face-data (cons (cons name face) global-face-data)))
 136             ;; add to menu
 137             (if (fboundp 'facemenu-add-new-face)
 138                 (facemenu-add-new-face name))
 139             face))
 140       name)))
 141
 142 (defcustom initialize-face-resources t
 143   "If non nil, allow X resources to initialize face properties.
 144 This only affects faces declared with `defface', and only NT or X11 frames."
 145   :group 'customize
 146   :type 'boolean)
 147
 148 (cond ((fboundp 'initialize-face-resources)
 149        ;; Already bound, do nothing.
 150        )
 151       ((fboundp 'make-face-x-resource-internal)
 152        ;; Emacs or new XEmacs.
 153        (defun initialize-face-resources (face &optional frame)
 154          "Initialize face according to the X11 resources.
 155 This might overwrite existing face properties.
 156 Does nothing when the variable initialize-face-resources is nil."
 157          (when initialize-face-resources
 158            (make-face-x-resource-internal face frame t))))
 159       (t
 160        ;; Too hard to do right on XEmacs.
 161        (defalias 'initialize-face-resources 'ignore)))
 162
 163 ;;(if (string-match "XEmacs" emacs-version)
 164 ;;    ;; Xemacs.
 165 ;;    (defun custom-invert-face (face &optional frame)
 166 ;;      "Swap the foreground and background colors of face FACE.
 167 ;;If the colors are not specified in the face, use the default colors."
 168 ;;      (interactive (list (read-face-name "Reverse face: ")))
 169 ;;      (let ((fg (color-name (face-foreground face frame) frame))
 170 ;;          (bg (color-name (face-background face frame) frame)))
 171 ;;      (set-face-foreground face bg frame)
 172 ;;      (set-face-background face fg frame)))
 173 ;;  ;; Emacs.
 174 ;;  (defun custom-invert-face (face &optional frame)
 175 ;;    "Swap the foreground and background colors of face FACE.
 176 ;;If the colors are not specified in the face, use the default colors."
 177 ;;    (interactive (list (read-face-name "Reverse face: ")))
 178 ;;    (let ((fg (or (face-foreground face frame)
 179 ;;                (face-foreground 'default frame)
 180 ;;                (frame-property (or frame (selected-frame))
 181 ;;                                'foreground-color)
 182 ;;                "black"))
 183 ;;        (bg (or (face-background face frame)
 184 ;;                (face-background 'default frame)
 185 ;;                (frame-property (or frame (selected-frame))
 186 ;;                                'background-color)
 187 ;;                "white")))
 188 ;;      (set-face-foreground face bg frame)
 189 ;;      (set-face-background face fg frame))))
 190
 191 (defcustom custom-background-mode nil
 192   "The brightness of the background.
 193 Set this to the symbol dark if your background color is dark, light if
 194 your background is light, or nil (default) if you want Emacs to
 195 examine the brightness for you."
 196   :group 'customize
 197   :type '(choice (choice-item dark)
 198                  (choice-item light)
 199                  (choice-item :tag "default" nil)))
 200
 201 (defun custom-background-mode (frame)
 202   "Kludge to detect background mode for FRAME."
 203   (let* ((bg-resource
 204           (condition-case ()
 205               (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
 206             (error nil)))
 207          color
 208          (mode (cond (bg-resource
 209                       (intern (downcase bg-resource)))
 210                      ((and (setq color (condition-case ()
 211                                            (or (frame-property
 212                                                 frame
 213                                                 'background-color)
 214                                                (custom-face-background
 215                                                 'default))
 216                                          (error nil)))
 217                            (or (string-match "XEmacs" emacs-version)
 218                                window-system)
 219                            (< (apply '+ (x-color-values color))
 220                               (/ (apply '+ (x-color-values "white"))
 221                                  3)))
 222                       'dark)
 223                      (t 'light))))
 224     (modify-frame-parameters frame (list (cons 'background-mode mode)))
 225     mode))
 226
 227 (eval-and-compile
 228   (if (string-match "XEmacs" emacs-version)
 229       ;; XEmacs.
 230       (defun custom-extract-frame-properties (frame)
 231         "Return a plist with the frame properties of FRAME used by custom."
 232         (list 'type (device-type (frame-device frame))
 233               'class (device-class (frame-device frame))
 234               'background (or custom-background-mode
 235                               (frame-property frame
 236                                               'background-mode)
 237                               (custom-background-mode frame))))
 238     ;; Emacs.
 239     (defun custom-extract-frame-properties (frame)
 240       "Return a plist with the frame properties of FRAME used by custom."
 241       (list 'type window-system
 242             'class (frame-property frame 'display-type)
 243             'background (or custom-background-mode
 244                             (frame-property frame 'background-mode)
 245                             (custom-background-mode frame))))))
 246
 247 ;;; Declaring a face.
 248
 249 ;;;###autoload
 250 (defun custom-declare-face (face spec doc &rest args)
 251   "Like `defface', but FACE is evaluated as a normal argument."
 252   (when (fboundp 'load-gc)
 253     ;; This should be allowed, somehow.
 254     (error "Attempt to declare a face during dump"))
 255   (unless (get face 'factory-face)
 256     (put face 'factory-face spec)
 257     (when (fboundp 'facep)
 258       (unless (custom-facep face)
 259         ;; If the user has already created the face, respect that.
 260         (let ((value (or (get face 'saved-face) spec))
 261               (frames (custom-relevant-frames))
 262               frame)
 263           ;; Create global face.
 264           (make-empty-face face)
 265           (custom-face-display-set face value)
 266           ;; Create frame local faces
 267           (while frames
 268             (setq frame (car frames)
 269                   frames (cdr frames))
 270             (custom-face-display-set face value frame))
 271           (initialize-face-resources face))))
 272     (when (and doc (null (face-doc-string face)))
 273       (set-face-doc-string face doc))
 274     (custom-handle-all-keywords face args 'custom-face)
 275     (run-hooks 'custom-define-hook))
 276   face)
 277
 278 ;;; Font Attributes.
 279
 280 (defconst custom-face-attributes
 281   '((:bold (toggle :format "Bold: %[%v%]\n"
 282                    :help-echo "Control whether a bold font should be used.")
 283            custom-set-face-bold
 284            custom-face-bold)
 285     (:italic (toggle :format "Italic: %[%v%]\n"
 286                      :help-echo "\
 287 Control whether an italic font should be used.")
 288              custom-set-face-italic
 289              custom-face-italic)
 290     (:underline (toggle :format "Underline: %[%v%]\n"
 291                         :help-echo "\
 292 Control whether the text should be underlined.")
 293                 set-face-underline-p
 294                 face-underline-p)
 295     (:foreground (color :tag "Foreground"
 296                         :value "black"
 297                         :help-echo "Set foreground color.")
 298                  set-face-foreground
 299                  custom-face-foreground)
 300     (:background (color :tag "Background"
 301                         :value "white"
 302                         :help-echo "Set background color.")
 303                  set-face-background
 304                  custom-face-background)
 305     ;;    (:invert (const :format "Invert Face\n"
 306     ;;              :sibling-args (:help-echo "
 307     ;;Reverse the foreground and background color.
 308     ;;If you haven't specified them for the face, the default colors will be used.")
 309     ;;              t)
 310     ;;       (lambda (face value &optional frame)
 311     ;;         ;; We don't use VALUE.
 312     ;;         (custom-invert-face face frame)))
 313     (:stipple (editable-field :format "Stipple: %v"
 314                               :help-echo "Name of background bitmap file.")
 315               set-face-stipple custom-face-stipple))
 316   "Alist of face attributes.
 317
 318 The elements are of the form (KEY TYPE SET GET) where KEY is a symbol
 319 identifying the attribute, TYPE is a widget type for editing the
 320 attibute, SET is a function for setting the attribute value, and GET is a function for getiing the attribute value.
 321
 322 The SET function should take three arguments, the face to modify, the
 323 value of the attribute, and optionally the frame where the face should
 324 be changed.
 325
 326 The GET function should take two arguments, the face to examine, and
 327 optonally the frame where the face should be examined.")
 328
 329 (defun custom-face-attributes-set (face frame &rest atts)
 330   "For FACE on FRAME set the attributes [KEYWORD VALUE]....
 331 Each keyword should be listed in `custom-face-attributes'.
 332
 333 If FRAME is nil, set the default face."
 334   (while atts
 335     (let* ((name (nth 0 atts))
 336            (value (nth 1 atts))
 337            (fun (nth 2 (assq name custom-face-attributes))))
 338       (setq atts (cdr (cdr atts)))
 339       (condition-case nil
 340           (funcall fun face value frame)
 341         (error nil)))))
 342
 343 (defun custom-face-attributes-get (face frame)
 344   "For FACE on FRAME get the attributes [KEYWORD VALUE]....
 345 Each keyword should be listed in `custom-face-attributes'.
 346
 347 If FRAME is nil, use the default face."
 348   (condition-case nil
 349       ;; Attempt to get `font.el' from w3.
 350       (require 'font)
 351     (error nil))
 352   (let ((atts custom-face-attributes)
 353         att result get)
 354     (while atts
 355       (setq att (car atts)
 356             atts (cdr atts)
 357             get (nth 3 att))
 358       (when get
 359         (let ((answer (funcall get face frame)))
 360           (unless (equal answer (funcall get 'default frame))
 361             (when (widget-apply (nth 1 att) :match answer)
 362               (setq result (cons (nth 0 att) (cons answer result))))))))
 363     result))
 364
 365 (defun custom-set-face-bold (face value &optional frame)
 366   "Set the bold property of FACE to VALUE."
 367   (if value
 368       (make-face-bold face frame)
 369     (make-face-unbold face frame)))
 370
 371 (defun custom-face-bold (face &rest args)
 372   "Return non-nil if the font of FACE is bold."
 373   (let* ((font (apply 'custom-face-font-name face args))
 374          (fontobj (font-create-object font)))
 375     (font-bold-p fontobj)))
 376
 377 (defun custom-set-face-italic (face value &optional frame)
 378   "Set the italic property of FACE to VALUE."
 379   (if value
 380       (make-face-italic face frame)
 381     (make-face-unitalic face frame)))
 382
 383 (defun custom-face-italic (face &rest args)
 384   "Return non-nil if the font of FACE is italic."
 385   (let* ((font (apply 'custom-face-font-name face args))
 386          (fontobj (font-create-object font)))
 387     (font-italic-p fontobj)))
 388
 389 (defun custom-face-stipple (face &rest args)
 390   "Return the name of the stipple file used for FACE."
 391   (if (string-match "XEmacs" emacs-version)
 392       (let ((image  (apply 'specifier-instance
 393                            (face-background-pixmap face) args)))
 394         (when image
 395           (image-instance-file-name image)))
 396     (apply 'face-stipple face args)))
 397
 398 (when (string-match "XEmacs" emacs-version)
 399   ;; Support for special XEmacs font attributes.
 400   (autoload 'font-create-object "font" nil)
 401
 402   (defun custom-set-face-font-size (face size &rest args)
 403     "Set the font of FACE to SIZE"
 404     (let* ((font (apply 'custom-face-font-name face args))
 405            (fontobj (font-create-object font)))
 406       (set-font-size fontobj size)
 407       (apply 'font-set-face-font face fontobj args)))
 408
 409   (defun custom-face-font-size (face &rest args)
 410     "Return the size of the font of FACE as a string."
 411     (let* ((font (apply 'custom-face-font-name face args))
 412            (fontobj (font-create-object font)))
 413       (format "%d" (font-size fontobj))))
 414
 415   (defun custom-set-face-font-family (face family &rest args)
 416     "Set the font of FACE to FAMILY."
 417     (let* ((font (apply 'custom-face-font-name face args))
 418            (fontobj (font-create-object font)))
 419       (set-font-family fontobj family)
 420       (apply 'font-set-face-font face fontobj args)))
 421
 422   (defun custom-face-font-family (face &rest args)
 423     "Return the name of the font family of FACE."
 424     (let* ((font (apply 'custom-face-font-name face args))
 425            (fontobj (font-create-object font)))
 426       (font-family fontobj)))
 427
 428   (nconc custom-face-attributes
 429          '((:family (editable-field :format "Font Family: %v"
 430                                     :help-echo "\
 431 Name of font family to use (e.g. times).")
 432                     custom-set-face-font-family
 433                     custom-face-font-family)
 434            (:size (editable-field :format "Size: %v"
 435                                   :help-echo "\
 436 Text size (e.g. 9pt or 2mm).")
 437                   custom-set-face-font-size
 438                   custom-face-font-size))))
 439
 440 ;;; Frames.
 441
 442 (defun custom-face-display-set (face spec &optional frame)
 443   "Set FACE to the attributes to the first matching entry in SPEC.
 444 Iff optional FRAME is non-nil, set it for that frame only.
 445 See `defface' for information about SPEC."
 446   (when (fboundp 'make-face)
 447     (while spec
 448       (let* ((entry (car spec))
 449              (display (nth 0 entry))
 450              (atts (nth 1 entry)))
 451         (setq spec (cdr spec))
 452         (when (custom-display-match-frame display frame)
 453           ;; Avoid creating frame local duplicates of the global face.
 454           (unless (and frame (eq display (get face 'custom-face-display)))
 455             (apply 'custom-face-attributes-set face frame atts))
 456           (unless frame
 457             (put face 'custom-face-display display))
 458           (setq spec nil))))))
 459
 460 (defvar custom-default-frame-properties nil
 461   "The frame properties used for the global faces.
 462 Frames who doesn't match these propertiess should have frame local faces.
 463 The value should be nil, if uninitialized, or a plist otherwise.
 464 See `defface' for a list of valid keys and values for the plist.")
 465
 466 (defun custom-get-frame-properties (&optional frame)
 467   "Return a plist with the frame properties of FRAME used by custom.
 468 If FRAME is nil, return the default frame properties."
 469   (cond (frame
 470          ;; Try to get from cache.
 471          (let ((cache (frame-property frame 'custom-properties)))
 472            (unless cache
 473              ;; Oh well, get it then.
 474              (setq cache (custom-extract-frame-properties frame))
 475              ;; and cache it...
 476              (modify-frame-parameters frame
 477                                       (list (cons 'custom-properties cache))))
 478            cache))
 479         (custom-default-frame-properties)
 480         (t
 481          (setq custom-default-frame-properties
 482                (custom-extract-frame-properties (selected-frame))))))
 483
 484 (defun custom-display-match-frame (display frame)
 485   "Non-nil iff DISPLAY matches FRAME.
 486 If FRAME is nil, the current FRAME is used."
 487   ;; This is a kludge to get started, we really should use specifiers!
 488   (if (eq display t)
 489       t
 490     (let* ((props (custom-get-frame-properties frame))
 491            (type (plist-get props 'type))
 492            (class (plist-get props 'class))
 493            (background (plist-get props 'background))
 494            (match t)
 495            (entries display)
 496            entry req options)
 497       (while (and entries match)
 498         (setq entry (car entries)
 499               entries (cdr entries)
 500               req (car entry)
 501               options (cdr entry)
 502               match (cond ((eq req 'type)
 503                            (memq type options))
 504                           ((eq req 'class)
 505                            (memq class options))
 506                           ((eq req 'background)
 507                            (memq background options))
 508                           (t
 509                            (error "Unknown req `%S' with options `%S'"
 510                                   req options)))))
 511       match)))
 512
 513 (defun custom-relevant-frames ()
 514   "List of frames whose custom properties differ from the default."
 515   (let ((relevant nil)
 516         (default (custom-get-frame-properties))
 517         (frames (frame-list))
 518         frame)
 519     (while frames
 520       (setq frame (car frames)
 521             frames (cdr frames))
 522       (unless (equal default (custom-get-frame-properties frame))
 523         (push frame relevant)))
 524     relevant))
 525
 526 (defun custom-initialize-faces (&optional frame)
 527   "Initialize all custom faces for FRAME.
 528 If FRAME is nil or omitted, initialize them for all frames."
 529   (mapcar (lambda (symbol)
 530             (let ((spec (or (get symbol 'saved-face)
 531                             (get symbol 'factory-face))))
 532               (when spec
 533                 (custom-face-display-set symbol spec frame)
 534                 (initialize-face-resources symbol frame))))
 535           (face-list)))
 536
 537 ;;;###autoload
 538 (defun custom-initialize-frame (&optional frame)
 539   "Initialize local faces for FRAME if necessary.
 540 If FRAME is missing or nil, the first member of (frame-list) is used."
 541   (unless frame
 542     (setq frame (car (frame-list))))
 543   (unless (equal (custom-get-frame-properties)
 544                  (custom-get-frame-properties frame))
 545     (custom-initialize-faces frame)))
 546
 547 ;; Enable.  This should go away when bundled with Emacs.
 548 (unless (string-match "XEmacs" emacs-version)
 549   (add-hook 'after-make-frame-hook 'custom-initialize-frame))
 550
 551 ;;; Initializing.
 552
 553 (and (fboundp 'make-face)
 554      (make-face 'custom-face-empty))
 555
 556 ;;;###autoload
 557 (defun custom-set-faces (&rest args)
 558   "Initialize faces according to user preferences.
 559 The arguments should be a list where each entry has the form:
 560
 561   (FACE SPEC [NOW])
 562
 563 SPEC will be stored as the saved value for FACE.  If NOW is present
 564 and non-nil, FACE will also be created according to SPEC.
 565
 566 See `defface' for the format of SPEC."
 567   (while args
 568     (let ((entry (car args)))
 569       (if (listp entry)
 570           (let ((face (nth 0 entry))
 571                 (spec (nth 1 entry))
 572                 (now (nth 2 entry)))
 573             (put face 'saved-face spec)
 574             (when now
 575               (put face 'force-face t))
 576             (when (or now (custom-facep face))
 577               (when (fboundp 'copy-face)
 578                 (copy-face 'custom-face-empty face))
 579               (custom-face-display-set face spec))
 580             (setq args (cdr args)))
 581         ;; Old format, a plist of FACE SPEC pairs.
 582         (let ((face (nth 0 args))
 583               (spec (nth 1 args)))
 584           (put face 'saved-face spec))
 585         (setq args (cdr (cdr args)))))))
 586
 587 ;;; The End.
 588
 589 (provide 'cus-face)
 590
 591 ;; cus-face.el ends here