Download
(require 'facemenu)
(require 'doremi-frm nil t)
(require 'hexrgb nil t)
(if (fboundp 'defvaralias)
(or (require 'palette nil t) (require 'eyedropper))
(require 'eyedropper))
(require 'easymenu)
(when (> emacs-major-version 21) (require 'help-mode))
(when (< emacs-major-version 21) (require 'faces+ nil t))
(when (> emacs-major-version 22) (require 'help-fns+ nil t))
(defvar facemenu-self-insert-data)
(defvar palette-action)
(defcustom facemenup-palette-update-while-editing-flag t
"*Non-nil means update the face whose color you're editing in the palette.
The face is updated automatically each time you change the palette's
current color, which is typically when you hit `RET' or click
`mouse-2'. If nil, then the face is updated only when you exit the
palette using `x'."
:type 'boolean :group 'facemenu)
(defconst facemenup-err-mouse "No defined face under mouse pointer. Face to change"
"Error message for no defined face under mouse pointer.")
(defconst facemenup-err-point "No defined face at cursor (point). Face to change"
"Error message for no defined face under mouse pointer.")
(defvar facemenup-last-face-changed nil "Last face changed using the face menu.")
(defvar facemenup-last-face-bg nil
"Background of last face changed using face menu, before the change.")
(defvar facemenup-last-face-fg nil
"Foreground of last face changed using face menu, before the change.")
(when (or (featurep 'font-lock-menus) (featurep 'font-menus))
(define-key-after facemenu-menu [display-fonts] '("Display Fonts" . display-fonts) 'dc))
(when (or (featurep 'font-lock-menus) (featurep 'font-menus))
(easy-menu-add-item facemenu-menu () (easy-menu-create-menu
"Syntax Highlighting (Font Lock)"
'(["In All Buffers" global-font-lock-mode
:style toggle :selected global-font-lock-mode
:active t]
["In Current Buffer" font-lock-mode
:style toggle :selected font-lock-mode :active t]
"--"
["More In Current Buffer" font-lock-fontify-more
(nth 2 (if (boundp 'flm-font-lock-fontify-level)
flm-font-lock-fontify-level
font-lock-fontify-level))]
["Less In Current Buffer" font-lock-fontify-less
(nth 1 (if (boundp 'flm-font-lock-fontify-level)
flm-font-lock-fontify-level
font-lock-fontify-level))]
))
"Syntax Highlighting (Font Lock)"))
(defconst facemenup-highlight-menu
(easy-menu-create-menu
"Highlight"
(append
'(["Highlight Region/Buffer" hlt-highlight-region t]
["Highlight Regexp in Region/Buffer..." hlt-highlight-regexp-region t]
["Highlight Regexp to End" hlt-highlight-regexp-to-end t]
["Unhighlight Region/Buffer" hlt-unhighlight-region t]
["Unhighlight Region/Buffer for Face" hlt-unhighlight-region-for-face t]
"--"
["Copy Text Properties" hlt-copy-props t]
["Paste Text Properties to Region" hlt-yank-props
(and mark-active (not buffer-read-only))]
"--"
["Highlighter Pen" hlt-highlighter-mouse t]
["Eraser" hlt-eraser-mouse t])
(and (fboundp 'hlt-show-only)
'("--"
["Hide Only Faces..." hlt-hide-only t]
["Show Only Faces..." hlt-show-only t]
["Show Faces..." hlt-show t]
["Hide Faces..." hlt-hide t]
"--"))
'(["Choose Highlighting Face" hlt-choose-default-face t]
["Replace Highlighting Face in Region/Buffer" hlt-replace-highlight-face t]
["Toggle Using Overlays for Highlighting" hlt-toggle-use-overlays-flag t])
(and (fboundp 'hlt-toggle-act-on-any-face-flag)
'(["Toggle Highlighting Arbritrary Faces" hlt-toggle-act-on-any-face-flag t]))
(and (fboundp 'hlt-next-highlight)
'("--"
["Go To Next Highlight" hlt-next-highlight t]
["Go To Previous Highlight" hlt-previous-highlight t]))))
"Highlight submenu of Text Properties menu.")
(unless (fboundp 'copy-tree)
(defun facemenup-copy-tree (tree &optional vecp)
"Make a copy of TREE.
If TREE is a cons cell, this recursively copies both its car and its cdr.
Contrast to `copy-sequence', which copies only along the cdrs. With second
argument VECP, this copies vectors as well as conses."
(if (consp tree)
(let (result)
(while (consp tree)
(let ((newcar (car tree)))
(if (or (consp (car tree)) (and vecp (vectorp (car tree))))
(setq newcar (facemenup-copy-tree (car tree) vecp)))
(push newcar result))
(setq tree (cdr tree)))
(nconc (nreverse result) tree))
(if (and vecp (vectorp tree))
(let ((i (length (setq tree (copy-sequence tree)))))
(while (>= (setq i (1- i)) 0)
(aset tree i (facemenup-copy-tree (aref tree i) vecp)))
tree)
tree))))
(defvar facemenu-mouse-menu (if (fboundp 'copy-tree)
(copy-tree facemenu-menu)
(facemenup-copy-tree facemenu-menu))
"Facemenu top-level popup mouse menu keymap.")
(defalias 'facemenu-mouse-menu facemenu-mouse-menu)
(define-key global-map [C-down-mouse-2] 'facemenu-mouse-menu)
(define-key facemenu-mouse-menu [dp]
(cons (purecopy "Describe Properties") 'facemenup-describe-text-properties-at-mouse))
(unless (fboundp 'describe-text-properties)
(define-key facemenu-menu [dp] '(menu-item "Describe Properties" list-text-properties-at)))
(when (boundp 'menu-bar-edit-region-menu)
(define-key menu-bar-edit-region-menu [ra]
'(menu-item "Remove Text Properties" facemenu-remove-all))
(define-key facemenu-menu [rm]
'(menu-item "Remove Face Properties" facemenu-remove-face-props)))
(define-key facemenu-menu [ra]
'(menu-item "Remove Text Properties from Region" facemenu-remove-all :enable mark-active))
(define-key facemenu-menu [rm]
'(menu-item "Remove Face Properties from Region" facemenu-remove-face-props :enable mark-active))
(define-key facemenu-mouse-menu [ra]
'(menu-item "Remove Text Properties from Region" facemenu-remove-all :enable mark-active))
(define-key facemenu-mouse-menu [rm]
'(menu-item "Remove Face Properties from Region" facemenu-remove-face-props :enable mark-active))
(easy-menu-add-item facemenu-mouse-menu () ["---" nil] 'dp)
(easy-menu-add-item facemenu-menu () ["---" nil] 'dp)
(when (fboundp 'hlt-highlight)
(easy-menu-add-item facemenu-mouse-menu () facemenup-highlight-menu "Special Properties"))
(when (fboundp 'palette)
(easy-menu-add-item facemenu-mouse-menu () "--")
(easy-menu-add-item facemenu-mouse-menu () ["Color Palette" palette t])
(easy-menu-add-item facemenu-mouse-menu () ["Palette - Edit Face Foreground"
facemenup-palette-face-fg-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu () ["Palette - Edit Face Background"
facemenup-palette-face-bg-at-mouse t]))
(easy-menu-add-item facemenu-mouse-menu () "--")
(cond ((fboundp 'palette)
(easy-menu-add-item facemenu-mouse-menu ()
["Eyedropper - Copy Foreground (C-u: Palette)"
eyedrop-pick-foreground-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu ()
["Eyedropper - Copy Background (C-u: Palette)"
eyedrop-pick-background-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu ()
["Eyedropper - Paste to Face Foreground"
facemenup-paste-to-face-fg-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu ()
["Eyedropper - Paste to Face Background"
facemenup-paste-to-face-bg-at-mouse t]))
(t
(easy-menu-add-item facemenu-mouse-menu ()
["Eyedropper - Copy Foreground (C-u: Palette)"
eyedrop-pick-foreground-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu ()
["Eyedropper - Copy Background (C-u: Palette)"
eyedrop-pick-background-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu ()
["Eyedropper - Paste to Face Foreground"
facemenup-paste-to-face-fg-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu ()
["Eyedropper - Paste to Face Background"
facemenup-paste-to-face-bg-at-mouse t])))
(when (fboundp 'doremi-face-fg+)
(easy-menu-add-item facemenu-mouse-menu () "--")
(easy-menu-add-item facemenu-mouse-menu () ["Do Re Mi - Edit Face Foreground"
facemenup-change-fg-of-face-at-mouse+ t])
(easy-menu-add-item facemenu-mouse-menu () ["Do Re Mi - Edit Face Background"
facemenup-change-bg-of-face-at-mouse+ t])
(easy-menu-add-item facemenu-mouse-menu () ["Do Re Mi - Undo Last Edit"
doremi-undo-last-face-change t]))
(easy-menu-add-item facemenu-mouse-menu () "--")
(easy-menu-add-item facemenu-mouse-menu () ["Set Face Foreground RGB"
facemenup-set-face-fg-RGB-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu () ["Set Face Background RGB"
facemenup-set-face-bg-RGB-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu () ["Set Face Foreground RGB (Hex)"
facemenup-set-face-fg-RGB-hex-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu () ["Set Face Background RGB (Hex)"
facemenup-set-face-bg-RGB-hex-at-mouse t])
(easy-menu-add-item facemenu-mouse-menu () ["Restore Last Foreground (Except Do Re Mi)"
facemenup-face-fg-restore t])
(easy-menu-add-item facemenu-mouse-menu () ["Restore Last Background (Except Do Re Mi)"
facemenup-face-bg-restore t])
(easy-menu-add-item facemenu-mouse-menu () "--")
(when (fboundp 'set-face-attribute)
(easy-menu-add-item facemenu-mouse-menu () ["Set Face Attribute"
facemenup-set-face-attribute-at-mouse t]))
(easy-menu-add-item facemenu-mouse-menu ()
["Customize Face" facemenup-customize-face-at-mouse t])
(defun facemenup-help (event)
"Open the Emacs manual to help about formatted text."
(interactive "e") (info "(emacs)Editing Format Info"))
(easy-menu-add-item facemenu-mouse-menu () "--")
(easy-menu-add-item facemenu-mouse-menu () ["Help" facemenup-help t])
(when (fboundp 'hlt-highlight)
(easy-menu-add-item facemenu-menu () facemenup-highlight-menu "Special Properties"))
(when (fboundp 'palette)
(easy-menu-add-item facemenu-menu () "--")
(easy-menu-add-item facemenu-menu () ["Color Palette" palette t])
(easy-menu-add-item facemenu-menu () ["Palette - Edit Face Foreground"
facemenup-palette-face-fg-at-point t])
(easy-menu-add-item facemenu-menu () ["Palette - Edit Face Background"
facemenup-palette-face-bg-at-point t]))
(when (fboundp 'doremi-face-fg+)
(easy-menu-add-item facemenu-menu () "--")
(easy-menu-add-item facemenu-menu () ["Do Re Mi - Edit Face Foreground"
facemenup-change-fg-of-face-at-point+ t])
(easy-menu-add-item facemenu-menu () ["Do Re Mi - Edit Face Background"
facemenup-change-bg-of-face-at-point+ t])
(easy-menu-add-item facemenu-menu () ["Do Re Mi - Undo Last Edit"
doremi-undo-last-face-change t]))
(easy-menu-add-item facemenu-menu () "--")
(easy-menu-add-item facemenu-menu () ["Eyedropper Copy Foreground Color"
eyedrop-pick-foreground-at-point t])
(easy-menu-add-item facemenu-menu () ["Eyedropper Copy Background Color"
eyedrop-pick-background-at-point t])
(easy-menu-add-item facemenu-menu () ["Eyedropper Paste to Face Foreground"
facemenup-paste-to-face-fg-at-point t])
(easy-menu-add-item facemenu-menu () ["Eyedropper Paste to Face Background"
facemenup-paste-to-face-bg-at-point t])
(easy-menu-add-item facemenu-menu () ["Set Face Foreground RGB"
facemenup-set-face-fg-RGB-at-point t])
(easy-menu-add-item facemenu-menu () ["Set Face Background RGB"
facemenup-set-face-bg-RGB-at-point t])
(easy-menu-add-item facemenu-menu () ["Set Face Foreground RGB (Hex)"
facemenup-set-face-fg-RGB-hex-at-point t])
(easy-menu-add-item facemenu-menu () ["Set Face Background RGB (Hex)"
facemenup-set-face-bg-RGB-hex-at-point t])
(easy-menu-add-item facemenu-menu () ["Restore Last Foreground (Except Do Re Mi)"
facemenup-face-fg-restore t])
(easy-menu-add-item facemenu-menu () ["Restore Last Background (Except Do Re Mi)"
facemenup-face-bg-restore t])
(easy-menu-add-item facemenu-menu () "--")
(when (fboundp 'set-face-attribute)
(easy-menu-add-item facemenu-menu () ["Set Face Attribute"
facemenup-set-face-attribute-at-point t]))
(easy-menu-add-item facemenu-menu ()
["Customize Face" facemenup-customize-face-at-point t])
(easy-menu-add-item facemenu-menu () "--")
(easy-menu-add-item facemenu-menu () ["Help" facemenup-help t])
(facemenu-update)
(defun facemenup-describe-text-properties-at-mouse (event)
"Describe text properties of character under the mouse pointer."
(interactive "e")
(while (input-pending-p) (discard-input))
(save-excursion
(set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(if (fboundp 'describe-text-properties)
(describe-text-properties (point))
(list-text-properties-at (point)))))
(defun facemenup-face-bg-restore ()
"Restore background of last face changed by face menu to last color.
This is not an undo: It always restores the previous color as
the background of the last face changed.
This does not work for face changes made by Do Re Mi."
(interactive)
(unless (stringp facemenup-last-face-bg) (error "No previous face background"))
(unless (facep facemenup-last-face-changed) (error "No face change to restore"))
(set-face-background facemenup-last-face-changed facemenup-last-face-bg)
(when (interactive-p)
(message "Background of `%s' restored to `%s'"
facemenup-last-face-changed facemenup-last-face-bg)))
(defun facemenup-face-fg-restore ()
"Restore foreground of last face changed by face menu to last color.
This is not an undo: It always restores the previous color as
the foreground of the last face changed.
This does not work for face changes made by Do Re Mi."
(interactive)
(unless (stringp facemenup-last-face-fg) (error "No previous face foreground"))
(unless (facep facemenup-last-face-changed) (error "No face change to restore"))
(set-face-foreground facemenup-last-face-changed facemenup-last-face-fg)
(when (interactive-p)
(message "Foreground of `%s' restored to `%s'"
facemenup-last-face-changed facemenup-last-face-fg)))
(when (fboundp 'palette)
(defun facemenup-palette-face-bg-at-mouse (event)
"Use palette to edit background of face under the mouse pointer.
To change this face: edit the color in the palette, then exit the
palette using \\<palette-mode-map>`\\[palette-exit]'.
To quit the palette without effecting any change on the face, use `\\[palette-quit]'.
To restore the face color after you have changed it, use
`\\[facemenup-face-bg-restore]'.
If option `facemenup-palette-update-while-editing-flag' is non-nil,
then the face is automatically updated each time you change the
palette's current color, which is typically when you hit `RET' or
click `mouse-2'. In this case, quitting the palette with `\\[palette-quit]' will not
undo any face changes you made. Use `\\[facemenup-face-bg-restore]' to restore."
(interactive "e")
(let ((face (save-excursion (set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point))))
(unless face (setq face (read-face-name facemenup-err-mouse)))
(add-hook 'palette-exit-hook `(lambda () (set-face-background ',face palette-current-color)))
(let ((bg (facemenup-face-bg face)))
(setq facemenup-last-face-bg bg
facemenup-last-face-changed face)
(when facemenup-palette-update-while-editing-flag
(setq palette-action `(lambda () (set-face-background ',face palette-current-color))))
(palette bg)))))
(when (fboundp 'palette)
(defun facemenup-palette-face-fg-at-mouse (event)
"Use palette to edit foreground of face under the mouse pointer.
To change this face: edit the color in the palette, then exit the
palette using `\\[palette-exit]'.
To quit the palette without effecting any change on the face, use `\\[palette-quit]'.
To restore the face color after you have changed it, use
`\\[facemenup-face-fg-restore]'.
If option `facemenup-palette-update-while-editing-flag' is non-nil,
then the face is automatically updated each time you change the
palette's current color, which is typically when you hit `RET' or
click `mouse-2'. In this case, quitting the palette with `\\[palette-quit]' will not
undo any face changes you made. Use `\\[facemenup-face-fg-restore]' to restore."
(interactive "e")
(let ((face (save-excursion (set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point))))
(unless face (setq face (read-face-name facemenup-err-mouse)))
(add-hook 'palette-exit-hook `(lambda () (set-face-foreground ',face palette-current-color)))
(let ((fg (facemenup-face-fg face)))
(setq facemenup-last-face-fg fg
facemenup-last-face-changed face)
(when facemenup-palette-update-while-editing-flag
(setq palette-action `(lambda () (set-face-foreground ',face palette-current-color))))
(condition-case nil
(palette fg)
(quit (set-face-foreground face fg)))))))
(when (fboundp 'palette)
(defun facemenup-palette-face-bg-at-point ()
"Use palette to edit background of face at the cursor (point).
To change this face: edit the color in the palette, then exit the
palette using `\\[palette-exit]'.
To quit the palette without effecting any change on the face, use `\\[palette-quit]'.
To restore the face color after you have changed it, use
`\\[facemenup-face-bg-restore]'.
If option `facemenup-palette-update-while-editing-flag' is non-nil,
then the face is automatically updated each time you change the
palette's current color, which is typically when you hit `RET' or
click `mouse-2'. In this case, quitting the palette with `\\[palette-quit]' will not
undo any face changes you made. Use `\\[facemenup-face-bg-restore]' to restore."
(interactive)
(let ((face (eyedrop-face-at-point)))
(unless face (read-face-name facemenup-err-point))
(add-hook 'palette-exit-hook
`(lambda () (set-face-background ',face palette-current-color)))
(let ((bg (facemenup-face-bg face)))
(setq facemenup-last-face-bg bg
facemenup-last-face-changed face)
(when facemenup-palette-update-while-editing-flag
(setq palette-action `(lambda () (set-face-background ',face palette-current-color))))
(condition-case nil
(palette bg)
(quit (set-face-background face bg)))))))
(when (fboundp 'palette)
(defun facemenup-palette-face-fg-at-point ()
"Use palette to edit foreground of face at the cursor (point).
To change this face: edit the color in the palette, then exit the
palette using `\\[palette-exit]'.
To quit the palette without effecting any change on the face, use `\\[palette-quit]'.
To restore the face color after you have changed it, use
`\\[facemenup-face-fg-restore]'.
If option `facemenup-palette-update-while-editing-flag' is non-nil,
then the face is automatically updated each time you change the
palette's current color, which is typically when you hit `RET' or
click `mouse-2'. In this case, quitting the palette with `\\[palette-quit]' will not
undo any face changes you made. Use `\\[facemenup-face-fg-restore]' to restore."
(interactive)
(let ((face (eyedrop-face-at-point)))
(unless face (read-face-name facemenup-err-point))
(add-hook 'palette-exit-hook
`(lambda () (set-face-foreground ',face palette-current-color)))
(let ((fg (facemenup-face-fg face)))
(setq facemenup-last-face-fg fg
facemenup-last-face-changed face)
(when facemenup-palette-update-while-editing-flag
(setq palette-action `(lambda () (set-face-foreground ',face palette-current-color))))
(condition-case nil
(palette fg)
(quit (set-face-foreground face fg)))))))
(when (fboundp 'doremi-face-bg+)
(defun facemenup-change-bg-of-face-at-mouse+ (event increment)
"Use Do Re Mi to edit background of face under the mouse pointer.
This uses command `doremi-face-bg+'; see that for more usage info.
Prefix argument is the INCREMENT of change.
If `eyedrop-picked-background' is non-nil and you use plain `C-u'
instead of a numeric prefix argument, then the face background is
first set to the value of `eyedrop-picked-background'. This happens
only if library `eyedropper.el' or `palette.el' is loaded. This lets
you pick up a background color from somewhere, using \"Pick Up
Background Color\" (`eyedrop-pick-background-at-mouse'), and then use
that as the initial value for
`facemenup-change-bg-of-face-at-mouse+'."
(interactive "e\np")
(let ((echo-keystrokes 0)
(face (save-excursion
(set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point))))
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (input-pending-p) (discard-input))
(doremi-face-bg+ face
(read-char-exclusive (format "Change background of `%s'. \
Adjust red, green, blue, hue, saturation, or value? [rgbhsv]: " face))
increment (consp current-prefix-arg)))))
(when (fboundp 'doremi-face-fg+)
(defun facemenup-change-fg-of-face-at-mouse+ (event increment)
"Use Do Re Mi to edit foreground of face under the mouse pointer.
This uses command `doremi-face-fg+'; see that for more usage info.
Prefix argument is the INCREMENT of change.
If `eyedrop-picked-foreground' is non-nil and you use plain `C-u'
instead of a numeric prefix argument, then the face foreground is
first set to the value of `eyedrop-picked-foreground'. This
happens only if library `eyedropper.el' or `palette.el' is
loaded. This lets you pick up a foreground color from somewhere,
using \"Pick Up Foreground Color\"
\(`eyedrop-pick-foreground-at-mouse'), and then use that as the
initial value for `facemenup-change-fg-of-face-at-mouse+'."
(interactive "e\np")
(let ((echo-keystrokes 0)
(face (save-excursion
(set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point))))
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (input-pending-p) (discard-input))
(doremi-face-fg+ face
(read-char-exclusive (format "Change foreground of `%s'. \
Adjust red, green, blue, hue, saturation, or value? [rgbhsv]: " face))
increment (consp current-prefix-arg)))))
(when (fboundp 'doremi-face-bg+)
(defun facemenup-change-bg-of-face-at-point+ (increment)
"Use Do Re Mi to edit background of face at the cursor (point).
This uses command `doremi-face-bg+'; see that for more usage info.
Prefix argument is the INCREMENT of change.
If `eyedrop-picked-background' is non-nil and you use plain `C-u'
instead of a numeric prefix argument, then the face background is
first set to the value of `eyedrop-picked-background'. This
happens only if library `eyedropper.el' or `palette.el' is
loaded. This lets you pick up a background color from somewhere,
using \"Pick Up Background Color\"
\(`eyedrop-pick-background-at-point'), and then use that as the
initial value for `facemenup-change-bg-of-face-at-point+'."
(interactive "p")
(let ((echo-keystrokes 0)
(face (eyedrop-face-at-point)))
(unless face (read-face-name facemenup-err-point))
(doremi-face-bg+ face (read-char-exclusive (format "Change background of `%s'. \
Adjust red, green, blue, hue, saturation, or value? [rgbhsv]: " face))
increment (consp current-prefix-arg)))))
(when (fboundp 'doremi-face-fg+)
(defun facemenup-change-fg-of-face-at-point+ (increment)
"Use Do Re Mi to edit foreground of face at the cursor (point).
This uses command `doremi-face-fg+'; see that for more usage info.
Prefix argument is the INCREMENT of change.
If `eyedrop-picked-foreground' is non-nil and you use plain `C-u'
instead of a numeric prefix argument, then the face foreground is
first set to the value of `eyedrop-picked-foreground'. This
happens only if library `eyedropper.el' or `palette.el' is
loaded. This lets you pick up a foreground color from somewhere,
using \"Pick Up Foreground Color\"
\(`eyedrop-pick-foreground-at-point'), and then use that as the
initial value for `facemenup-change-fg-of-face-at-point+'."
(interactive "p")
(let ((echo-keystrokes 0)
(face (eyedrop-face-at-point)))
(unless face (read-face-name facemenup-err-point))
(doremi-face-fg+ face (read-char-exclusive (format "Change foreground of `%s'. \
Adjust red, green, blue, hue, saturation, or value? [rgbhsv]: " face))
increment (consp current-prefix-arg)))))
(defun facemenup-set-face-bg-RGB-at-mouse (event)
"Set RGB of background of face at character under the mouse pointer.
RGB is specified in decimal."
(interactive "e")
(let ((echo-keystrokes 0)
(face (save-excursion
(set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point)))
red green blue)
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (input-pending-p) (discard-input))
(while (or (not (wholenump red)) (>= red 256))
(setq red (read-minibuffer "Red value (decimal): ")))
(while (or (not (wholenump green)) (>= green 256))
(setq green (read-minibuffer "Green value (decimal): ")))
(while (or (not (wholenump blue)) (>= blue 256))
(setq blue (read-minibuffer "Blue value (decimal): ")))
(setq red (format "%02x" red)
green (format "%02x" green)
blue (format "%02x" blue))
(let ((bg (facemenup-face-bg face)))
(setq facemenup-last-face-bg bg
facemenup-last-face-changed face))
(set-face-background face (format "#%s%s%s" red green blue))))
(defun facemenup-set-face-fg-RGB-at-mouse (event)
"Set RGB of foreground of face at character under the mouse pointer.
RGB is specified in decimal."
(interactive "e")
(let ((echo-keystrokes 0)
(face (save-excursion
(set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point)))
red green blue)
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (input-pending-p) (discard-input))
(while (or (not (wholenump red)) (>= red 256))
(setq red (read-minibuffer "Red value (decimal): ")))
(while (or (not (wholenump green)) (>= green 256))
(setq green (read-minibuffer "Green value (decimal): ")))
(while (or (not (wholenump blue)) (>= blue 256))
(setq blue (read-minibuffer "Blue value (decimal): ")))
(setq red (format "%02x" red)
green (format "%02x" green)
blue (format "%02x" blue))
(let ((fg (facemenup-face-fg face)))
(setq facemenup-last-face-fg fg
facemenup-last-face-changed face))
(set-face-foreground face (format "#%s%s%s" red green blue))))
(defun facemenup-set-face-bg-RGB-at-point ()
"Set RGB of background of face at character following cursor (point).
RGB is specified in decimal, from 0 to 255."
(interactive)
(let ((face (eyedrop-face-at-point))
red green blue)
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (or (not (wholenump red)) (>= red 256))
(setq red (read-minibuffer "Red value (decimal, 0-255): ")))
(while (or (not (wholenump green)) (>= green 256))
(setq green (read-minibuffer "Green value (decimal, 0-255): ")))
(while (or (not (wholenump blue)) (>= blue 256))
(setq blue (read-minibuffer "Blue value (decimal, 0-255): ")))
(setq red (format "%02x" red)
green (format "%02x" green)
blue (format "%02x" blue))
(let ((bg (facemenup-face-bg face)))
(setq facemenup-last-face-bg bg
facemenup-last-face-changed face))
(set-face-background face (format "#%s%s%s" red green blue))))
(defun facemenup-set-face-fg-RGB-at-point ()
"Set RGB of foreground of face at character following cursor (point).
RGB is specified in decimal, from 0 to 255."
(interactive)
(let ((face (eyedrop-face-at-point))
red green blue)
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (or (not (wholenump red)) (>= red 256))
(setq red (read-minibuffer "Red value (decimal, 0-255): ")))
(while (or (not (wholenump green)) (>= green 256))
(setq green (read-minibuffer "Green value (decimal, 0-255): ")))
(while (or (not (wholenump blue)) (>= blue 256))
(setq blue (read-minibuffer "Blue value (decimal, 0-255): ")))
(setq red (format "%02x" red)
green (format "%02x" green)
blue (format "%02x" blue))
(let ((fg (facemenup-face-fg face)))
(setq facemenup-last-face-fg fg
facemenup-last-face-changed face))
(set-face-foreground face (format "#%s%s%s" red green blue))))
(defun facemenup-set-face-bg-RGB-hex-at-mouse (event)
"Set RGB of background of face at character under the mouse pointer.
RGB is specified in hexadecimal, from 0 to FFFF."
(interactive "e")
(let ((echo-keystrokes 0)
(face (save-excursion
(set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point)))
red green blue)
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (input-pending-p) (discard-input))
(while (null (condition-case nil
(prog1
(setq red (hexrgb-hex-to-int
(read-from-minibuffer "Red value (hex, 0-FFFF): ")))
(when (or (< red 0) (> red 65535)) (error)))
(error nil))))
(while (null (condition-case nil
(prog1
(setq green (hexrgb-hex-to-int
(read-from-minibuffer "Green value (hex, 0-FFFF): ")))
(when (or (< green 0) (> green 65535)) (error)))
(error nil))))
(while (null (condition-case nil
(prog1
(setq blue (hexrgb-hex-to-int
(read-from-minibuffer "Blue value (hex, 0-FFFF): ")))
(when (or (< blue 0) (> blue 65535)) (error)))
(error nil))))
(let ((bg (facemenup-face-bg face)))
(setq facemenup-last-face-bg bg
facemenup-last-face-changed face))
(set-face-background face (format "#%04x%04x%04x" red green blue))))
(defun facemenup-set-face-fg-RGB-hex-at-mouse (event)
"Set RGB of foreground of face at character under the mouse pointer.
RGB is specified in hexadecimal, from 0 to FFFF."
(interactive "e")
(let ((echo-keystrokes 0)
(face (save-excursion
(set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point)))
red green blue)
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (input-pending-p) (discard-input))
(while (null (condition-case nil
(prog1
(setq red (hexrgb-hex-to-int
(read-from-minibuffer "Red value (hex, 0-FFFF): ")))
(when (or (< red 0) (> red 65535)) (error)))
(error nil))))
(while (null (condition-case nil
(prog1
(setq green (hexrgb-hex-to-int
(read-from-minibuffer "Green value (hex, 0-FFFF): ")))
(when (or (< green 0) (> green 65535)) (error)))
(error nil))))
(while (null (condition-case nil
(prog1
(setq blue (hexrgb-hex-to-int
(read-from-minibuffer "Blue value (hex, 0-FFFF): ")))
(when (or (< blue 0) (> blue 65535)) (error)))
(error nil))))
(let ((fg (facemenup-face-fg face)))
(setq facemenup-last-face-fg fg
facemenup-last-face-changed face))
(set-face-foreground face (format "#%04x%04x%04x" red green blue))))
(defun facemenup-set-face-bg-RGB-hex-at-point ()
"Set RGB of background of face at character following cursor (point).
RGB is specified in hexadecimal, from 0 to FFFF."
(interactive)
(let ((face (eyedrop-face-at-point))
red green blue)
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (null (condition-case nil
(prog1
(setq red (hexrgb-hex-to-int
(read-from-minibuffer "Red value (hex, 0-FFFF): ")))
(when (or (< red 0) (> red 65535)) (error)))
(error nil))))
(while (null (condition-case nil
(prog1
(setq green (hexrgb-hex-to-int
(read-from-minibuffer "Green value (hex, 0-FFFF): ")))
(when (or (< green 0) (> green 65535)) (error)))
(error nil))))
(while (null (condition-case nil
(prog1
(setq blue (hexrgb-hex-to-int
(read-from-minibuffer "Blue value (hex, 0-FFFF): ")))
(when (or (< blue 0) (> blue 65535)) (error)))
(error nil))))
(let ((bg (facemenup-face-bg face)))
(setq facemenup-last-face-bg bg
facemenup-last-face-changed face))
(set-face-background face (format "#%04x%04x%04x" red green blue))))
(defun facemenup-set-face-fg-RGB-hex-at-point ()
"Set RGB of foreground of face at character following cursor (point).
RGB is specified in hexadecimal, from 0 to FFFF."
(interactive)
(let ((face (eyedrop-face-at-point))
red green blue)
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (null (condition-case nil
(prog1
(setq red (hexrgb-hex-to-int
(read-from-minibuffer "Red value (hex, 0-FFFF): ")))
(when (or (< red 0) (> red 65535)) (error)))
(error nil))))
(while (null (condition-case nil
(prog1
(setq green (hexrgb-hex-to-int
(read-from-minibuffer "Green value (hex, 0-FFFF): ")))
(when (or (< green 0) (> green 65535)) (error)))
(error nil))))
(while (null (condition-case nil
(prog1
(setq blue (hexrgb-hex-to-int
(read-from-minibuffer "Blue value (hex, 0-FFFF): ")))
(when (or (< blue 0) (> blue 65535)) (error)))
(error nil))))
(let ((fg (facemenup-face-fg face)))
(setq facemenup-last-face-fg fg
facemenup-last-face-changed face))
(set-face-foreground face (format "#%04x%04x%04x" red green blue))))
(defun facemenup-paste-to-face-bg-at-mouse (event)
"Paste last color copied to background of face under mouse.
The last color copied is in `eyedrop-last-picked-color'."
(interactive "e")
(unless eyedrop-last-picked-color (error "Cannot paste. No color copied"))
(let ((face (save-excursion (set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point))))
(unless face (setq face (read-face-name facemenup-err-mouse)))
(let ((bg (facemenup-face-bg face)))
(setq facemenup-last-face-bg bg
facemenup-last-face-changed face))
(set-face-background face eyedrop-last-picked-color)))
(defun facemenup-paste-to-face-fg-at-mouse (event)
"Paste last color copied to foreground of face under mouse.
The last color copied is in `eyedrop-last-picked-color'."
(interactive "e")
(unless eyedrop-last-picked-color (error "Cannot paste. No color copied"))
(let ((face (save-excursion (set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point))))
(unless face (setq face (read-face-name facemenup-err-mouse)))
(let ((fg (facemenup-face-fg face)))
(setq facemenup-last-face-fg fg
facemenup-last-face-changed face))
(set-face-foreground face eyedrop-last-picked-color)))
(defun facemenup-paste-to-face-bg-at-point ()
"Paste last color copied to background of face at cursor (point).
The last color copied is in `eyedrop-last-picked-color'."
(interactive)
(unless eyedrop-last-picked-color (error "Cannot paste. No color copied"))
(let ((face (eyedrop-face-at-point)))
(unless face (read-face-name facemenup-err-point))
(let ((bg (facemenup-face-bg face)))
(setq facemenup-last-face-bg bg
facemenup-last-face-changed face))
(set-face-background face eyedrop-last-picked-color)))
(defun facemenup-paste-to-face-fg-at-point ()
"Paste last color copied to foreground of face at cursor (point).
The last color copied is in `eyedrop-last-picked-color'."
(interactive)
(unless eyedrop-last-picked-color (error "Cannot paste. No color copied"))
(let ((face (eyedrop-face-at-point)))
(unless face (read-face-name facemenup-err-point))
(let ((fg (facemenup-face-fg face)))
(setq facemenup-last-face-fg fg
facemenup-last-face-changed face))
(set-face-foreground face eyedrop-last-picked-color)))
(when (fboundp 'set-face-attribute)
(defun facemenup-set-face-attribute-at-mouse (event)
"Set attribute of face used at character under the mouse pointer.
You are prompted for the face attribute to change and its new value."
(interactive "e")
(let* ((face (save-excursion
(set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point))))
(unless face (setq face (read-face-name facemenup-err-mouse)))
(while (input-pending-p) (discard-input))
(facemenup-set-face-attribute-at--1 face)))
(defun facemenup-set-face-attribute-at-point ()
"Set attribute of face used at character following cursor (point).
You are prompted for the face attribute to change and its new value."
(interactive)
(let ((face (eyedrop-face-at-point)))
(unless face (read-face-name facemenup-err-point))
(facemenup-set-face-attribute-at--1 face)))
(defun facemenup-set-face-attribute-at--1 (face)
(let* ((attr (intern (completing-read "Face attribute to change:"
[:family :width :height :weight :slant :foreground
:background :inverse-video :stipple
:underline :overline :strike-through
:inherit :box :font :bold :italic]
nil t nil nil ":foreground")))
(value (read-minibuffer (format "New value for attribute `%s': " attr))))
(set-face-attribute face nil attr value)
(put face 'customized-face (list (list 't (list attr value))))
(message (substitute-command-keys
"Use `\\[customize-face]' to revisit changes."))))
(defun facemenup-set-face-attribute ()
"Set attribute of face.
You are prompted for the face, attribute to change, and its new value."
(interactive)
(let ((face (intern (symbol-name (read-face-name "Modify face: ")))))
(facemenup-set-face-attribute-at--1 face))))
(defun facemenup-customize-face-at-mouse (event)
"Customize the face used at character under the mouse pointer."
(interactive "e")
(let ((face (save-excursion (set-buffer (window-buffer (posn-window (event-end event))))
(goto-char (posn-point (event-end event)))
(eyedrop-face-at-point))))
(unless face (read-face-name facemenup-err-mouse))
(customize-face face)))
(defun facemenup-customize-face-at-point ()
"Customize the face used at character following cursor (point)."
(interactive)
(let ((face (eyedrop-face-at-point)))
(unless face (read-face-name facemenup-err-point))
(customize-face face)))
(defun facemenup-face-bg (face)
"`face-background', but get frame background if face has none.
For Emacs 22+, this is `face-background' inheriting from `default'."
(condition-case nil
(face-background face nil 'default)
(error (or (face-background face) (cdr (assq 'background-color (frame-parameters)))))))
(defun facemenup-face-fg (face)
"`face-foreground', but get frame foreground if face has none.
For Emacs 22+, this is `face-foreground' inheriting from `default'."
(condition-case nil
(face-foreground face nil 'default)
(error (or (face-foreground face) (cdr (assq 'foreground-color (frame-parameters)))))))
(defun facemenu-read-color (&optional prompt)
"Read a color using the minibuffer."
(setq prompt (or prompt "Color: "))
(let* ((completion-ignore-case t)
(col (cond ((and (boundp 'icicle-mode) icicle-mode)
(icicle-read-color-wysiwyg 0 prompt))
((fboundp 'hexrgb-read-color)
(hexrgb-read-color prompt nil t))
(t
(completing-read
prompt
(or facemenu-color-alist
(if (fboundp 'defined-colors)
(defined-colors)
(and window-system
(mapcar 'list (x-defined-colors))))))))))
(if (equal "" col) nil col)))
(when (>= emacs-major-version 22)
(defun facemenu-set-face (face &optional start end)
"Apply FACE to the region or the next character typed.
With no prefix argument or a numeric prefix argument, if the region is
active and non-empty, then apply FACE to the region.
Otherwise, apply FACE to the next character inserted.
FACE is determined as follows:
With no prefix argument or a plain prefix argument (`C-u'), read the
name of FACE, using completion.
With a numeric prefix argument:
Display the face list. If the user clicks a face sample, then use
that FACE.
Call `facemenu-add-new-face', then `facemenu-add-face'.
Add FACE to the menu of faces, if allowed by `facemenu-listed-faces'."
(interactive
(list (progn (barf-if-buffer-read-only)
(if (and current-prefix-arg (atom current-prefix-arg))
(let ((deactivate-mark nil)) (list-faces-display))
(read-face-name "Use face")))
(and mark-active (atom current-prefix-arg) (region-beginning))
(and mark-active (atom current-prefix-arg) (region-end))))
(unless (and (interactive-p) current-prefix-arg (atom current-prefix-arg))
(facemenu-add-new-face face)
(facemenu-add-face face start end)))
(defun list-faces-display (&optional regexp)
"List all faces, using the same sample text in each.
The sample text is a string that comes from the variable
`list-faces-sample-text'.
You can click a face name to see a description of the face and
possibly customize it.
You can click a face's sample text to apply that face to the
last-accessed buffer. If the region in that buffer is active and
non-empty, then the face is applied to it. Otherwise, the face
is applied to any new text that is entered.
With a prefix argument, you are prompted for a regexp, and only
faces with matching names are displayed."
(interactive (list (and current-prefix-arg
(if (fboundp 'icicle-read-string-completing)
(icicle-read-string-completing
"List faces matching regexp: " nil
(lambda (c) (string-match "regexp" (symbol-name c))))
(if (fboundp 'read-regexp)
(read-regexp "List faces matching regexp")
(read-string "List faces matching regexp: "))))))
(let ((all-faces (zerop (length regexp)))
(frame (selected-frame))
(max-length 0)
(deactivate-mark nil)
faces line-format disp-frame window face-name)
(setq faces (delq nil (mapcar (lambda (f)
(let ((s (symbol-name f)))
(when (or all-faces (string-match regexp s))
(setq max-length (max (length s) max-length))
f)))
(sort (face-list) #'string-lessp))))
(unless faces (error "No faces matching \"%s\"" regexp))
(setq max-length (1+ max-length)
line-format (format "%%-%ds" max-length))
(with-output-to-temp-buffer "*Faces*"
(save-excursion
(set-buffer standard-output)
(setq truncate-lines t)
(insert (funcall
(if (fboundp 'help-commands-to-key-buttons)
#'help-commands-to-key-buttons
#'substitute-command-keys)
(concat "Use \\<help-mode-map>"
(if (display-mouse-p) "\\[help-follow-mouse] or ")
"\\[help-follow]:\n"
" * on a face's sample text to set the region to that face, or\n"
" * on a face name to see a description of the face and possibly"
" customize it.\n\n"
"Face Sample\n\n")))
(setq help-xref-stack ())
(dolist (face faces)
(setq face-name (symbol-name face))
(insert (format line-format face-name))
(save-excursion
(save-match-data
(search-backward face-name)
(setq help-xref-stack-item `(list-faces-display ,regexp))
(help-xref-button 0 'help-face face)))
(let ((beg (point))
(line-beg (line-beginning-position)))
(insert list-faces-sample-text)
(save-excursion
(save-match-data
(search-backward list-faces-sample-text)
(help-xref-button 0 'help-facemenu-set-face
(list face (other-buffer (current-buffer) t)))))
(insert "\n")
(put-text-property beg (1- (point)) 'face face)
(put-text-property line-beg (1- (point)) 'read-face-name face)
(goto-char beg)
(forward-line 1)
(while (not (eobp))
(insert-char ? max-length)
(forward-line 1))))
(goto-char (point-min))))
(setq window (get-buffer-window (get-buffer "*Faces*") t)
disp-frame (if window (window-frame window) (car (frame-list))))
(or (eq frame disp-frame)
(let ((faces (face-list)))
(while faces
(copy-face (car faces) (car faces) frame disp-frame)
(setq faces (cdr faces)))))))
(define-button-type 'help-facemenu-set-face
:supertype 'help-xref
'help-function 'facemenup-set-face-from-list
'help-echo (purecopy "mouse-2, RET: Set region to face"))
(defun facemenup-set-face-from-list (face+buffer)
"Like `facemenu-set-face', but acts in another buffer.
Argument FACE+BUFFER is a list (FACE BUFFER), where FACE is the
face to apply and BUFFER is the target buffer.
Also, close the *Faces* display."
(let ((face (car face+buffer))
(buffer (cadr face+buffer)))
(save-excursion (set-buffer buffer)
(facemenu-add-new-face face)
(facemenu-add-face face (and mark-active (region-beginning))
(and mark-active (region-end)))
(setq mark-active nil)))
(let ((win (get-buffer-window "*Faces*"))) (when win (delete-window win))))
(if (> emacs-major-version 23)
(defun list-colors-print (list &optional callback)
(let ((callback-fn (and callback `(lambda (button)
(funcall ,callback (button-get button 'color-name)))))
(rgb-format (facemenu-rgb-format-for-display))
rgb-width)
(setq rgb-width (1+ (length (format rgb-format 1 1 1))))
(dolist (color list)
(if (consp color)
(when (cdr color)
(setq color (sort color (lambda (a b) (string< (downcase a) (downcase b))))))
(setq color (list color)))
(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)))
(insert (car color))
(indent-to 22)
(put-text-property opoint (point) 'face (list ':background (car color)))
(put-text-property (prog1 (point)
(insert " ")
(if (cdr color)
(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))))
(point) 'face (list ':foreground (car color)))
(indent-to (max (- (window-width) rgb-width) 44))
(insert (propertize
(apply 'format rgb-format (mapcar (lambda (c) (lsh c -8))
(color-values (car color))))
'mouse-face 'highlight
'help-echo
(format "RGB: (%s); HSV: (%s)"
(mapconcat (lambda (dd) (format "%1.6f" dd))
(hexrgb-hex-to-rgb (car color)) ", ")
(mapconcat (lambda (dd) (format "%1.6f" dd))
(hexrgb-hex-to-hsv (car color)) ", "))))
(save-excursion
(save-match-data
(forward-line 0)
(re-search-forward ".*")
(setq help-xref-stack-item `(list-colors-display ,list))
(help-xref-button 0 'help-facemenu-edit-color
(if (consp color) (car color) color))))
(when callback
(make-text-button opoint (point)
'follow-link t
'mouse-face (list :background (car color)
:foreground (if light-p "black" "white"))
'color-name (car color)
'action callback-fn)))
(insert "\n")))
(when (fboundp 'fit-frame-if-one-window) (fit-frame-if-one-window))
(goto-char (point-min)))
(defun list-colors-print (list)
(let ((rgb-format (facemenu-rgb-format-for-display))
rgb-width)
(setq rgb-width (1+ (length (format rgb-format 1 1 1))))
(dolist (color list)
(if (consp color)
(when (cdr color)
(setq color (sort color (lambda (a b) (string< (downcase a) (downcase b))))))
(setq color (list color)))
(put-text-property (prog1 (point) (insert (car color)) (indent-to 22))
(point) 'face (list ':background (car color)))
(put-text-property (prog1 (point)
(insert " " (if (cdr color)
(mapconcat 'identity (cdr color) ", ")
(car color))))
(point) 'face (list ':foreground (car color)))
(indent-to (max (- (window-width) rgb-width) 44))
(insert (apply 'format rgb-format (mapcar (lambda (c) (lsh c -8))
(color-values (car color)))))
(save-excursion
(save-match-data
(forward-line 0)
(re-search-forward ".*")
(setq help-xref-stack-item `(list-colors-display ,list))
(help-xref-button 0 'help-facemenu-edit-color (if (consp color) (car color) color))))
(insert "\n")))
(goto-char (point-min))))
(defun facemenu-rgb-format-for-display ()
(let ((ncolors (display-color-cells (selected-frame)))
(exp 0))
(while (> (lsh ncolors (- exp)) 1)
(setq exp (1+ exp)))
(setq exp (/ exp 12))
(format "#%%0%dx%%0%dx%%0%dx" exp exp exp)))
(define-button-type 'help-facemenu-edit-color
:supertype 'help-xref
'help-function 'palette
'help-echo (purecopy "mouse-2, RET: Open palette on color"))
(if (> emacs-major-version 23)
(defun facemenu-add-face (face &optional start end)
"Add FACE to text between START and END.
If START is nil or START to END is empty, add FACE to next typed character
instead. For each section of that region that has a different face property,
FACE will be consed onto it, and other faces that are completely hidden by
that will be removed from the list.
If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil,
they are used to set the face information.
As a special case, if FACE is `default', then the region is left with NO face
text property. Otherwise, selecting the default face would not have any
effect. See `facemenu-remove-face-function'."
(interactive "*xFace: \nr")
(cond
((and (eq face 'default)
(not (eq facemenu-remove-face-function t)))
(if facemenu-remove-face-function
(funcall facemenu-remove-face-function start end)
(if (and start (< start end))
(remove-text-properties start end '(face default))
(facemenu-set-self-insert-face 'default))))
(facemenu-add-face-function
(save-excursion
(if end (goto-char end))
(save-excursion
(if start (goto-char start))
(insert-before-markers
(funcall facemenu-add-face-function face end)))
(if facemenu-end-add-face
(insert (if (stringp facemenu-end-add-face)
facemenu-end-add-face
(funcall facemenu-end-add-face face))))))
((and start (< start end))
(let ((part-start start) part-end)
(while (not (= part-start end))
(setq part-end (next-single-property-change part-start 'face
nil end))
(let ((prev (get-text-property part-start 'face)))
(put-text-property part-start part-end 'face
(if (null prev)
face
(facemenu-active-faces
(cons face
(if (listp prev)
prev
(list prev)))
(selected-frame))))
(put-text-property part-start part-end 'font-lock-ignore t))
(setq part-start part-end))))
(t
(facemenu-set-self-insert-face
(if (eq last-command (cdr facemenu-self-insert-data))
(cons face (if (listp (car facemenu-self-insert-data))
(car facemenu-self-insert-data)
(list (car facemenu-self-insert-data))))
face))))
(unless (facemenu-enable-faces-p)
(message "Font-lock mode will override any faces you set in this buffer")))
(defun facemenu-add-face (face &optional start end)
"Add FACE to text between START and END.
If START is nil or START to END is empty, add FACE to next typed character
instead. For each section of that region that has a different face property,
FACE will be consed onto it, and other faces that are completely hidden by
that will be removed from the list.
If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-nil,
they are used to set the face information.
As a special case, if FACE is `default', then the region is left with NO face
text property. Otherwise, selecting the default face would not have any
effect. See `facemenu-remove-face-function'."
(interactive "*xFace: \nr")
(if (and (eq face 'default)
(not (eq facemenu-remove-face-function t)))
(if facemenu-remove-face-function
(funcall facemenu-remove-face-function start end)
(if (and start (< start end))
(remove-text-properties start end '(face default))
(setq self-insert-face 'default
self-insert-face-command this-command)))
(if facemenu-add-face-function
(save-excursion
(if end (goto-char end))
(save-excursion
(if start (goto-char start))
(insert-before-markers
(funcall facemenu-add-face-function face end)))
(if facemenu-end-add-face
(insert (if (stringp facemenu-end-add-face)
facemenu-end-add-face
(funcall facemenu-end-add-face face)))))
(if (and start (< start end))
(let ((part-start start)
part-end)
(while (not (= part-start end))
(setq part-end (next-single-property-change part-start 'face nil end))
(let ((prev (get-text-property part-start 'face)))
(put-text-property part-start part-end 'face
(if (null prev)
face
(facemenu-active-faces
(cons face
(if (listp prev)
prev
(list prev)))
(selected-frame))))
(put-text-property part-start part-end 'font-lock-ignore t))
(setq part-start part-end)))
(setq self-insert-face (if (eq last-command self-insert-face-command)
(cons face (if (listp self-insert-face)
self-insert-face
(list self-insert-face)))
face)
self-insert-face-command this-command))))
(unless (facemenu-enable-faces-p)
(message "Font-lock mode will override any faces you set in this buffer")))))
(provide 'facemenu+)