Commit | Line | Data |
---|---|---|
4e8aa578 RS |
1 | ;;; facemenu.el -- Create a face menu for interactively adding fonts to text |
2 | ;; Copyright (c) 1994 Free Software Foundation, Inc. | |
3 | ||
4 | ;; Author: Boris Goldowsky <boris@cs.rochester.edu> | |
5 | ;; Keywords: faces | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
9 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation; either version 2, or (at your option) | |
12 | ;; any later version. | |
13 | ||
14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
21 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
22 | ||
23 | ;;; Commentary: | |
24 | ;; This file defines a menu of faces (bold, italic, etc) which | |
25 | ;; allows you to set the face used for a region of the buffer. | |
26 | ;; Some faces also have keybindings, which are shown in the menu. | |
27 | ||
28 | ;;; Installation: | |
29 | ;; Put this file somewhere on emacs's load-path, and put | |
30 | ;; (require 'facemenu) | |
31 | ;; in your .emacs file. | |
32 | ||
33 | ;;; Usage: | |
34 | ;; Selecting a face from the menu or typing the keyboard equivalent | |
35 | ;; will change the region to use that face. | |
36 | ;; If you use transient-mark-mode and the region is not active, the | |
37 | ;; face will be remembered and used for the next insertion. It will | |
38 | ;; be forgotten if you move point or make other modifications before | |
39 | ;; inserting or typing anything. | |
40 | ;; | |
41 | ;; Faces can be selected from the keyboard as well. | |
42 | ;; The standard keybindings are M-s (or ESC s) + letter: | |
43 | ;; M-s i = "set italic", M-s b = "set bold", etc. | |
44 | ||
45 | ;;; Customization: | |
46 | ;; An alternative set of keybindings that may be easier to type can be set up | |
47 | ;; using "Hyper" keys. This requires that you set up a hyper-key on your | |
48 | ;; keyboard. On my system, putting the following command in my .xinitrc: | |
49 | ;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L" | |
50 | ;; makes the key labelled "Alt" act as a hyper key, but check with local | |
51 | ;; X-perts for how to do it on your system. If you do this, then put the | |
52 | ;; following in your .emacs before the (require 'facemenu): | |
53 | ;; (setq facemenu-keybindings | |
54 | ;; '((default . [?\H-d]) | |
55 | ;; (bold . [?\H-b]) | |
56 | ;; (italic . [?\H-i]) | |
57 | ;; (bold-italic . [?\H-o]) | |
58 | ;; (underline . [?\H-u]))) | |
59 | ;; (setq facemenu-keymap global-map) | |
60 | ;; (setq facemenu-key nil) | |
61 | ;; | |
62 | ;; In general, the order of the faces that appear in the menu and their | |
63 | ;; keybindings can be controlled by setting the variable | |
64 | ;; `facemenu-keybindings'. Faces that you never want to add to your | |
65 | ;; document (e.g., `region') are listed in `facemenu-unlisted-faces'. | |
66 | ||
67 | ;;; Known Problems: | |
68 | ;; Only works with Emacs 19.23 and later. | |
69 | ;; | |
70 | ;; There is at present no way to display what the faces look like in | |
71 | ;; the menu itself. | |
72 | ;; | |
73 | ;; `list-faces-display' shows the faces in a different order than | |
74 | ;; this menu, which could be confusing. I do /not/ sort the list | |
75 | ;; alphabetically, because I like the default order: it puts the most | |
76 | ;; basic, common fonts first. | |
77 | ;; | |
78 | ;; Please send me any other problems, comments or ideas. | |
79 | ||
80 | ;;; Code: | |
81 | ||
82 | (provide 'facemenu) | |
83 | ||
84 | (defvar facemenu-key "\M-s" | |
85 | "Prefix to use for facemenu commands.") | |
86 | ||
87 | (defvar facemenu-keymap nil | |
88 | "Map for keybindings of face commands. | |
89 | If nil, `facemenu-update' will create one. | |
90 | `Facemenu-update' also fills in the keymap according to the bindings | |
91 | requested in facemenu-keybindings.") | |
92 | ||
93 | (defvar facemenu-keybindings | |
94 | '((default . "d") | |
95 | (bold . "b") | |
96 | (italic . "i") | |
97 | (bold-italic . "o") ; O for "Oblique" or "bOld"... | |
98 | (underline . "u")) | |
99 | "Alist of interesting faces and keybindings. | |
100 | Each element is itself a list: the car is the name of the face, | |
101 | the next element is the key to use as a keyboard equivalent of the menu item; | |
102 | the binding is made in facemenu-keymap. | |
103 | ||
104 | The faces specifically mentioned in this list are put at the top of | |
105 | the menu, in the order specified. All other faces which are defined, | |
106 | except for those in `facemenu-unlisted-faces', are listed after them, | |
107 | but get no keyboard equivalents. | |
108 | ||
109 | If you change this variable after loading facemenu.el, you will need to call | |
110 | `facemenu-update' to make it take effect.") | |
111 | ||
112 | (defvar facemenu-unlisted-faces | |
113 | '(modeline region secondary-selection highlight scratch-face) | |
114 | "Faces that are not included in the Face menu. | |
115 | Set this before loading facemenu.el, or call `facemenu-update' after | |
116 | changing it.") | |
117 | ||
118 | (defvar facemenu-next nil) ; set when we are going to set a face on next char. | |
119 | (defvar facemenu-loc nil) | |
120 | ||
121 | (defun facemenu-update () | |
122 | "Add or update the \"Face\" menu in the menu bar." | |
123 | (interactive) | |
124 | ||
125 | ;; Set up keymaps | |
126 | (fset 'facemenu-menu (setq facemenu-menu (make-sparse-keymap "Face"))) | |
127 | (if (null facemenu-keymap) | |
128 | (fset 'facemenu-keymap | |
129 | (setq facemenu-keymap (make-sparse-keymap "Set face")))) | |
130 | (if facemenu-key | |
131 | (define-key global-map facemenu-key facemenu-keymap)) | |
132 | ||
133 | ;; Define basic keys | |
41e77289 RS |
134 | ;; We construct this list structure explicitly because a quoted constant |
135 | ;; would be pure. | |
b22e89dc RS |
136 | (define-key facemenu-menu [update] (cons "Update Menu" 'facemenu-update)) |
137 | (define-key facemenu-menu [display] (cons "Display" 'list-faces-display)) | |
138 | (define-key facemenu-menu [sep1] (list "-------------")) | |
41e77289 RS |
139 | (define-key facemenu-menu [remove] (cons "Remove Properties" |
140 | 'facemenu-remove-all)) | |
b22e89dc RS |
141 | (define-key facemenu-menu [read-only] (cons "Read-Only" |
142 | 'facemenu-set-read-only)) | |
143 | (define-key facemenu-menu [invisible] (cons "Invisible" | |
144 | 'facemenu-set-invisible)) | |
002e48b7 | 145 | (define-key facemenu-menu [sep2] (list "-------------")) |
b22e89dc | 146 | (define-key facemenu-menu [other] (cons "Other..." 'facemenu-set-face)) |
4e8aa578 RS |
147 | |
148 | ;; Define commands for face-changing | |
149 | (facemenu-iterate | |
150 | (function | |
151 | (lambda (f) | |
152 | (let ((face (car f)) | |
153 | (name (symbol-name (car f))) | |
154 | (key (cdr f))) | |
155 | (cond ((memq face facemenu-unlisted-faces) | |
156 | nil) | |
157 | ((null key) (define-key facemenu-menu (vector face) | |
158 | (cons name 'facemenu-set-face-from-menu))) | |
159 | (t (let ((function (intern (concat "facemenu-set-" name)))) | |
160 | (fset function | |
161 | (` (lambda () (interactive) | |
162 | (facemenu-set-face (quote (, face)))))) | |
163 | (define-key facemenu-keymap key (cons name function)) | |
164 | (define-key facemenu-menu key (cons name function)))))) | |
165 | nil)) | |
166 | (facemenu-complete-face-list facemenu-keybindings)) | |
167 | ||
168 | (define-key global-map (vector 'menu-bar 'Face) | |
169 | (cons "Face" facemenu-menu))) | |
170 | ||
171 | ; We'd really like to name the menu items as follows, | |
172 | ; but we can't since menu entries don't display text properties (yet?) | |
173 | ; (let ((s (copy-sequence (symbol-name face)))) | |
174 | ; (put-text-property 0 (1- (length s)) | |
175 | ; 'face face s) | |
176 | ; s) | |
177 | ||
178 | ;;;###autoload | |
179 | (defun facemenu-set-face (face &optional start end) | |
180 | "Set the face of the region or next character typed. | |
181 | The face to be used is prompted for. | |
182 | If the region is active, it will be set to the requested face. If | |
183 | it is inactive \(even if mark-even-if-inactive is set) the next | |
184 | character that is typed \(via `self-insert-command') will be set to | |
185 | the the selected face. Moving point or switching buffers before | |
186 | typing a character cancels the request." | |
187 | (interactive (list (read-face-name "Use face: "))) | |
188 | (if mark-active | |
189 | (put-text-property (or start (region-beginning)) | |
190 | (or end (region-end)) | |
191 | 'face face) | |
192 | (setq facemenu-next face facemenu-loc (point)))) | |
193 | ||
194 | (defun facemenu-set-face-from-menu (face start end) | |
195 | "Set the face of the region or next character typed. | |
196 | This function is designed to be called from a menu; the face to use | |
197 | is the menu item's name. | |
198 | If the region is active, it will be set to the requested face. If | |
199 | it is inactive \(even if mark-even-if-inactive is set) the next | |
200 | character that is typed \(via `self-insert-command') will be set to | |
201 | the the selected face. Moving point or switching buffers before | |
202 | typing a character cancels the request." | |
203 | (interactive (let ((keys (this-command-keys))) | |
204 | (list (elt keys (1- (length keys))) | |
205 | (if mark-active (region-beginning)) | |
206 | (if mark-active (region-end))))) | |
207 | (if start | |
208 | (put-text-property start end 'face face) | |
209 | (setq facemenu-next face facemenu-loc (point)))) | |
210 | ||
211 | (defun facemenu-set-invisible (start end) | |
212 | "Make the region invisible. | |
213 | This sets the `invisible' text property; it can be undone with | |
214 | `facemenu-remove-all'." | |
215 | (interactive "r") | |
216 | (put-text-property start end 'invisible t)) | |
217 | ||
218 | (defun facemenu-set-intangible (start end) | |
219 | "Make the region intangible: disallow moving into it. | |
220 | This sets the `intangible' text property; it can be undone with | |
221 | `facemenu-remove-all'." | |
222 | (interactive "r") | |
223 | (put-text-property start end 'intangible t)) | |
224 | ||
225 | (defun facemenu-set-read-only (start end) | |
226 | "Make the region unmodifiable. | |
227 | This sets the `read-only' text property; it can be undone with | |
228 | `facemenu-remove-all'." | |
229 | (interactive "r") | |
230 | (put-text-property start end 'read-only t)) | |
231 | ||
232 | (defun facemenu-remove-all (start end) | |
233 | "Remove all text properties that facemenu added to region." | |
234 | (interactive "*r") ; error if buffer is read-only despite the next line. | |
235 | (let ((inhibit-read-only t)) | |
236 | (remove-text-properties | |
237 | start end '(face nil invisible nil intangible nil | |
238 | read-only nil category nil)))) | |
239 | ||
240 | (defun facemenu-after-change (begin end old-length) | |
241 | "May set the face of just-inserted text to user's request. | |
242 | This only happens if the change is an insertion, and | |
243 | `facemenu-set-face[-from-menu]' was called with point at the | |
244 | beginning of the insertion." | |
245 | (if (null facemenu-next) ; exit immediately if no work | |
246 | nil | |
247 | (if (and (= 0 old-length) ; insertion | |
248 | (= facemenu-loc begin)) ; point wasn't moved in between | |
249 | (put-text-property begin end 'face facemenu-next)) | |
250 | (setq facemenu-next nil))) | |
251 | ||
252 | ||
253 | (defun facemenu-complete-face-list (&optional oldlist) | |
254 | "Return alist of all faces that are look different. | |
255 | Starts with given LIST of faces, and adds elements only if they display | |
256 | differently from any face already on the list. | |
257 | The original LIST will end up at the end of the returned list, in reverse | |
258 | order. The elements added will have null cdrs." | |
259 | (let ((list nil)) | |
260 | (facemenu-iterate | |
261 | (function | |
262 | (lambda (item) | |
263 | (if (internal-find-face (car item)) | |
264 | (setq list (cons item list))) | |
265 | nil)) | |
266 | oldlist) | |
267 | (facemenu-iterate | |
268 | (function | |
269 | (lambda (new-face) | |
270 | (if (not (facemenu-iterate | |
271 | (function | |
272 | (lambda (item) (face-equal (car item) new-face t))) | |
273 | list)) | |
274 | (setq list (cons (cons new-face nil) list))) | |
275 | nil)) | |
276 | (nreverse (face-list))) | |
277 | list)) | |
278 | ||
279 | (defun facemenu-iterate (func iterate-list) | |
280 | "Apply FUNC to each element of LIST until one returns non-nil. | |
281 | Returns the non-nil value it found, or nil if all were nil." | |
282 | (while (and iterate-list (not (funcall func (car iterate-list)))) | |
283 | (setq iterate-list (cdr iterate-list))) | |
284 | (car iterate-list)) | |
285 | ||
286 | (facemenu-update) | |
287 | (add-hook 'menu-bar-final-items 'Face) | |
288 | (add-hook 'after-change-functions 'facemenu-after-change) | |
289 | ||
290 | ;;; facemenu.el ends here | |
291 |