X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/d03d411d4a487dd690831a6d36be662f2f896989..ef62b23df5a7007c3d8c74dbca87ba83e9da682e:/lisp/face-remap.el diff --git a/lisp/face-remap.el b/lisp/face-remap.el index fce25af834..be2207a993 100644 --- a/lisp/face-remap.el +++ b/lisp/face-remap.el @@ -1,9 +1,9 @@ ;;; face-remap.el --- Functions for managing `face-remapping-alist' ;; -;; Copyright (C) 2008 Free Software Foundation, Inc. +;; Copyright (C) 2008-2012 Free Software Foundation, Inc. ;; ;; Author: Miles Bader -;; Keywords: faces face display user commands +;; Keywords: faces, face remapping, display, user commands ;; ;; This file is part of GNU Emacs. ;; @@ -103,24 +103,30 @@ The list structure of ENTRY may be destructively modified." (setcdr entry (sort (cdr entry) 'face-attrs-more-relative-p)) (nreverse entry)) -;;;### autoload +;;;###autoload (defun face-remap-add-relative (face &rest specs) "Add a face remapping entry of FACE to SPECS in the current buffer. - -Return a cookie which can be used to delete the remapping with +Return a cookie which can be used to delete this remapping with `face-remap-remove-relative'. -SPECS can be any value suitable for the `face' text property, -including a face name, a list of face names, or a face-attribute -property list. The attributes given by SPECS will be merged with -any other currently active face remappings of FACE, and with the -global definition of FACE. An attempt is made to sort multiple -entries so that entries with relative face-attributes are applied -after entries with absolute face-attributes. - -The base (lowest priority) remapping may be set to a specific -value, instead of the default of the global face definition, -using `face-remap-set-base'." +The remaining arguments, SPECS, should form a list of faces. +Each list element should be either a face name or a property list +of face attribute/value pairs. If more than one face is listed, +that specifies an aggregate face, in the same way as in a `face' +text property, except for possible priority changes noted below. + +The face remapping specified by SPECS takes effect alongside the +remappings from other calls to `face-remap-add-relative' for the +same FACE, as well as the normal definition of FACE (at lowest +priority). This function tries to sort multiple remappings for +the same face, so that remappings specifying relative face +attributes are applied after remappings specifying absolute face +attributes. + +The base (lowest priority) remapping may be set to something +other than the normal definition of FACE via `face-remap-set-base'." + (while (and (consp specs) (null (cdr specs))) + (setq specs (car specs))) (make-local-variable 'face-remapping-alist) (let ((entry (assq face face-remapping-alist))) (when (null entry) @@ -144,9 +150,11 @@ COOKIE should be the return value from that function." (remq remapping face-remapping-alist))) (cdr cookie)))))) -;;;### autoload +;;;###autoload (defun face-remap-reset-base (face) - "Set the base remapping of FACE to inherit from FACE's global definition." + "Set the base remapping of FACE to the normal definition of FACE. +This causes the remappings specified by `face-remap-add-relative' +to apply on top of the normal definition of FACE." (let ((entry (assq face face-remapping-alist))) (when entry ;; If there's nothing except a base remapping, we simply remove @@ -158,13 +166,22 @@ COOKIE should be the return value from that function." (remq entry face-remapping-alist)) (setcar (last entry) face))))) ; otherwise, just inherit global def -;;;### autoload +;;;###autoload (defun face-remap-set-base (face &rest specs) "Set the base remapping of FACE in the current buffer to SPECS. -If SPECS is empty, the default base remapping is restored, which -inherits from the global definition of FACE; note that this is -different from SPECS containing a single value `nil', which does -not inherit from the global definition of FACE." +This causes the remappings specified by `face-remap-add-relative' +to apply on top of the face specification given by SPECS. + +The remaining arguments, SPECS, should form a list of faces. +Each list element should be either a face name or a property list +of face attribute/value pairs, like in a `face' text property. + +If SPECS is empty, call `face-remap-reset-base' to use the normal +definition of FACE as the base remapping; note that this is +different from SPECS containing a single value `nil', which means +not to inherit from the global definition of FACE at all." + (while (and (consp specs) (not (null (car specs))) (null (cdr specs))) + (setq specs (car specs))) (if (or (null specs) (and (eq (car specs) face) (null (cdr specs)))) ; default ;; Set entry back to default @@ -184,7 +201,8 @@ not inherit from the global definition of FACE." "Scale factor used by `text-scale-mode'. Each positive or negative step scales the default face height by this amount." :group 'display - :type 'number) + :type 'number + :version "23.1") ;; current remapping cookie for text-scale-mode (defvar text-scale-mode-remapping nil) @@ -199,17 +217,20 @@ Each positive or negative step scales the default face height by this amount." (make-variable-buffer-local 'text-scale-mode-amount) (define-minor-mode text-scale-mode - "Minor mode for displaying buffer text in a larger/smaller font than usual. + "Minor mode for displaying buffer text in a larger/smaller font. +With a prefix argument ARG, enable the mode if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil. The amount of scaling is determined by the variable `text-scale-mode-amount': one step scales the global default face size by the value of the variable `text-scale-mode-step' \(a negative amount shrinks the text). -The `text-scale-increase' and `text-scale-decrease' functions may -be used to interactively modify the variable -`text-scale-mode-amount' (they also enable or disable -`text-scale-mode' as necessary)." +The `text-scale-increase', `text-scale-decrease', and +`text-scale-set' functions may be used to interactively modify +the variable `text-scale-mode-amount' (they also enable or +disable `text-scale-mode' as necessary)." :lighter (" " text-scale-mode-lighter) (when text-scale-mode-remapping (face-remap-remove-relative text-scale-mode-remapping)) @@ -225,7 +246,20 @@ be used to interactively modify the variable (force-window-update (current-buffer))) ;;;###autoload -(defun text-scale-increase (&optional inc) +(defun text-scale-set (level) + "Set the scale factor of the default face in the current buffer to LEVEL. +If LEVEL is non-zero, `text-scale-mode' is enabled, otherwise it is disabled. + +LEVEL is a number of steps, with 0 representing the default size. +Each step scales the height of the default face by the variable +`text-scale-mode-step' (a negative number decreases the height by +the same amount)." + (interactive "p") + (setq text-scale-mode-amount level) + (text-scale-mode (if (zerop text-scale-mode-amount) -1 1))) + +;;;###autoload +(defun text-scale-increase (inc) "Increase the height of the default face in the current buffer by INC steps. If the new height is other than the default, `text-scale-mode' is enabled. @@ -234,11 +268,12 @@ Each step scales the height of the default face by the variable height by the same amount). As a special case, an argument of 0 will remove any scaling currently active." (interactive "p") - (setq text-scale-mode-amount (if (= inc 0) 0 (+ text-scale-mode-amount inc))) + (setq text-scale-mode-amount + (if (= inc 0) 0 (+ (if text-scale-mode text-scale-mode-amount 0) inc))) (text-scale-mode (if (zerop text-scale-mode-amount) -1 1))) ;;;###autoload -(defun text-scale-decrease (&optional dec) +(defun text-scale-decrease (dec) "Decrease the height of the default face in the current buffer by DEC steps. See `text-scale-increase' for more details." (interactive "p") @@ -249,7 +284,7 @@ See `text-scale-increase' for more details." ;;;###autoload (define-key ctl-x-map [(control ?=)] 'text-scale-adjust) ;;;###autoload (define-key ctl-x-map [(control ?0)] 'text-scale-adjust) ;;;###autoload -(defun text-scale-adjust (&optional inc) +(defun text-scale-adjust (inc) "Increase or decrease the height of the default face in the current buffer. The actual adjustment made depends on the final component of the @@ -275,51 +310,144 @@ a top-level keymap, `text-scale-increase' or `text-scale-decrease' may be more appropriate." (interactive "p") (let ((first t) - (step t) - (ev last-command-event)) - (while step - (let ((base (event-basic-type ev))) - (cond ((or (eq base ?+) (eq base ?=)) - (setq step inc)) - ((eq base ?-) - (setq step (- inc))) - ((eq base ?0) - (setq step 0)) - (first - (setq step inc)) - (t - (setq step nil)))) - (when step - (text-scale-increase step) - (setq inc 1 first nil) - (setq ev (read-event)))) - (push ev unread-command-events))) + (ev last-command-event) + (echo-keystrokes nil)) + (let* ((base (event-basic-type ev)) + (step + (pcase base + ((or `?+ `?=) inc) + (`?- (- inc)) + (`?0 0) + (t inc)))) + (text-scale-increase step) + ;; FIXME: do it after everu "iteration of the loop". + (message "+,-,0 for further adjustment: ") + (set-temporary-overlay-map + (let ((map (make-sparse-keymap))) + (dolist (mods '(() (control))) + (define-key map (vector (append mods '(?-))) 'text-scale-decrease) + (define-key map (vector (append mods '(?+))) 'text-scale-increase) + ;; = is unshifted + on most keyboards. + (define-key map (vector (append mods '(?=))) 'text-scale-increase) + (define-key map (vector (append mods '(?0))) + (lambda () (interactive) (text-scale-increase 0)))) + map) + t)))) ;; ---------------------------------------------------------------- -;; variable-pitch-mode +;; buffer-face-mode -;; suggested key binding: (global-set-key "\C-cv" 'variable-pitch-mode) +(defcustom buffer-face-mode-face 'variable-pitch + "The face specification used by `buffer-face-mode'. +It may contain any value suitable for a `face' text property, +including a face name, a list of face names, a face-attribute +plist, etc." + :group 'display + :version "23.1") -;; current remapping cookie for variable-pitch-mode -(defvar variable-pitch-mode-remapping nil) -(make-variable-buffer-local 'variable-pitch-mode-remapping) +;; current remapping cookie for buffer-face-mode +(defvar buffer-face-mode-remapping nil) +(make-variable-buffer-local 'buffer-face-mode-remapping) ;;;###autoload -(define-minor-mode variable-pitch-mode - "Variable-pitch default-face mode. -When active, causes the buffer text to be displayed using -the `variable-pitch' face." - :lighter " VarPitch" - (when variable-pitch-mode-remapping - (face-remap-remove-relative variable-pitch-mode-remapping)) - (setq variable-pitch-mode-remapping - (and variable-pitch-mode - (face-remap-add-relative 'default 'variable-pitch))) +(define-minor-mode buffer-face-mode + "Minor mode for a buffer-specific default face. +With a prefix argument ARG, enable the mode if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil. When enabled, the face specified by the +variable `buffer-face-mode-face' is used to display the buffer text." + :lighter " BufFace" + (when buffer-face-mode-remapping + (face-remap-remove-relative buffer-face-mode-remapping)) + (setq buffer-face-mode-remapping + (and buffer-face-mode + (face-remap-add-relative 'default buffer-face-mode-face))) (force-window-update (current-buffer))) +;;;###autoload +(defun buffer-face-set (&rest specs) + "Enable `buffer-face-mode', using face specs SPECS. +Each argument in SPECS should be a face, i.e. either a face name +or a property list of face attributes and values. If more than +one face is listed, that specifies an aggregate face, like in a +`face' text property. If SPECS is nil or omitted, disable +`buffer-face-mode'. + +This function makes the variable `buffer-face-mode-face' buffer +local, and sets it to FACE." + (interactive (list (read-face-name "Set buffer face"))) + (while (and (consp specs) (null (cdr specs))) + (setq specs (car specs))) + (if (null specs) + (buffer-face-mode 0) + (set (make-local-variable 'buffer-face-mode-face) specs) + (buffer-face-mode t))) + +;;;###autoload +(defun buffer-face-toggle (&rest specs) + "Toggle `buffer-face-mode', using face specs SPECS. +Each argument in SPECS should be a face, i.e. either a face name +or a property list of face attributes and values. If more than +one face is listed, that specifies an aggregate face, like in a +`face' text property. + +If `buffer-face-mode' is already enabled, and is currently using +the face specs SPECS, then it is disabled; if buffer-face-mode is +disabled, or is enabled and currently displaying some other face, +then is left enabled, but the face changed to reflect SPECS. + +This function will make the variable `buffer-face-mode-face' +buffer local, and set it to SPECS." + (interactive (list buffer-face-mode-face)) + (while (and (consp specs) (null (cdr specs))) + (setq specs (car specs))) + (if (or (null specs) + (and buffer-face-mode (equal buffer-face-mode-face specs))) + (buffer-face-mode 0) + (set (make-local-variable 'buffer-face-mode-face) specs) + (buffer-face-mode t))) + +(defun buffer-face-mode-invoke (specs arg &optional interactive) + "Enable or disable `buffer-face-mode' using face specs SPECS, and argument ARG. +ARG controls whether the mode is enabled or disabled, and is +interpreted in the usual manner for minor-mode commands. + +SPECS can be any value suitable for a `face' text property, +including a face name, a plist of face attributes and values, or +a list of faces. + +If INTERACTIVE is non-nil, display a message describing the +result. + +This is a wrapper function which calls `buffer-face-set' or +`buffer-face-toggle' (depending on ARG), and prints a status +message in the echo area. In many cases one of those functions +may be more appropriate." + (let ((last-message (current-message))) + (if (or (eq arg 'toggle) (not arg)) + (buffer-face-toggle specs) + (buffer-face-set (and (> (prefix-numeric-value arg) 0) specs))) + (when interactive + (unless (and (current-message) + (not (equal last-message (current-message)))) + (message "Buffer-Face mode %sabled" + (if buffer-face-mode "en" "dis")))))) + + +;; ---------------------------------------------------------------- +;; variable-pitch-mode + +;;;###autoload +(defun variable-pitch-mode (&optional arg) + "Variable-pitch default-face mode. +An interface to `buffer-face-mode' which uses the `variable-pitch' face. +Besides the choice of face, it is the same as `buffer-face-mode'." + (interactive (list (or current-prefix-arg 'toggle))) + (buffer-face-mode-invoke 'variable-pitch arg + (called-interactively-p 'interactive))) + (provide 'face-remap) -;; arch-tag: 5c5f034b-8d58-4967-82bd-d61fd364e686 ;;; face-remap.el ends here