LCOV - code coverage report
Current view: top level - lisp - facemenu.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 38 320 11.9 %
Date: 2017-08-27 09:44:50 Functions: 6 33 18.2 %

          Line data    Source code
       1             : ;;; facemenu.el --- create a face menu for interactively adding fonts to text
       2             : 
       3             : ;; Copyright (C) 1994-1996, 2001-2017 Free Software Foundation, Inc.
       4             : 
       5             : ;; Author: Boris Goldowsky <boris@gnu.org>
       6             : ;; Keywords: faces
       7             : ;; Package: emacs
       8             : 
       9             : ;; This file is part of GNU Emacs.
      10             : 
      11             : ;; GNU Emacs is free software: you can redistribute it and/or modify
      12             : ;; it under the terms of the GNU General Public License as published by
      13             : ;; the Free Software Foundation, either version 3 of the License, or
      14             : ;; (at your option) any later version.
      15             : 
      16             : ;; GNU Emacs is distributed in the hope that it will be useful,
      17             : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
      18             : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      19             : ;; GNU General Public License for more details.
      20             : 
      21             : ;; You should have received a copy of the GNU General Public License
      22             : ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
      23             : 
      24             : ;;; Commentary:
      25             : 
      26             : ;; This file defines a menu of faces (bold, italic, etc) which allows you to
      27             : ;; set the face used for a region of the buffer.  Some faces also have
      28             : ;; keybindings, which are shown in the menu.
      29             : ;;
      30             : ;; The menu also contains submenus for indentation and justification-changing
      31             : ;; commands.
      32             : 
      33             : ;;; Usage:
      34             : ;; Selecting a face from the menu or typing the keyboard equivalent will
      35             : ;; change the region to use that face.  If you use transient-mark-mode and the
      36             : ;; region is not active, the face will be remembered and used for the next
      37             : ;; insertion.  It will be forgotten if you move point or make other
      38             : ;; modifications before inserting or typing anything.
      39             : ;;
      40             : ;; Faces can be selected from the keyboard as well.
      41             : ;; The standard keybindings are M-o (or ESC o) + letter:
      42             : ;; M-o i = "set italic",  M-o b = "set bold", etc.
      43             : 
      44             : ;;; Customization:
      45             : ;; An alternative set of keybindings that may be easier to type can be set up
      46             : ;; using "Alt" or "Hyper" keys.  This requires that you either have or create
      47             : ;; an Alt or Hyper key on your keyboard.  On my keyboard, there is a key
      48             : ;; labeled "Alt", but to make it act as an Alt key I have to put this command
      49             : ;; into my .xinitrc:
      50             : ;;    xmodmap -e "add Mod3 = Alt_L"
      51             : ;; Or, I can make it into a Hyper key with this:
      52             : ;;    xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L"
      53             : ;; Check with local X-perts for how to do it on your system.
      54             : ;; Then you can define your keybindings with code like this in your .emacs:
      55             : ;;   (setq facemenu-keybindings
      56             : ;;    '((default     . [?\H-d])
      57             : ;;      (bold        . [?\H-b])
      58             : ;;      (italic      . [?\H-i])
      59             : ;;      (bold-italic . [?\H-l])
      60             : ;;      (underline   . [?\H-u])))
      61             : ;;   (facemenu-update)
      62             : ;;   (setq facemenu-keymap global-map)
      63             : ;;   (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color
      64             : ;;   (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color
      65             : ;;
      66             : ;; The order of the faces that appear in the menu and their keybindings can be
      67             : ;; controlled by setting the variables `facemenu-keybindings' and
      68             : ;; `facemenu-new-faces-at-end'.  List faces that you want to use in documents
      69             : ;; in `facemenu-listed-faces'.
      70             : 
      71             : ;;; Known Problems:
      72             : ;; Bold and Italic do not combine to create bold-italic if you select them
      73             : ;; both, although most other combinations (eg bold + underline + some color)
      74             : ;; do the intuitive thing.
      75             : ;;
      76             : ;; There is at present no way to display what the faces look like in
      77             : ;; the menu itself.
      78             : ;;
      79             : ;; `list-faces-display' shows the faces in a different order than
      80             : ;; this menu, which could be confusing.  I do /not/ sort the list
      81             : ;; alphabetically, because I like the default order: it puts the most
      82             : ;; basic, common fonts first.
      83             : ;;
      84             : ;; Please send me any other problems, comments or ideas.
      85             : 
      86             : ;;; Code:
      87             : 
      88             : (eval-when-compile
      89             :   (require 'help)
      90             :   (require 'button))
      91             : 
      92             : ;; Global bindings:
      93             : (define-key global-map [C-down-mouse-2] 'facemenu-menu)
      94             : (define-key global-map "\M-o" 'facemenu-keymap)
      95             : 
      96             : (defgroup facemenu nil
      97             :   "Create a face menu for interactively adding fonts to text."
      98             :   :group 'faces
      99             :   :prefix "facemenu-")
     100             : 
     101             : (defcustom facemenu-keybindings
     102             :   (mapcar 'purecopy
     103             :   '((default     . "d")
     104             :     (bold        . "b")
     105             :     (italic      . "i")
     106             :     (bold-italic . "l") ; {bold} intersect {italic} = {l}
     107             :     (underline   . "u")))
     108             :   "Alist of interesting faces and keybindings.
     109             : Each element is itself a list: the car is the name of the face,
     110             : the next element is the key to use as a keyboard equivalent of the menu item;
     111             : the binding is made in `facemenu-keymap'.
     112             : 
     113             : The faces specifically mentioned in this list are put at the top of
     114             : the menu, in the order specified.  All other faces which are defined
     115             : in `facemenu-listed-faces' are listed after them, but get no
     116             : keyboard equivalents.
     117             : 
     118             : If you change this variable after loading facemenu.el, you will need to call
     119             : `facemenu-update' to make it take effect."
     120             :   :type '(repeat (cons face string))
     121             :   :group 'facemenu)
     122             : 
     123             : (defcustom facemenu-new-faces-at-end t
     124             :   "Where in the menu to insert newly-created faces.
     125             : This should be nil to put them at the top of the menu, or t to put them
     126             : just before \"Other\" at the end."
     127             :   :type 'boolean
     128             :   :group 'facemenu)
     129             : 
     130             : (defcustom facemenu-listed-faces nil
     131             :   "List of faces to include in the Face menu.
     132             : Each element should be a symbol, the name of a face.
     133             : The \"basic \" faces in `facemenu-keybindings' are automatically
     134             : added to the Face menu, and need not be in this list.
     135             : 
     136             : This value takes effect when you load facemenu.el.  If the
     137             : list includes symbols which are not defined as faces, they
     138             : are ignored; however, subsequently defining or creating
     139             : those faces adds them to the menu then.  You can call
     140             : `facemenu-update' to recalculate the menu contents, such as
     141             : if you change the value of this variable,
     142             : 
     143             : If this variable is t, all faces that you apply to text
     144             : using the face menu commands (even by name), and all faces
     145             : that you define or create, are added to the menu.  You may
     146             : find it useful to set this variable to t temporarily while
     147             : you define some faces, so that they will be added.  However,
     148             : if the value is no longer t and you call `facemenu-update',
     149             : it will remove any faces not explicitly in the list."
     150             :   :type '(choice (const :tag "List all faces" t)
     151             :                  (const :tag "None" nil)
     152             :                  (repeat symbol))
     153             :   :group 'facemenu
     154             :   :version "22.1")
     155             : 
     156             : (defvar facemenu-face-menu
     157             :   (let ((map (make-sparse-keymap "Face")))
     158             :     (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
     159             :     map)
     160             :   "Menu keymap for faces.")
     161             : (defalias 'facemenu-face-menu facemenu-face-menu)
     162             : (put 'facemenu-face-menu 'menu-enable '(facemenu-enable-faces-p))
     163             : 
     164             : (defvar facemenu-foreground-menu
     165             :   (let ((map (make-sparse-keymap "Foreground Color")))
     166             :     (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-foreground))
     167             :     map)
     168             :   "Menu keymap for foreground colors.")
     169             : (defalias 'facemenu-foreground-menu facemenu-foreground-menu)
     170             : (put 'facemenu-foreground-menu 'menu-enable '(facemenu-enable-faces-p))
     171             : 
     172             : (defvar facemenu-background-menu
     173             :   (let ((map (make-sparse-keymap "Background Color")))
     174             :     (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-background))
     175             :     map)
     176             :   "Menu keymap for background colors.")
     177             : (defalias 'facemenu-background-menu facemenu-background-menu)
     178             : (put 'facemenu-background-menu 'menu-enable '(facemenu-enable-faces-p))
     179             : 
     180             : ;;; Condition for enabling menu items that set faces.
     181             : (defun facemenu-enable-faces-p ()
     182             :   ;; Enable the facemenu if facemenu-add-face-function is defined
     183             :   ;; (e.g. in Tex-mode and SGML mode), or if font-lock is off.
     184           0 :   (or (not (and font-lock-mode font-lock-defaults))
     185           0 :       facemenu-add-face-function))
     186             : 
     187             : (defvar facemenu-special-menu
     188             :   (let ((map (make-sparse-keymap "Special")))
     189             :     (define-key map [?s] (cons (purecopy "Remove Special")
     190             :                                'facemenu-remove-special))
     191             :     (define-key map [?t] (cons (purecopy "Intangible")
     192             :                                'facemenu-set-intangible))
     193             :     (define-key map [?v] (cons (purecopy "Invisible")
     194             :                                'facemenu-set-invisible))
     195             :     (define-key map [?r] (cons (purecopy "Read-Only")
     196             :                                'facemenu-set-read-only))
     197             :     map)
     198             :   "Menu keymap for non-face text-properties.")
     199             : (defalias 'facemenu-special-menu facemenu-special-menu)
     200             : 
     201             : (defvar facemenu-justification-menu
     202             :   (let ((map (make-sparse-keymap "Justification")))
     203             :     (define-key map [?c] (cons (purecopy "Center") 'set-justification-center))
     204             :     (define-key map [?b] (cons (purecopy "Full") 'set-justification-full))
     205             :     (define-key map [?r] (cons (purecopy "Right") 'set-justification-right))
     206             :     (define-key map [?l] (cons (purecopy "Left") 'set-justification-left))
     207             :     (define-key map [?u] (cons (purecopy "Unfilled") 'set-justification-none))
     208             :     map)
     209             :   "Submenu for text justification commands.")
     210             : (defalias 'facemenu-justification-menu facemenu-justification-menu)
     211             : 
     212             : (defvar facemenu-indentation-menu
     213             :   (let ((map (make-sparse-keymap "Indentation")))
     214             :     (define-key map [decrease-right-margin]
     215             :       (cons (purecopy "Indent Right Less") 'decrease-right-margin))
     216             :     (define-key map [increase-right-margin]
     217             :       (cons (purecopy "Indent Right More") 'increase-right-margin))
     218             :     (define-key map [decrease-left-margin]
     219             :       (cons (purecopy "Indent Less") 'decrease-left-margin))
     220             :     (define-key map [increase-left-margin]
     221             :       (cons (purecopy "Indent More") 'increase-left-margin))
     222             :     map)
     223             :   "Submenu for indentation commands.")
     224             : (defalias 'facemenu-indentation-menu facemenu-indentation-menu)
     225             : 
     226             : ;; This is split up to avoid an overlong line in loaddefs.el.
     227             : (defvar facemenu-menu nil
     228             :   "Facemenu top-level menu keymap.")
     229             : (setq facemenu-menu (make-sparse-keymap "Text Properties"))
     230             : (let ((map facemenu-menu))
     231             :   (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
     232             :   (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
     233             :   (define-key map [dp] (cons (purecopy "Describe Properties")
     234             :                              'describe-text-properties))
     235             :   (define-key map [ra] (list 'menu-item (purecopy "Remove Text Properties")
     236             :                              'facemenu-remove-all
     237             :                              :enable 'mark-active))
     238             :   (define-key map [rm] (list 'menu-item (purecopy "Remove Face Properties")
     239             :                              'facemenu-remove-face-props
     240             :                              :enable 'mark-active))
     241             :   (define-key map [s1] (list (purecopy "--"))))
     242             : (let ((map facemenu-menu))
     243             :   (define-key map [in] (cons (purecopy "Indentation")
     244             :                              'facemenu-indentation-menu))
     245             :   (define-key map [ju] (cons (purecopy "Justification")
     246             :                              'facemenu-justification-menu))
     247             :   (define-key map [s2] (list (purecopy "--")))
     248             :   (define-key map [sp] (cons (purecopy "Special Properties")
     249             :                              'facemenu-special-menu))
     250             :   (define-key map [bg] (cons (purecopy "Background Color")
     251             :                              'facemenu-background-menu))
     252             :   (define-key map [fg] (cons (purecopy "Foreground Color")
     253             :                              'facemenu-foreground-menu))
     254             :   (define-key map [fc] (cons (purecopy "Face")
     255             :                              'facemenu-face-menu)))
     256             : (defalias 'facemenu-menu facemenu-menu)
     257             : 
     258             : (defvar facemenu-keymap
     259             :   (let ((map (make-sparse-keymap "Set face")))
     260             :     (define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face))
     261             :     (define-key map "\M-o" 'font-lock-fontify-block)
     262             :     map)
     263             :   "Keymap for face-changing commands.
     264             : `Facemenu-update' fills in the keymap according to the bindings
     265             : requested in `facemenu-keybindings'.")
     266             : (defalias 'facemenu-keymap facemenu-keymap)
     267             : 
     268             : 
     269             : (defcustom facemenu-add-face-function nil
     270             :   "Function called at beginning of text to change or nil.
     271             : This function is passed the FACE to set and END of text to change, and must
     272             : return a string which is inserted.  It may set `facemenu-end-add-face'."
     273             :   :type '(choice (const :tag "None" nil)
     274             :                  function)
     275             :   :group 'facemenu)
     276             : 
     277             : (defcustom facemenu-end-add-face nil
     278             :   "String to insert or function called at end of text to change or nil.
     279             : This function is passed the FACE to set, and must return a string which is
     280             : inserted."
     281             :   :type '(choice (const :tag "None" nil)
     282             :                  string
     283             :                  function)
     284             :   :group 'facemenu)
     285             : 
     286             : (defcustom facemenu-remove-face-function nil
     287             :   "When non-nil, this is a function called to remove faces.
     288             : This function is passed the START and END of text to change.
     289             : May also be t meaning to use `facemenu-add-face-function'."
     290             :   :type '(choice (const :tag "None" nil)
     291             :                  (const :tag "Use add-face" t)
     292             :                  function)
     293             :   :group 'facemenu)
     294             : 
     295             : ;;; Internal Variables
     296             : 
     297             : (defvar facemenu-color-alist nil
     298             :   "Alist of colors, used for completion.
     299             : If this is nil, then the value of (defined-colors) is used.")
     300             : 
     301             : (defun facemenu-update ()
     302             :   "Add or update the \"Face\" menu in the menu bar.
     303             : You can call this to update things if you change any of the menu configuration
     304             : variables."
     305             :   (interactive)
     306             : 
     307             :   ;; Add each defined face to the menu.
     308           1 :   (facemenu-iterate 'facemenu-add-new-face
     309           1 :                     (facemenu-complete-face-list facemenu-keybindings)))
     310             : 
     311             : (defun facemenu-set-face (face &optional start end)
     312             :   "Apply FACE to the region or next character typed.
     313             : 
     314             : If the region is active (normally true except in Transient
     315             : Mark mode) and nonempty, and there is no prefix argument,
     316             : this command applies FACE to the region.  Otherwise, it applies FACE
     317             : to the faces to use for the next character
     318             : inserted.  (Moving point or switching buffers before typing
     319             : a character to insert cancels the specification.)
     320             : 
     321             : If FACE is `default', to \"apply\" it means clearing
     322             : the list of faces to be used.  For any other value of FACE,
     323             : to \"apply\" it means putting FACE at the front of the list
     324             : of faces to be used, and removing any faces further
     325             : along in the list that would be completely overridden by
     326             : preceding faces (including FACE).
     327             : 
     328             : This command can also add FACE to the menu of faces,
     329             : if `facemenu-listed-faces' says to do that."
     330           0 :   (interactive (list (progn
     331           0 :                        (barf-if-buffer-read-only)
     332           0 :                        (read-face-name "Use face" (face-at-point t)))
     333           0 :                      (if (and mark-active (not current-prefix-arg))
     334           0 :                          (region-beginning))
     335           0 :                      (if (and mark-active (not current-prefix-arg))
     336           0 :                          (region-end))))
     337           0 :   (facemenu-add-new-face face)
     338           0 :   (facemenu-add-face face start end))
     339             : 
     340             : (defun facemenu-set-foreground (color &optional start end)
     341             :   "Set the foreground COLOR of the region or next character typed.
     342             : This command reads the color in the minibuffer.
     343             : 
     344             : If the region is active (normally true except in Transient Mark mode)
     345             : and there is no prefix argument, this command sets the region to the
     346             : requested face.
     347             : 
     348             : Otherwise, this command specifies the face for the next character
     349             : inserted.  Moving point or switching buffers before
     350             : typing a character to insert cancels the specification."
     351           0 :   (interactive (list (progn
     352           0 :                        (barf-if-buffer-read-only)
     353           0 :                        (read-color "Foreground color: "))
     354           0 :                      (if (and mark-active (not current-prefix-arg))
     355           0 :                          (region-beginning))
     356           0 :                      (if (and mark-active (not current-prefix-arg))
     357           0 :                          (region-end))))
     358           0 :   (facemenu-set-face-from-menu
     359           0 :    (facemenu-add-new-color color 'facemenu-foreground-menu)
     360           0 :    start end))
     361             : 
     362             : (defun facemenu-set-background (color &optional start end)
     363             :   "Set the background COLOR of the region or next character typed.
     364             : This command reads the color in the minibuffer.
     365             : 
     366             : If the region is active (normally true except in Transient Mark mode)
     367             : and there is no prefix argument, this command sets the region to the
     368             : requested face.
     369             : 
     370             : Otherwise, this command specifies the face for the next character
     371             : inserted.  Moving point or switching buffers before
     372             : typing a character to insert cancels the specification."
     373           0 :   (interactive (list (progn
     374           0 :                        (barf-if-buffer-read-only)
     375           0 :                        (read-color "Background color: "))
     376           0 :                      (if (and mark-active (not current-prefix-arg))
     377           0 :                          (region-beginning))
     378           0 :                      (if (and mark-active (not current-prefix-arg))
     379           0 :                          (region-end))))
     380           0 :   (facemenu-set-face-from-menu
     381           0 :    (facemenu-add-new-color color 'facemenu-background-menu)
     382           0 :    start end))
     383             : 
     384             : (defun facemenu-set-face-from-menu (face start end)
     385             :   "Set the FACE of the region or next character typed.
     386             : This function is designed to be called from a menu; FACE is determined
     387             : using the event type of the menu entry.  If FACE is a symbol whose
     388             : name starts with \"fg:\" or \"bg:\", then this functions sets the
     389             : foreground or background to the color specified by the rest of the
     390             : symbol's name.  Any other symbol is considered the name of a face.
     391             : 
     392             : If the region is active (normally true except in Transient Mark mode)
     393             : and there is no prefix argument, this command sets the region to the
     394             : requested face.
     395             : 
     396             : Otherwise, this command specifies the face for the next character
     397             : inserted.  Moving point or switching buffers before typing a character
     398             : to insert cancels the specification."
     399           0 :   (interactive (list last-command-event
     400           0 :                      (if (and mark-active (not current-prefix-arg))
     401           0 :                          (region-beginning))
     402           0 :                      (if (and mark-active (not current-prefix-arg))
     403           0 :                          (region-end))))
     404           0 :   (barf-if-buffer-read-only)
     405           0 :   (facemenu-add-face
     406           0 :    (let ((fn (symbol-name face)))
     407           0 :      (if (string-match "\\`\\([fb]\\)g:\\(.+\\)" fn)
     408           0 :          (list (list (if (string= (match-string 1 fn) "f")
     409             :                          :foreground
     410           0 :                        :background)
     411           0 :                      (match-string 2 fn)))
     412           0 :        face))
     413           0 :    start end))
     414             : 
     415             : (defun facemenu-set-invisible (start end)
     416             :   "Make the region invisible.
     417             : This sets the `invisible' text property; it can be undone with
     418             : `facemenu-remove-special'."
     419             :   (interactive "r")
     420           0 :   (add-text-properties start end '(invisible t)))
     421             : 
     422             : (defun facemenu-set-intangible (start end)
     423             :   "Make the region intangible: disallow moving into it.
     424             : This sets the `intangible' text property; it can be undone with
     425             : `facemenu-remove-special'."
     426             :   (interactive "r")
     427           0 :   (add-text-properties start end '(intangible t)))
     428             : 
     429             : (defun facemenu-set-read-only (start end)
     430             :   "Make the region unmodifiable.
     431             : This sets the `read-only' text property; it can be undone with
     432             : `facemenu-remove-special'."
     433             :   (interactive "r")
     434           0 :   (add-text-properties start end '(read-only t)))
     435             : 
     436             : (defun facemenu-remove-face-props (start end)
     437             :   "Remove `face' and `mouse-face' text properties."
     438             :   (interactive "*r") ; error if buffer is read-only despite the next line.
     439           0 :   (let ((inhibit-read-only t))
     440           0 :     (remove-text-properties
     441           0 :      start end '(face nil mouse-face nil))))
     442             : 
     443             : (defun facemenu-remove-all (start end)
     444             :   "Remove all text properties from the region."
     445             :   (interactive "*r") ; error if buffer is read-only despite the next line.
     446           0 :   (let ((inhibit-read-only t))
     447           0 :     (set-text-properties start end nil)))
     448             : 
     449             : (defun facemenu-remove-special (start end)
     450             :   "Remove all the \"special\" text properties from the region.
     451             : These special properties include `invisible', `intangible' and `read-only'."
     452             :   (interactive "*r") ; error if buffer is read-only despite the next line.
     453           0 :   (let ((inhibit-read-only t))
     454           0 :     (remove-text-properties
     455           0 :      start end '(invisible nil intangible nil read-only nil))))
     456             : 
     457             : (defalias 'facemenu-read-color 'read-color)
     458             : 
     459             : (defcustom list-colors-sort nil
     460             :   "Color sort order for `list-colors-display'.
     461             : nil means default implementation-dependent order (defined in `x-colors').
     462             : `name' sorts by color name.
     463             : `rgb' sorts by red, green, blue components.
     464             : `(rgb-dist . COLOR)' sorts by the RGB distance to the specified color.
     465             : `hsv' sorts by hue, saturation, value.
     466             : `(hsv-dist . COLOR)' sorts by the HSV distance to the specified color
     467             : and excludes grayscale colors.
     468             : `luminance' sorts by relative luminance in the CIE XYZ color space."
     469             :   :type '(choice (const :tag "Unsorted" nil)
     470             :                  (const :tag "Color Name" name)
     471             :                  (const :tag "Red-Green-Blue" rgb)
     472             :                  (cons :tag "Distance on RGB cube"
     473             :                        (const :tag "Distance from Color" rgb-dist)
     474             :                        (color :tag "Source Color Name"))
     475             :                  (const :tag "Hue-Saturation-Value" hsv)
     476             :                  (cons :tag "Distance on HSV cylinder"
     477             :                        (const :tag "Distance from Color" hsv-dist)
     478             :                        (color :tag "Source Color Name"))
     479             :                  (const :tag "Luminance" luminance))
     480             :   :group 'facemenu
     481             :   :version "24.1")
     482             : 
     483             : (defun list-colors-sort-key (color)
     484             :   "Return a list of keys for sorting colors depending on `list-colors-sort'.
     485             : COLOR is the name of the color.  When return value is nil,
     486             : filter out the color from the output."
     487           0 :   (require 'color)
     488           0 :   (cond
     489           0 :    ((null list-colors-sort) color)
     490           0 :    ((eq list-colors-sort 'name)
     491           0 :     (downcase color))
     492           0 :    ((eq list-colors-sort 'rgb)
     493           0 :     (color-values color))
     494           0 :    ((eq (car-safe list-colors-sort) 'rgb-dist)
     495           0 :     (color-distance color (cdr list-colors-sort)))
     496           0 :    ((eq list-colors-sort 'hsv)
     497           0 :     (apply 'color-rgb-to-hsv (color-name-to-rgb color)))
     498           0 :    ((eq (car-safe list-colors-sort) 'hsv-dist)
     499           0 :     (let* ((c-rgb (color-name-to-rgb color))
     500           0 :            (c-hsv (apply 'color-rgb-to-hsv c-rgb))
     501           0 :            (o-hsv (apply 'color-rgb-to-hsv
     502           0 :                          (color-name-to-rgb (cdr list-colors-sort)))))
     503           0 :       (unless (and (eq (nth 0 c-rgb) (nth 1 c-rgb)) ; exclude grayscale
     504           0 :                    (eq (nth 1 c-rgb) (nth 2 c-rgb)))
     505             :         ;; 3D Euclidean distance (sqrt is not needed for sorting)
     506           0 :         (+ (expt (- 180 (abs (- 180 (abs (- (nth 0 c-hsv) ; wrap hue
     507           0 :                                             (nth 0 o-hsv)))))) 2)
     508           0 :            (expt (- (nth 1 c-hsv) (nth 1 o-hsv)) 2)
     509           0 :            (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2)))))
     510           0 :    ((eq list-colors-sort 'luminance)
     511           0 :     (let ((c-rgb (color-name-to-rgb color)))
     512           0 :       (+ (* (nth 0 c-rgb) 0.21266729)
     513           0 :          (* (nth 1 c-rgb) 0.7151522)
     514           0 :          (* (nth 2 c-rgb) 0.0721750))))))
     515             : 
     516             : (defvar list-colors-callback nil
     517             :   "Value of CALLBACK arg passed to `list-colors-display'; internal use.")
     518             : 
     519             : (defun list-colors-redisplay (_ignore-auto _noconfirm)
     520             :   "Redisplay the colors using `list-colors-sort'.
     521             : 
     522             : This is installed as a `revert-buffer-function' in the *Colors* buffer."
     523           0 :   (list-colors-display nil (buffer-name) list-colors-callback))
     524             : 
     525             : (defun list-colors-display (&optional list buffer-name callback)
     526             :   "Display names of defined colors, and show what they look like.
     527             : If the optional argument LIST is non-nil, it should be a list of
     528             : colors to display.  Otherwise, this command computes a list of
     529             : colors that the current display can handle.  Customize
     530             : `list-colors-sort' to change the order in which colors are shown.
     531             : Type `g' or \\[revert-buffer] after customizing `list-colors-sort'
     532             : to redisplay colors in the new order.
     533             : 
     534             : If the optional argument BUFFER-NAME is nil, it defaults to *Colors*.
     535             : 
     536             : If the optional argument CALLBACK is non-nil, it should be a
     537             : function to call each time the user types RET or clicks on a
     538             : color.  The function should accept a single argument, the color name."
     539             :   (interactive)
     540           0 :   (when (and (null list) (> (display-color-cells) 0))
     541           0 :     (setq list (list-colors-duplicates (defined-colors)))
     542           0 :     (when list-colors-sort
     543             :       ;; Schwartzian transform with `(color key1 key2 key3 ...)'.
     544           0 :       (setq list (mapcar
     545             :                   'car
     546           0 :                   (sort (delq nil (mapcar
     547             :                                    (lambda (c)
     548           0 :                                      (let ((key (list-colors-sort-key
     549           0 :                                                  (car c))))
     550           0 :                                        (when key
     551           0 :                                          (cons c (if (consp key) key
     552           0 :                                                    (list key))))))
     553           0 :                                    list))
     554             :                         (lambda (a b)
     555           0 :                           (let* ((a-keys (cdr a))
     556           0 :                                  (b-keys (cdr b))
     557           0 :                                  (a-key (car a-keys))
     558           0 :                                  (b-key (car b-keys)))
     559             :                             ;; Skip common keys at the beginning of key lists.
     560           0 :                             (while (and a-key b-key (equal a-key b-key))
     561           0 :                               (setq a-keys (cdr a-keys) a-key (car a-keys)
     562           0 :                                     b-keys (cdr b-keys) b-key (car b-keys)))
     563           0 :                             (cond
     564           0 :                              ((and (numberp a-key) (numberp b-key))
     565           0 :                               (< a-key b-key))
     566           0 :                              ((and (stringp a-key) (stringp b-key))
     567           0 :                               (string< a-key b-key)))))))))
     568           0 :     (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color))
     569             :       ;; Don't show more than what the display can handle.
     570           0 :       (let ((lc (nthcdr (1- (display-color-cells)) list)))
     571           0 :         (if lc
     572           0 :             (setcdr lc nil)))))
     573           0 :   (unless buffer-name
     574           0 :     (setq buffer-name "*Colors*"))
     575           0 :   (with-help-window buffer-name
     576           0 :     (with-current-buffer standard-output
     577           0 :       (erase-buffer)
     578           0 :       (list-colors-print list callback)
     579           0 :       (set-buffer-modified-p nil)
     580           0 :       (setq truncate-lines t)
     581           0 :       (setq-local list-colors-callback callback)
     582           0 :       (setq revert-buffer-function 'list-colors-redisplay)))
     583           0 :   (when callback
     584           0 :     (pop-to-buffer buffer-name)
     585           0 :     (message "Click on a color to select it.")))
     586             : 
     587             : (defun list-colors-print (list &optional callback)
     588           0 :   (let ((callback-fn
     589           0 :          (if callback
     590           0 :              `(lambda (button)
     591           0 :                 (funcall ,callback (button-get button 'color-name))))))
     592           0 :     (dolist (color list)
     593           0 :       (if (consp color)
     594           0 :           (if (cdr color)
     595           0 :               (setq color (sort color (lambda (a b)
     596           0 :                                         (string< (downcase a)
     597           0 :                                                  (downcase b))))))
     598           0 :         (setq color (list color)))
     599           0 :       (let* ((opoint (point))
     600           0 :              (color-values (color-values (car color)))
     601           0 :              (light-p (>= (apply 'max color-values)
     602           0 :                           (* (car (color-values "white")) .5))))
     603           0 :         (insert (car color))
     604           0 :         (indent-to 22)
     605           0 :         (put-text-property opoint (point) 'face `(:background ,(car color)))
     606           0 :         (put-text-property
     607           0 :          (prog1 (point)
     608           0 :            (insert " ")
     609             :            ;; Insert all color names.
     610           0 :            (insert (mapconcat 'identity color ",")))
     611           0 :          (point)
     612           0 :          'face (list :foreground (car color)))
     613           0 :         (insert (propertize " " 'display '(space :align-to (- right 9))))
     614           0 :         (insert " ")
     615           0 :         (insert (propertize
     616           0 :                  (apply 'format "#%02x%02x%02x"
     617           0 :                         (mapcar (lambda (c) (lsh c -8))
     618           0 :                                 color-values))
     619             :                  'mouse-face 'highlight
     620             :                  'help-echo
     621           0 :                  (let ((hsv (apply 'color-rgb-to-hsv
     622           0 :                                    (color-name-to-rgb (car color)))))
     623           0 :                    (format "H:%.2f S:%.2f V:%.2f"
     624           0 :                            (nth 0 hsv) (nth 1 hsv) (nth 2 hsv)))))
     625           0 :         (when callback
     626           0 :           (make-text-button
     627           0 :            opoint (point)
     628             :            'follow-link t
     629           0 :            'mouse-face (list :background (car color)
     630           0 :                              :foreground (if light-p "black" "white"))
     631           0 :            'color-name (car color)
     632           0 :            'action callback-fn)))
     633           0 :       (insert "\n"))
     634           0 :     (goto-char (point-min))))
     635             : 
     636             : 
     637             : (defun list-colors-duplicates (&optional list)
     638             :   "Return a list of colors with grouped duplicate colors.
     639             : If a color has no duplicates, then the element of the returned list
     640             : has the form (COLOR-NAME).  The element of the returned list with
     641             : duplicate colors has the form (COLOR-NAME DUPLICATE-COLOR-NAME ...).
     642             : This function uses the predicate `facemenu-color-equal' to compare
     643             : color names.  If the optional argument LIST is non-nil, it should
     644             : be a list of colors to display.  Otherwise, this function uses
     645             : a list of colors that the current display can handle."
     646           0 :   (let* ((list (mapcar 'list (or list (defined-colors))))
     647           0 :          (l list))
     648           0 :     (while (cdr l)
     649           0 :       (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l))))
     650             :                ;; On MS-Windows, there are logical colors that might have
     651             :                ;; the same value but different names and meanings.  For
     652             :                ;; example, `SystemMenuText' (the color w32 uses for the
     653             :                ;; text in menu entries) and `SystemWindowText' (the default
     654             :                ;; color w32 uses for the text in windows and dialogs) may
     655             :                ;; be the same display color and be adjacent in the list.
     656             :                ;; These system colors all have names prefixed with "System",
     657             :                ;; which is hardcoded in w32fns.c (SYSTEM_COLOR_PREFIX).
     658             :                ;; This makes them different to any other color.  Bug#9722
     659           0 :                (not (and (eq system-type 'windows-nt)
     660           0 :                          (string-match-p "^System" (car (car l))))))
     661           0 :           (progn
     662           0 :             (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l))))
     663           0 :             (setcdr l (cdr (cdr l))))
     664           0 :         (setq l (cdr l))))
     665           0 :     list))
     666             : 
     667             : (defun facemenu-color-equal (a b)
     668             :   "Return t if colors A and B are the same color.
     669             : A and B should be strings naming colors.
     670             : This function queries the display system to find out what the color
     671             : names mean.  It returns nil if the colors differ or if it can't
     672             : determine the correct answer."
     673           0 :   (cond ((equal a b) t)
     674           0 :         ((equal (color-values a) (color-values b)))))
     675             : 
     676             : 
     677             : (defvar facemenu-self-insert-data nil)
     678             : 
     679             : (defun facemenu-post-self-insert-function ()
     680           0 :   (when (and (car facemenu-self-insert-data)
     681           0 :              (eq last-command (cdr facemenu-self-insert-data)))
     682           0 :     (put-text-property (1- (point)) (point)
     683           0 :                        'face (car facemenu-self-insert-data))
     684           0 :     (setq facemenu-self-insert-data nil))
     685           0 :   (remove-hook 'post-self-insert-hook 'facemenu-post-self-insert-function))
     686             : 
     687             : (defun facemenu-set-self-insert-face (face)
     688             :   "Arrange for the next self-inserted char to have face `face'."
     689           0 :   (setq facemenu-self-insert-data (cons face this-command))
     690           0 :   (add-hook 'post-self-insert-hook 'facemenu-post-self-insert-function))
     691             : 
     692             : (defun facemenu-add-face (face &optional start end)
     693             :   "Add FACE to text between START and END.
     694             : If START is nil or START to END is empty, add FACE to next typed character
     695             : instead.  For each section of that region that has a different face property,
     696             : FACE will be consed onto it, and other faces that are completely hidden by
     697             : that will be removed from the list.
     698             : If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil,
     699             : they are used to set the face information.
     700             : 
     701             : As a special case, if FACE is `default', then the region is left with NO face
     702             : text property.  Otherwise, selecting the default face would not have any
     703             : effect.  See `facemenu-remove-face-function'."
     704             :   (interactive "*xFace: \nr")
     705           0 :   (cond
     706           0 :    ((and (eq face 'default)
     707           0 :          (not (eq facemenu-remove-face-function t)))
     708           0 :     (if facemenu-remove-face-function
     709           0 :         (funcall facemenu-remove-face-function start end)
     710           0 :       (if (and start (< start end))
     711           0 :           (remove-text-properties start end '(face default))
     712           0 :         (facemenu-set-self-insert-face 'default))))
     713           0 :    (facemenu-add-face-function
     714           0 :     (save-excursion
     715           0 :       (if end (goto-char end))
     716           0 :       (save-excursion
     717           0 :         (if start (goto-char start))
     718           0 :         (insert-before-markers
     719           0 :          (funcall facemenu-add-face-function face end)))
     720           0 :       (if facemenu-end-add-face
     721           0 :           (insert (if (stringp facemenu-end-add-face)
     722           0 :                       facemenu-end-add-face
     723           0 :                     (funcall facemenu-end-add-face face))))))
     724           0 :    ((and start (< start end))
     725           0 :     (let ((part-start start) part-end)
     726           0 :       (while (not (= part-start end))
     727           0 :         (setq part-end (next-single-property-change part-start 'face
     728           0 :                                                     nil end))
     729           0 :         (let ((prev (get-text-property part-start 'face)))
     730           0 :           (put-text-property part-start part-end 'face
     731           0 :                              (if (null prev)
     732           0 :                                  face
     733           0 :                                (facemenu-active-faces
     734           0 :                                 (cons face
     735           0 :                                       (if (face-list-p prev)
     736           0 :                                           prev
     737           0 :                                         (list prev)))
     738             :                                 ;; Specify the selected frame
     739             :                                 ;; because nil would mean to use
     740             :                                 ;; the new-frame default settings,
     741             :                                 ;; and those are usually nil.
     742           0 :                                 (selected-frame)))))
     743           0 :         (setq part-start part-end))))
     744             :    (t
     745           0 :     (facemenu-set-self-insert-face
     746           0 :      (if (eq last-command (cdr facemenu-self-insert-data))
     747           0 :          (cons face (if (listp (car facemenu-self-insert-data))
     748           0 :                         (car facemenu-self-insert-data)
     749           0 :                       (list (car facemenu-self-insert-data))))
     750           0 :        face))))
     751           0 :   (unless (facemenu-enable-faces-p)
     752           0 :     (message "Font-lock mode will override any faces you set in this buffer")))
     753             : 
     754             : (defun facemenu-active-faces (face-list &optional frame)
     755             :   "Return from FACE-LIST those faces that would be used for display.
     756             : This means each face attribute is not specified in a face earlier in FACE-LIST
     757             : and such a face is therefore active when used to display text.
     758             : If the optional argument FRAME is given, use the faces in that frame; otherwise
     759             : use the selected frame.  If t, then the global, non-frame faces are used."
     760           0 :   (let* ((mask-atts (copy-sequence
     761           0 :                      (if (consp (car face-list))
     762           0 :                          (face-attributes-as-vector (car face-list))
     763           0 :                        (or (internal-lisp-face-p (car face-list) frame)
     764           0 :                            (check-face (car face-list))))))
     765           0 :          (active-list (list (car face-list)))
     766           0 :          (face-list (cdr face-list))
     767           0 :          (mask-len (length mask-atts)))
     768           0 :     (while face-list
     769           0 :       (if (let ((face-atts
     770           0 :                  (if (consp (car face-list))
     771           0 :                      (face-attributes-as-vector (car face-list))
     772           0 :                    (or (internal-lisp-face-p (car face-list) frame)
     773           0 :                        (check-face (car face-list)))))
     774           0 :                 (i mask-len)
     775             :                 (useful nil))
     776           0 :             (while (>= (setq i (1- i)) 0)
     777           0 :               (and (not (memq (aref face-atts i) '(nil unspecified)))
     778           0 :                    (memq (aref mask-atts i) '(nil unspecified))
     779           0 :                    (aset mask-atts i (setq useful t))))
     780           0 :             useful)
     781           0 :           (setq active-list (cons (car face-list) active-list)))
     782           0 :       (setq face-list (cdr face-list)))
     783           0 :     (nreverse active-list)))
     784             : 
     785             : (defun facemenu-add-new-face (face)
     786             :   "Add FACE (a face) to the Face menu if `facemenu-listed-faces' says so.
     787             : This is called whenever you create a new face, and at other times."
     788           7 :   (let* (name
     789             :          symbol
     790             :          menu docstring
     791           7 :          (key (cdr (assoc face facemenu-keybindings)))
     792             :          function menu-val)
     793           7 :     (if (symbolp face)
     794           7 :         (setq name (symbol-name face)
     795           7 :               symbol face)
     796           0 :       (setq name face
     797           7 :             symbol (intern name)))
     798           7 :     (setq menu 'facemenu-face-menu)
     799           7 :     (setq docstring
     800           7 :           (purecopy (format "Select face `%s' for subsequent insertion.
     801             : If the mark is active and there is no prefix argument,
     802             : apply face `%s' to the region instead.
     803             : This command was defined by `facemenu-add-new-face'."
     804           7 :                   name name)))
     805           7 :     (cond ((facemenu-iterate ; check if equivalent face is already in the menu
     806          49 :             (lambda (m) (and (listp m)
     807          42 :                              (symbolp (car m))
     808             :                              ;; Avoid error in face-equal
     809             :                              ;; when a non-face is erroneously present.
     810           0 :                              (facep (car m))
     811          49 :                              (face-equal (car m) symbol)))
     812           7 :             (cdr (symbol-function menu))))
     813             :           ;; Faces with a keyboard equivalent.  These go at the front.
     814           7 :           (key
     815           5 :            (setq function (intern (concat "facemenu-set-" name)))
     816           5 :            (fset function
     817           5 :                  `(lambda ()
     818           5 :                     ,docstring
     819             :                     (interactive)
     820             :                     (facemenu-set-face
     821           5 :                      (quote ,symbol)
     822             :                      (if (and mark-active (not current-prefix-arg))
     823             :                          (region-beginning))
     824             :                      (if (and mark-active (not current-prefix-arg))
     825           5 :                          (region-end)))))
     826           5 :            (define-key 'facemenu-keymap key (cons name function))
     827           5 :            (define-key menu key (cons name function)))
     828             :           ;; Faces with no keyboard equivalent.  Figure out where to put it:
     829           2 :           ((or (eq t facemenu-listed-faces)
     830           2 :                (memq symbol facemenu-listed-faces))
     831           0 :            (setq key (vector symbol)
     832             :                  function 'facemenu-set-face-from-menu
     833           0 :                  menu-val (symbol-function menu))
     834           0 :            (if (and facemenu-new-faces-at-end
     835           0 :                     (> (length menu-val) 3))
     836           0 :                (define-key-after menu-val key (cons name function)
     837           0 :                  (car (nth (- (length menu-val) 3) menu-val)))
     838           7 :              (define-key menu key (cons name function))))))
     839             :   nil) ; Return nil for facemenu-iterate
     840             : 
     841             : (defun facemenu-add-new-color (color menu)
     842             :   "Add COLOR (a color name string) to the appropriate Face menu.
     843             : MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'.
     844             : Return the event type (a symbol) of the added menu entry.
     845             : 
     846             : This is called whenever you use a new color."
     847           0 :   (let (symbol)
     848           0 :     (unless (color-defined-p color)
     849           0 :       (error "Color `%s' undefined" color))
     850           0 :     (cond ((eq menu 'facemenu-foreground-menu)
     851           0 :            (setq symbol (intern (concat "fg:" color))))
     852           0 :           ((eq menu 'facemenu-background-menu)
     853           0 :            (setq symbol (intern (concat "bg:" color))))
     854           0 :           (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'")))
     855           0 :     (unless (facemenu-iterate ; Check if color is already in the menu.
     856           0 :              (lambda (m) (and (listp m)
     857           0 :                               (eq (car m) symbol)))
     858           0 :              (cdr (symbol-function menu)))
     859             :       ;; Color is not in the menu.  Figure out where to put it.
     860           0 :       (let ((key (vector symbol))
     861             :             (function 'facemenu-set-face-from-menu)
     862           0 :             (menu-val (symbol-function menu)))
     863           0 :         (if (and facemenu-new-faces-at-end
     864           0 :                  (> (length menu-val) 3))
     865           0 :             (define-key-after menu-val key (cons color function)
     866           0 :               (car (nth (- (length menu-val) 3) menu-val)))
     867           0 :           (define-key menu key (cons color function)))))
     868           0 :     symbol))
     869             : 
     870             : (defun facemenu-complete-face-list (&optional oldlist)
     871             :   "Return list of all faces that look different.
     872             : Starts with given ALIST of faces, and adds elements only if they display
     873             : differently from any face already on the list.
     874             : The faces on ALIST will end up at the end of the returned list, in reverse
     875             : order."
     876           1 :   (let ((list (nreverse (mapcar 'car oldlist))))
     877           1 :     (facemenu-iterate
     878             :      (lambda (new-face)
     879         128 :        (if (not (memq new-face list))
     880         128 :            (setq list (cons new-face list)))
     881             :        nil)
     882           1 :      (nreverse (face-list)))
     883           1 :     list))
     884             : 
     885             : (defun facemenu-iterate (func list)
     886             :   "Apply FUNC to each element of LIST until one returns non-nil.
     887             : Returns the non-nil value it found, or nil if all were nil."
     888         191 :   (while (and list (not (funcall func (car list))))
     889         182 :     (setq list (cdr list)))
     890           9 :   (car list))
     891             : 
     892             : (facemenu-update)
     893             : 
     894             : (provide 'facemenu)
     895             : 
     896             : ;;; facemenu.el ends here

Generated by: LCOV version 1.12