38 |
;; insertion. It will be forgotten if you move point or make other |
;; insertion. It will be forgotten if you move point or make other |
39 |
;; modifications before inserting or typing anything. |
;; modifications before inserting or typing anything. |
40 |
;; |
;; |
41 |
;; Faces can be selected from the keyboard as well. |
;; Faces can be selected from the keyboard as well. |
42 |
;; The standard keybindings are M-g (or ESC g) + letter: |
;; The standard keybindings are M-g (or ESC g) + letter: |
43 |
;; M-g i = "set italic", M-g b = "set bold", etc. |
;; M-g i = "set italic", M-g b = "set bold", etc. |
44 |
|
|
86 |
|
|
87 |
;;; Code: |
;;; Code: |
88 |
|
|
89 |
(provide 'facemenu) |
(eval-when-compile |
|
|
|
|
(eval-when-compile |
|
90 |
(require 'help) |
(require 'help) |
91 |
(require 'button)) |
(require 'button)) |
92 |
|
|
93 |
;;; Provide some binding for startup: |
;;; Provide some binding for startup: |
94 |
;;;###autoload (define-key global-map "\M-g" 'facemenu-keymap) |
;;;###autoload (define-key global-map "\M-g" 'facemenu-keymap) |
95 |
;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap) |
;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap) |
96 |
|
|
97 |
;; Global bindings: |
;; Global bindings: |
98 |
(define-key global-map [C-down-mouse-2] 'facemenu-menu) |
(define-key global-map [C-down-mouse-2] 'facemenu-menu) |
99 |
(define-key global-map "\M-g" 'facemenu-keymap) |
(define-key global-map "\M-g" 'facemenu-keymap) |
116 |
|
|
117 |
The faces specifically mentioned in this list are put at the top of |
The faces specifically mentioned in this list are put at the top of |
118 |
the menu, in the order specified. All other faces which are defined, |
the menu, in the order specified. All other faces which are defined, |
119 |
except for those in `facemenu-unlisted-faces', are listed after them, |
except for those in `facemenu-unlisted-faces', are listed after them, |
120 |
but get no keyboard equivalents. |
but get no keyboard equivalents. |
121 |
|
|
122 |
If you change this variable after loading facemenu.el, you will need to call |
If you change this variable after loading facemenu.el, you will need to call |
164 |
(defalias 'facemenu-face-menu facemenu-face-menu) |
(defalias 'facemenu-face-menu facemenu-face-menu) |
165 |
|
|
166 |
;;;###autoload |
;;;###autoload |
167 |
(defvar facemenu-foreground-menu |
(defvar facemenu-foreground-menu |
168 |
(let ((map (make-sparse-keymap "Foreground Color"))) |
(let ((map (make-sparse-keymap "Foreground Color"))) |
169 |
(define-key map "o" (cons "Other..." 'facemenu-set-foreground)) |
(define-key map "o" (cons "Other..." 'facemenu-set-foreground)) |
170 |
map) |
map) |
182 |
(defalias 'facemenu-background-menu facemenu-background-menu) |
(defalias 'facemenu-background-menu facemenu-background-menu) |
183 |
|
|
184 |
;;;###autoload |
;;;###autoload |
185 |
(defvar facemenu-special-menu |
(defvar facemenu-special-menu |
186 |
(let ((map (make-sparse-keymap "Special"))) |
(let ((map (make-sparse-keymap "Special"))) |
187 |
(define-key map [?s] (cons (purecopy "Remove Special") |
(define-key map [?s] (cons (purecopy "Remove Special") |
188 |
'facemenu-remove-special)) |
'facemenu-remove-special)) |
213 |
;;;###autoload |
;;;###autoload |
214 |
(defvar facemenu-indentation-menu |
(defvar facemenu-indentation-menu |
215 |
(let ((map (make-sparse-keymap "Indentation"))) |
(let ((map (make-sparse-keymap "Indentation"))) |
216 |
(define-key map [decrease-right-margin] |
(define-key map [decrease-right-margin] |
217 |
(cons (purecopy "Indent Right Less") 'decrease-right-margin)) |
(cons (purecopy "Indent Right Less") 'decrease-right-margin)) |
218 |
(define-key map [increase-right-margin] |
(define-key map [increase-right-margin] |
219 |
(cons (purecopy "Indent Right More") 'increase-right-margin)) |
(cons (purecopy "Indent Right More") 'increase-right-margin)) |
236 |
(let ((map facemenu-menu)) |
(let ((map facemenu-menu)) |
237 |
(define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display)) |
(define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display)) |
238 |
(define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display)) |
(define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display)) |
239 |
(define-key map [dp] (cons (purecopy "Describe Text") |
(define-key map [dp] (cons (purecopy "Describe Properties") |
240 |
'describe-text-at)) |
'describe-text-properties)) |
241 |
(define-key map [ra] (cons (purecopy "Remove Text Properties") |
(define-key map [ra] (cons (purecopy "Remove Text Properties") |
242 |
'facemenu-remove-all)) |
'facemenu-remove-all)) |
243 |
(define-key map [rm] (cons (purecopy "Remove Face Properties") |
(define-key map [rm] (cons (purecopy "Remove Face Properties") |
245 |
(define-key map [s1] (list (purecopy "--")))) |
(define-key map [s1] (list (purecopy "--")))) |
246 |
;;;###autoload |
;;;###autoload |
247 |
(let ((map facemenu-menu)) |
(let ((map facemenu-menu)) |
248 |
(define-key map [in] (cons (purecopy "Indentation") |
(define-key map [in] (cons (purecopy "Indentation") |
249 |
'facemenu-indentation-menu)) |
'facemenu-indentation-menu)) |
250 |
(define-key map [ju] (cons (purecopy "Justification") |
(define-key map [ju] (cons (purecopy "Justification") |
251 |
'facemenu-justification-menu)) |
'facemenu-justification-menu)) |
252 |
(define-key map [s2] (list (purecopy "--"))) |
(define-key map [s2] (list (purecopy "--"))) |
253 |
(define-key map [sp] (cons (purecopy "Special Properties") |
(define-key map [sp] (cons (purecopy "Special Properties") |
254 |
'facemenu-special-menu)) |
'facemenu-special-menu)) |
255 |
(define-key map [bg] (cons (purecopy "Background Color") |
(define-key map [bg] (cons (purecopy "Background Color") |
256 |
'facemenu-background-menu)) |
'facemenu-background-menu)) |
257 |
(define-key map [fg] (cons (purecopy "Foreground Color") |
(define-key map [fg] (cons (purecopy "Foreground Color") |
258 |
'facemenu-foreground-menu)) |
'facemenu-foreground-menu)) |
259 |
(define-key map [fc] (cons (purecopy "Face") |
(define-key map [fc] (cons (purecopy "Face") |
260 |
'facemenu-face-menu))) |
'facemenu-face-menu))) |
261 |
;;;###autoload |
;;;###autoload |
262 |
(defalias 'facemenu-menu facemenu-menu) |
(defalias 'facemenu-menu facemenu-menu) |
263 |
|
|
264 |
(defvar facemenu-keymap |
(defvar facemenu-keymap |
265 |
(let ((map (make-sparse-keymap "Set face"))) |
(let ((map (make-sparse-keymap "Set face"))) |
266 |
(define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face)) |
(define-key map "o" (cons (purecopy "Other...") 'facemenu-set-face)) |
267 |
map) |
map) |
328 |
|
|
329 |
Otherwise, this command specifies the face for the next character |
Otherwise, this command specifies the face for the next character |
330 |
inserted. Moving point or switching buffers before |
inserted. Moving point or switching buffers before |
331 |
typing a character to insert cancels the specification." |
typing a character to insert cancels the specification." |
332 |
(interactive (list (progn |
(interactive (list (progn |
333 |
(barf-if-buffer-read-only) |
(barf-if-buffer-read-only) |
334 |
(read-face-name "Use face")) |
(read-face-name "Use face")) |
350 |
|
|
351 |
Otherwise, this command specifies the face for the next character |
Otherwise, this command specifies the face for the next character |
352 |
inserted. Moving point or switching buffers before |
inserted. Moving point or switching buffers before |
353 |
typing a character to insert cancels the specification." |
typing a character to insert cancels the specification." |
354 |
(interactive (list (progn |
(interactive (list (progn |
355 |
(barf-if-buffer-read-only) |
(barf-if-buffer-read-only) |
356 |
(facemenu-read-color "Foreground color: ")) |
(facemenu-read-color "Foreground color: ")) |
374 |
|
|
375 |
Otherwise, this command specifies the face for the next character |
Otherwise, this command specifies the face for the next character |
376 |
inserted. Moving point or switching buffers before |
inserted. Moving point or switching buffers before |
377 |
typing a character to insert cancels the specification." |
typing a character to insert cancels the specification." |
378 |
(interactive (list (progn |
(interactive (list (progn |
379 |
(barf-if-buffer-read-only) |
(barf-if-buffer-read-only) |
380 |
(facemenu-read-color "Background color: ")) |
(facemenu-read-color "Background color: ")) |
399 |
|
|
400 |
Otherwise, this command specifies the face for the next character |
Otherwise, this command specifies the face for the next character |
401 |
inserted. Moving point or switching buffers before |
inserted. Moving point or switching buffers before |
402 |
typing a character to insert cancels the specification." |
typing a character to insert cancels the specification." |
403 |
(interactive (list last-command-event |
(interactive (list last-command-event |
404 |
(if (and mark-active (not current-prefix-arg)) |
(if (and mark-active (not current-prefix-arg)) |
405 |
(region-beginning)) |
(region-beginning)) |
407 |
(region-end)))) |
(region-end)))) |
408 |
(barf-if-buffer-read-only) |
(barf-if-buffer-read-only) |
409 |
(facemenu-get-face face) |
(facemenu-get-face face) |
410 |
(if start |
(if start |
411 |
(facemenu-add-face face start end) |
(facemenu-add-face face start end) |
412 |
(facemenu-add-face face))) |
(facemenu-add-face face))) |
413 |
|
|
440 |
"Remove `face' and `mouse-face' text properties." |
"Remove `face' and `mouse-face' text properties." |
441 |
(interactive "*r") ; error if buffer is read-only despite the next line. |
(interactive "*r") ; error if buffer is read-only despite the next line. |
442 |
(let ((inhibit-read-only t)) |
(let ((inhibit-read-only t)) |
443 |
(remove-text-properties |
(remove-text-properties |
444 |
start end '(face nil mouse-face nil)))) |
start end '(face nil mouse-face nil)))) |
445 |
|
|
446 |
;;;###autoload |
;;;###autoload |
456 |
These special properties include `invisible', `intangible' and `read-only'." |
These special properties include `invisible', `intangible' and `read-only'." |
457 |
(interactive "*r") ; error if buffer is read-only despite the next line. |
(interactive "*r") ; error if buffer is read-only despite the next line. |
458 |
(let ((inhibit-read-only t)) |
(let ((inhibit-read-only t)) |
459 |
(remove-text-properties |
(remove-text-properties |
460 |
start end '(invisible nil intangible nil read-only nil)))) |
start end '(invisible nil intangible nil read-only nil)))) |
461 |
|
|
462 |
;;;###autoload |
;;;###autoload |
463 |
(defun facemenu-read-color (&optional prompt) |
(defun facemenu-read-color (&optional prompt) |
464 |
"Read a color using the minibuffer." |
"Read a color using the minibuffer." |
465 |
(let ((col (completing-read (or prompt "Color: ") |
(let ((col (completing-read (or prompt "Color: ") |
466 |
(or facemenu-color-alist |
(or facemenu-color-alist |
467 |
(mapcar 'list (defined-colors))) |
(defined-colors)) |
468 |
nil t))) |
nil t))) |
469 |
(if (equal "" col) |
(if (equal "" col) |
470 |
nil |
nil |
498 |
(setq s (point)) |
(setq s (point)) |
499 |
(insert (car list)) |
(insert (car list)) |
500 |
(indent-to 20) |
(indent-to 20) |
501 |
(put-text-property s (point) 'face |
(put-text-property s (point) 'face |
502 |
(cons 'background-color (car list))) |
(cons 'background-color (car list))) |
503 |
(setq s (point)) |
(setq s (point)) |
504 |
(insert " " (car list) "\n") |
(insert " " (car list) "\n") |
505 |
(put-text-property s (point) 'face |
(put-text-property s (point) 'face |
506 |
(cons 'foreground-color (car list))) |
(cons 'foreground-color (car list))) |
507 |
(setq list (cdr list))))))) |
(setq list (cdr list))))))) |
508 |
|
|
652 |
(define-key 'facemenu-keymap key (cons name function)) |
(define-key 'facemenu-keymap key (cons name function)) |
653 |
(define-key menu key (cons name function))) |
(define-key menu key (cons name function))) |
654 |
((facemenu-iterate ; check if equivalent face is already in the menu |
((facemenu-iterate ; check if equivalent face is already in the menu |
655 |
(lambda (m) (and (listp m) |
(lambda (m) (and (listp m) |
656 |
(symbolp (car m)) |
(symbolp (car m)) |
657 |
(face-equal (car m) symbol))) |
(face-equal (car m) symbol))) |
658 |
(cdr (symbol-function menu)))) |
(cdr (symbol-function menu)))) |
693 |
(format "Select background color %s for subsequent insertion." |
(format "Select background color %s for subsequent insertion." |
694 |
name)))) |
name)))) |
695 |
(cond ((facemenu-iterate ; check if equivalent face is already in the menu |
(cond ((facemenu-iterate ; check if equivalent face is already in the menu |
696 |
(lambda (m) (and (listp m) |
(lambda (m) (and (listp m) |
697 |
(symbolp (car m)) |
(symbolp (car m)) |
698 |
(stringp (cadr m)) |
(stringp (cadr m)) |
699 |
(string-equal (cadr m) color))) |
(string-equal (cadr m) color))) |
711 |
|
|
712 |
(defun facemenu-complete-face-list (&optional oldlist) |
(defun facemenu-complete-face-list (&optional oldlist) |
713 |
"Return list of all faces that look different. |
"Return list of all faces that look different. |
714 |
Starts with given ALIST of faces, and adds elements only if they display |
Starts with given ALIST of faces, and adds elements only if they display |
715 |
differently from any face already on the list. |
differently from any face already on the list. |
716 |
The faces on ALIST will end up at the end of the returned list, in reverse |
The faces on ALIST will end up at the end of the returned list, in reverse |
717 |
order." |
order." |
718 |
(let ((list (nreverse (mapcar 'car oldlist)))) |
(let ((list (nreverse (mapcar 'car oldlist)))) |
719 |
(facemenu-iterate |
(facemenu-iterate |
720 |
(lambda (new-face) |
(lambda (new-face) |
721 |
(if (not (memq new-face list)) |
(if (not (memq new-face list)) |
722 |
(setq list (cons new-face list))) |
(setq list (cons new-face list))) |
723 |
nil) |
nil) |
733 |
|
|
734 |
(facemenu-update) |
(facemenu-update) |
735 |
|
|
736 |
|
(provide 'facemenu) |
737 |
;;; facemenu.el ends here |
;;; facemenu.el ends here |