X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/2b0c7330457b8ca42375c92ada7dc7cefb0fa9fb..cd99601878e97578ecd8e2209feeda275a3a13f5:/lisp/facemenu.el diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 97862afb67..88b9ddc7f5 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -1,6 +1,6 @@ ;;; facemenu.el --- create a face menu for interactively adding fonts to text -;; Copyright (C) 1994-1996, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1994-1996, 2001-2012 Free Software Foundation, Inc. ;; Author: Boris Goldowsky ;; Keywords: faces @@ -127,15 +127,6 @@ just before \"Other\" at the end." :type 'boolean :group 'facemenu) -(defvar facemenu-unlisted-faces - `(modeline region secondary-selection highlight scratch-face - ,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-") - ,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-") - ,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-")) - "*List of faces that are of no interest to the user.") -(make-obsolete-variable 'facemenu-unlisted-faces 'facemenu-listed-faces - "22.1,\n and has no effect on the Face menu") - (defcustom facemenu-listed-faces nil "List of faces to include in the Face menu. Each element should be a symbol, the name of a face. @@ -241,10 +232,12 @@ it will remove any faces not explicitly in the list." (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display)) (define-key map [dp] (cons (purecopy "Describe Properties") 'describe-text-properties)) - (define-key map [ra] (cons (purecopy "Remove Text Properties") - 'facemenu-remove-all)) - (define-key map [rm] (cons (purecopy "Remove Face Properties") - 'facemenu-remove-face-props)) + (define-key map [ra] (list 'menu-item (purecopy "Remove Text Properties") + 'facemenu-remove-all + :enable 'mark-active)) + (define-key map [rm] (list 'menu-item (purecopy "Remove Face Properties") + 'facemenu-remove-face-props + :enable 'mark-active)) (define-key map [s1] (list (purecopy "--")))) (let ((map facemenu-menu)) (define-key map [in] (cons (purecopy "Indentation") @@ -471,7 +464,8 @@ These special properties include `invisible', `intangible' and `read-only'." `(rgb-dist . COLOR)' sorts by the RGB distance to the specified color. `hsv' sorts by hue, saturation, value. `(hsv-dist . COLOR)' sorts by the HSV distance to the specified color -and excludes grayscale colors." +and excludes grayscale colors. +`luminance' sorts by relative luminance in the CIE XYZ color space." :type '(choice (const :tag "Unsorted" nil) (const :tag "Color Name" name) (const :tag "Red-Green-Blue" rgb) @@ -481,7 +475,8 @@ and excludes grayscale colors." (const :tag "Hue-Saturation-Value" hsv) (cons :tag "Distance on HSV cylinder" (const :tag "Distance from Color" hsv-dist) - (color :tag "Source Color Name"))) + (color :tag "Source Color Name")) + (const :tag "Luminance" luminance)) :group 'facemenu :version "24.1") @@ -511,23 +506,25 @@ filter out the color from the output." (+ (expt (- 180 (abs (- 180 (abs (- (nth 0 c-hsv) ; wrap hue (nth 0 o-hsv)))))) 2) (expt (- (nth 1 c-hsv) (nth 1 o-hsv)) 2) - (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2))))))) + (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2))))) + ((eq list-colors-sort 'luminance) + (let ((c-rgb (color-name-to-rgb color))) + (+ (* (nth 0 c-rgb) 0.21266729) + (* (nth 1 c-rgb) 0.7151522) + (* (nth 2 c-rgb) 0.0721750)))))) (defun list-colors-display (&optional list buffer-name callback) "Display names of defined colors, and show what they look like. If the optional argument LIST is non-nil, it should be a list of colors to display. Otherwise, this command computes a list of -colors that the current display can handle. +colors that the current display can handle. Customize +`list-colors-sort' to change the order in which colors are shown. -If the optional argument BUFFER-NAME is nil, it defaults to -*Colors*. +If the optional argument BUFFER-NAME is nil, it defaults to *Colors*. If the optional argument CALLBACK is non-nil, it should be a function to call each time the user types RET or clicks on a -color. The function should accept a single argument, the color -name. - -You can change the color sort order by customizing `list-colors-sort'." +color. The function should accept a single argument, the color name." (interactive) (when (and (null list) (> (display-color-cells) 0)) (setq list (list-colors-duplicates (defined-colors))) @@ -567,18 +564,12 @@ You can change the color sort order by customizing `list-colors-sort'." (with-help-window buffer-name (with-current-buffer standard-output (erase-buffer) + (list-colors-print list callback) + (set-buffer-modified-p nil) (setq truncate-lines t))) - (let ((buf (get-buffer buffer-name)) - (inhibit-read-only t)) - ;; Display buffer before generating content, to allow - ;; `list-colors-print' to get the right window-width. - (with-selected-window (or (get-buffer-window buf t) (selected-window)) - (with-current-buffer buf - (list-colors-print list callback) - (set-buffer-modified-p nil))) - (when callback - (pop-to-buffer buf) - (message "Click on a color to select it.")))) + (when callback + (pop-to-buffer buffer-name) + (message "Click on a color to select it."))) (defun list-colors-print (list &optional callback) (let ((callback-fn @@ -595,30 +586,19 @@ You can change the color sort order by customizing `list-colors-sort'." (let* ((opoint (point)) (color-values (color-values (car color))) (light-p (>= (apply 'max color-values) - (* (car (color-values "white")) .5))) - (max-len (max (- (window-width) 33) 20))) + (* (car (color-values "white")) .5)))) (insert (car color)) (indent-to 22) (put-text-property opoint (point) 'face `(:background ,(car color))) (put-text-property (prog1 (point) (insert " ") - (if (cdr color) - ;; Insert as many color names as possible, fitting max-len. - (let ((names (list (car color))) - (others (cdr color)) - (len (length (car color))) - newlen) - (while (and others - (< (setq newlen (+ len 2 (length (car others)))) - max-len)) - (setq len newlen) - (push (pop others) names)) - (insert (mapconcat 'identity (nreverse names) ", "))) - (insert (car color)))) + ;; Insert all color names. + (insert (mapconcat 'identity color ","))) (point) 'face (list :foreground (car color))) - (indent-to (max (- (window-width) 8) 44)) + (insert (propertize " " 'display '(space :align-to (- right 9)))) + (insert " ") (insert (propertize (apply 'format "#%02x%02x%02x" (mapcar (lambda (c) (lsh c -8)) @@ -654,8 +634,17 @@ a list of colors that the current display can handle." (l list)) (while (cdr l) (if (and (facemenu-color-equal (car (car l)) (car (car (cdr l)))) - (not (if (fboundp 'w32-default-color-map) - (not (assoc (car (car l)) (w32-default-color-map)))))) + ;; On MS-Windows, there are logical colors that might have + ;; the same value but different names and meanings. For + ;; example, `SystemMenuText' (the color w32 uses for the + ;; text in menu entries) and `SystemWindowText' (the default + ;; color w32 uses for the text in windows and dialogs) may + ;; be the same display color and be adjacent in the list. + ;; These system colors all have names prefixed with "System", + ;; which is hardcoded in w32fns.c (SYSTEM_COLOR_PREFIX). + ;; This makes them different to any other color. Bug#9722 + (not (and (eq system-type 'windows-nt) + (string-match-p "^System" (car (car l)))))) (progn (setcdr (car l) (cons (car (car (cdr l))) (cdr (car l)))) (setcdr l (cdr (cdr l)))) @@ -842,19 +831,13 @@ MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'. Return the event type (a symbol) of the added menu entry. This is called whenever you use a new color." - (let (symbol docstring) + (let (symbol) (unless (color-defined-p color) (error "Color `%s' undefined" color)) (cond ((eq menu 'facemenu-foreground-menu) - (setq docstring - (format "Select foreground color %s for subsequent insertion." - color) - symbol (intern (concat "fg:" color)))) + (setq symbol (intern (concat "fg:" color)))) ((eq menu 'facemenu-background-menu) - (setq docstring - (format "Select background color %s for subsequent insertion." - color) - symbol (intern (concat "bg:" color)))) + (setq symbol (intern (concat "bg:" color)))) (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'"))) (unless (facemenu-iterate ; Check if color is already in the menu. (lambda (m) (and (listp m)