Mercurial > emacs
comparison lisp/facemenu.el @ 9494:9a4ed505445e
(facemenu-read-color, facemenu-colors): New fn, var.
(facemenu-set-face, facemenu-set-face-from-menu,
facemenu-after-change): Face property can take a list value; add
to it rather than completely replacing the property.
(facemenu-add-face, facemenu-discard-redundant-faces): New functions.
(facemenu-set-foreground, facemenu-set-background)
(facemenu-get-face, facemenu-foreground, facemenu-background): New
functions and variables. Faces with names of the form fg:color
and bg:color are now treated specially.
(facemenu-update): Updated for above.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Wed, 12 Oct 1994 23:23:23 +0000 |
parents | 231a4d114799 |
children | fe1c170fa35a |
comparison
equal
deleted
inserted
replaced
9493:0160fca3dee1 | 9494:9a4ed505445e |
---|---|
63 ;; keybindings can be controlled by setting the variable | 63 ;; keybindings can be controlled by setting the variable |
64 ;; `facemenu-keybindings'. Faces that you never want to add to your | 64 ;; `facemenu-keybindings'. Faces that you never want to add to your |
65 ;; document (e.g., `region') are listed in `facemenu-unlisted-faces'. | 65 ;; document (e.g., `region') are listed in `facemenu-unlisted-faces'. |
66 | 66 |
67 ;;; Known Problems: | 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 | 68 ;; There is at present no way to display what the faces look like in |
71 ;; the menu itself. | 69 ;; the menu itself. |
72 ;; | 70 ;; |
73 ;; `list-faces-display' shows the faces in a different order than | 71 ;; `list-faces-display' shows the faces in a different order than |
74 ;; this menu, which could be confusing. I do /not/ sort the list | 72 ;; this menu, which could be confusing. I do /not/ sort the list |
113 '(modeline region secondary-selection highlight scratch-face) | 111 '(modeline region secondary-selection highlight scratch-face) |
114 "Faces that are not included in the Face menu. | 112 "Faces that are not included in the Face menu. |
115 Set this before loading facemenu.el, or call `facemenu-update' after | 113 Set this before loading facemenu.el, or call `facemenu-update' after |
116 changing it.") | 114 changing it.") |
117 | 115 |
116 (defvar facemenu-colors | |
117 (if (eq 'x window-system) | |
118 (mapcar 'list (x-defined-colors))) | |
119 "Alist of colors, used for completion.") | |
120 | |
118 (defvar facemenu-next nil) ; set when we are going to set a face on next char. | 121 (defvar facemenu-next nil) ; set when we are going to set a face on next char. |
119 (defvar facemenu-loc nil) | 122 (defvar facemenu-loc nil) |
123 | |
124 (defalias 'facemenu-foreground (make-sparse-keymap "Foreground")) | |
125 (defalias 'facemenu-background (make-sparse-keymap "Background")) | |
120 | 126 |
121 (defun facemenu-update () | 127 (defun facemenu-update () |
122 "Add or update the \"Face\" menu in the menu bar." | 128 "Add or update the \"Face\" menu in the menu bar." |
123 (interactive) | 129 (interactive) |
124 | 130 |
132 | 138 |
133 ;; Define basic keys | 139 ;; Define basic keys |
134 ;; We construct this list structure explicitly because a quoted constant | 140 ;; We construct this list structure explicitly because a quoted constant |
135 ;; would be pure. | 141 ;; would be pure. |
136 (define-key facemenu-menu [update] (cons "Update Menu" 'facemenu-update)) | 142 (define-key facemenu-menu [update] (cons "Update Menu" 'facemenu-update)) |
137 (define-key facemenu-menu [display] (cons "Display" 'list-faces-display)) | 143 (define-key facemenu-menu [display] (cons "Display Faces" |
144 'list-faces-display)) | |
138 (define-key facemenu-menu [sep1] (list "-------------")) | 145 (define-key facemenu-menu [sep1] (list "-------------")) |
139 (define-key facemenu-menu [remove] (cons "Remove Properties" | 146 (define-key facemenu-menu [remove] (cons "Remove Properties" |
140 'facemenu-remove-all)) | 147 'facemenu-remove-all)) |
141 (define-key facemenu-menu [read-only] (cons "Read-Only" | 148 (define-key facemenu-menu [read-only] (cons "Read-Only" |
142 'facemenu-set-read-only)) | 149 'facemenu-set-read-only)) |
143 (define-key facemenu-menu [invisible] (cons "Invisible" | 150 (define-key facemenu-menu [invisible] (cons "Invisible" |
144 'facemenu-set-invisible)) | 151 'facemenu-set-invisible)) |
145 (define-key facemenu-menu [sep2] (list "-------------")) | 152 (define-key facemenu-menu [sep2] (list "-------------")) |
153 (define-key facemenu-menu [bg] (cons "Background Color" | |
154 'facemenu-background)) | |
155 (define-key facemenu-menu [fg] (cons "Foreground Color" | |
156 'facemenu-foreground)) | |
157 (define-key facemenu-menu [sep3] (list "-------------")) | |
146 (define-key facemenu-menu [other] (cons "Other..." 'facemenu-set-face)) | 158 (define-key facemenu-menu [other] (cons "Other..." 'facemenu-set-face)) |
159 | |
160 (define-key 'facemenu-foreground "o" (cons "Other" 'facemenu-set-foreground)) | |
161 (define-key 'facemenu-background "o" (cons "Other" 'facemenu-set-background)) | |
147 | 162 |
148 ;; Define commands for face-changing | 163 ;; Define commands for face-changing |
149 (facemenu-iterate | 164 (facemenu-iterate |
150 (function | 165 (lambda (f) |
151 (lambda (f) | 166 (let* ((face (car f)) |
152 (let ((face (car f)) | 167 (name (symbol-name face)) |
153 (name (symbol-name (car f))) | 168 (key (cdr f)) |
154 (key (cdr f))) | 169 (menu (cond ((string-match "^fg:" name) 'facemenu-foreground) |
155 (cond ((memq face facemenu-unlisted-faces) | 170 ((string-match "^bg:" name) 'facemenu-background) |
156 nil) | 171 (t facemenu-menu)))) |
157 ((null key) (define-key facemenu-menu (vector face) | 172 (if (memq menu '(facemenu-foreground facemenu-background)) |
158 (cons name 'facemenu-set-face-from-menu))) | 173 (setq name (substring name 3))) |
159 (t (let ((function (intern (concat "facemenu-set-" name)))) | 174 (cond ((memq face facemenu-unlisted-faces) |
160 (fset function | 175 nil) |
161 (` (lambda () (interactive) | 176 ((null key) (define-key menu (vector face) |
162 (facemenu-set-face (quote (, face)))))) | 177 (cons name 'facemenu-set-face-from-menu))) |
163 (define-key facemenu-keymap key (cons name function)) | 178 (t (let ((function (intern (concat "facemenu-set-" name)))) |
164 (define-key facemenu-menu key (cons name function)))))) | 179 (fset function |
165 nil)) | 180 (` (lambda () (interactive) |
181 (facemenu-set-face (quote (, face)))))) | |
182 (define-key facemenu-keymap key (cons name function)) | |
183 (define-key menu key (cons name function)))))) | |
184 nil) | |
166 (facemenu-complete-face-list facemenu-keybindings)) | 185 (facemenu-complete-face-list facemenu-keybindings)) |
167 | 186 |
168 (define-key global-map (vector 'menu-bar 'Face) | 187 (define-key global-map (vector 'menu-bar 'Face) |
169 (cons "Face" facemenu-menu))) | 188 (cons "Face" facemenu-menu))) |
170 | 189 |
174 ; (put-text-property 0 (1- (length s)) | 193 ; (put-text-property 0 (1- (length s)) |
175 ; 'face face s) | 194 ; 'face face s) |
176 ; s) | 195 ; s) |
177 | 196 |
178 ;;;###autoload | 197 ;;;###autoload |
198 (defun facemenu-read-color (prompt) | |
199 "Read a color using the minibuffer." | |
200 (let ((col (completing-read (or "Color: ") facemenu-colors nil t))) | |
201 (if (equal "" col) | |
202 nil | |
203 col))) | |
204 | |
205 ;;;###autoload | |
179 (defun facemenu-set-face (face &optional start end) | 206 (defun facemenu-set-face (face &optional start end) |
180 "Set the face of the region or next character typed. | 207 "Add FACE to the region or next character typed. |
181 The face to be used is prompted for. | 208 It will be added to the top of the face list; any faces lower on the list that |
182 If the region is active, it will be set to the requested face. If | 209 will not show through at all will be removed. |
210 | |
211 Interactively, the face to be used is prompted for. | |
212 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 | 213 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 | 214 character that is typed \(via `self-insert-command') will be set to |
185 the the selected face. Moving point or switching buffers before | 215 the the selected face. Moving point or switching buffers before |
186 typing a character cancels the request." | 216 typing a character cancels the request." |
187 (interactive (list (read-face-name "Use face: "))) | 217 (interactive (list (read-face-name "Use face: "))) |
188 (if mark-active | 218 (if mark-active |
189 (put-text-property (or start (region-beginning)) | 219 (let ((start (or start (region-beginning))) |
190 (or end (region-end)) | 220 (end (or end (region-end)))) |
191 'face face) | 221 (facemenu-add-face face start end)) |
192 (setq facemenu-next face facemenu-loc (point)))) | 222 (setq facemenu-next face |
223 facemenu-loc (point)))) | |
224 | |
225 (defun facemenu-set-foreground (color &optional start end) | |
226 "Set the foreground color of the region or next character typed. | |
227 The color is prompted for. A face named `fg:color' is used \(or created). | |
228 If the region is active, it will be set to the requested face. If | |
229 it is inactive \(even if mark-even-if-inactive is set) the next | |
230 character that is typed \(via `self-insert-command') will be set to | |
231 the the selected face. Moving point or switching buffers before | |
232 typing a character cancels the request." | |
233 (interactive (list (facemenu-read-color "Foreground color: "))) | |
234 (let ((face (intern (concat "fg:" color)))) | |
235 (or (facemenu-get-face face) | |
236 (error "Unknown color: %s" color)) | |
237 (facemenu-set-face face start end))) | |
238 | |
239 (defun facemenu-set-background (color &optional start end) | |
240 "Set the background color of the region or next character typed. | |
241 The color is prompted for. A face named `bg:color' is used \(or created). | |
242 If the region is active, it will be set to the requested face. If | |
243 it is inactive \(even if mark-even-if-inactive is set) the next | |
244 character that is typed \(via `self-insert-command') will be set to | |
245 the the selected face. Moving point or switching buffers before | |
246 typing a character cancels the request." | |
247 (interactive (list (facemenu-read-color "Background color: "))) | |
248 (let ((face (intern (concat "bg:" color)))) | |
249 (or (facemenu-get-face face) | |
250 (error "Unknown color: %s" color)) | |
251 (facemenu-set-face face start end))) | |
193 | 252 |
194 (defun facemenu-set-face-from-menu (face start end) | 253 (defun facemenu-set-face-from-menu (face start end) |
195 "Set the face of the region or next character typed. | 254 "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 | 255 This function is designed to be called from a menu; the face to use |
197 is the menu item's name. | 256 is the menu item's name. |
198 If the region is active, it will be set to the requested face. If | 257 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 | 258 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 | 259 character that is typed \(via `self-insert-command') will be set to |
201 the the selected face. Moving point or switching buffers before | 260 the the selected face. Moving point or switching buffers before |
202 typing a character cancels the request." | 261 typing a character cancels the request." |
203 (interactive (let ((keys (this-command-keys))) | 262 (interactive (list last-command-event |
204 (list (elt keys (1- (length keys))) | 263 (if mark-active (region-beginning)) |
205 (if mark-active (region-beginning)) | 264 (if mark-active (region-end)))) |
206 (if mark-active (region-end))))) | 265 (facemenu-get-face face) |
207 (if start | 266 (if start |
208 (put-text-property start end 'face face) | 267 (facemenu-add-face face start end) |
209 (setq facemenu-next face facemenu-loc (point)))) | 268 (setq facemenu-next face facemenu-loc (point)))) |
210 | 269 |
211 (defun facemenu-set-invisible (start end) | 270 (defun facemenu-set-invisible (start end) |
212 "Make the region invisible. | 271 "Make the region invisible. |
213 This sets the `invisible' text property; it can be undone with | 272 This sets the `invisible' text property; it can be undone with |
234 (interactive "*r") ; error if buffer is read-only despite the next line. | 293 (interactive "*r") ; error if buffer is read-only despite the next line. |
235 (let ((inhibit-read-only t)) | 294 (let ((inhibit-read-only t)) |
236 (remove-text-properties | 295 (remove-text-properties |
237 start end '(face nil invisible nil intangible nil | 296 start end '(face nil invisible nil intangible nil |
238 read-only nil category nil)))) | 297 read-only nil category nil)))) |
298 | |
299 (defun facemenu-get-face (face) | |
300 "Make sure FACE exists. | |
301 If not, it is created. If it is created and is of the form `fg:color', then | |
302 set the foreground to that color. If of the form `bg:color', set the | |
303 background. In any case, add it to the appropriate menu. Returns nil if | |
304 given a bad color." | |
305 (if (internal-find-face face) | |
306 t | |
307 (make-face face) | |
308 (let* ((name (symbol-name face)) | |
309 (color (substring name 3))) | |
310 (cond ((string-match "^fg:" name) | |
311 (set-face-foreground face color) | |
312 (define-key 'facemenu-foreground (vector face) | |
313 (cons color 'facemenu-set-face-from-menu)) | |
314 (x-color-defined-p color)) | |
315 ((string-match "^bg:" name) | |
316 (set-face-background face color) | |
317 (define-key 'facemenu-background (vector face) | |
318 (cons color 'facemenu-set-face-from-menu)) | |
319 (x-color-defined-p color)) | |
320 (t | |
321 (define-key facemenu-menu (vector face) | |
322 (cons name 'facemenu-set-face-from-menu)) | |
323 t))))) | |
239 | 324 |
240 (defun facemenu-after-change (begin end old-length) | 325 (defun facemenu-after-change (begin end old-length) |
241 "May set the face of just-inserted text to user's request. | 326 "May set the face of just-inserted text to user's request. |
242 This only happens if the change is an insertion, and | 327 This only happens if the change is an insertion, and |
243 `facemenu-set-face[-from-menu]' was called with point at the | 328 `facemenu-set-face[-from-menu]' was called with point at the |
244 beginning of the insertion." | 329 beginning of the insertion." |
245 (if (null facemenu-next) ; exit immediately if no work | 330 (if (null facemenu-next) ; exit immediately if no work |
246 nil | 331 nil |
247 (if (and (= 0 old-length) ; insertion | 332 (if (and (= 0 old-length) ; insertion |
248 (= facemenu-loc begin)) ; point wasn't moved in between | 333 (= facemenu-loc begin)) ; point wasn't moved in between |
249 (put-text-property begin end 'face facemenu-next)) | 334 (facemenu-add-face facemenu-next begin end)) |
250 (setq facemenu-next nil))) | 335 (setq facemenu-next nil))) |
251 | |
252 | 336 |
253 (defun facemenu-complete-face-list (&optional oldlist) | 337 (defun facemenu-complete-face-list (&optional oldlist) |
254 "Return alist of all faces that are look different. | 338 "Return alist of all faces that are look different. |
255 Starts with given LIST of faces, and adds elements only if they display | 339 Starts with given LIST of faces, and adds elements only if they display |
256 differently from any face already on the list. | 340 differently from any face already on the list. |
274 (setq list (cons (cons new-face nil) list))) | 358 (setq list (cons (cons new-face nil) list))) |
275 nil)) | 359 nil)) |
276 (nreverse (face-list))) | 360 (nreverse (face-list))) |
277 list)) | 361 list)) |
278 | 362 |
363 (defun facemenu-add-face (face start end) | |
364 "Add FACE to text between START and END. | |
365 For each section of that region that has a different face property, FACE will | |
366 be consed onto it, and other faces that are completely hidden by that will be | |
367 removed from the list." | |
368 (interactive "*xFace:\nr") | |
369 (let ((part-start start) part-end) | |
370 (while (not (= part-start end)) | |
371 (setq part-end (next-single-property-change part-start 'face nil end)) | |
372 (let ((prev (get-text-property part-start 'face))) | |
373 (put-text-property part-start part-end 'face | |
374 (if (null prev) | |
375 face | |
376 (facemenu-discard-redundant-faces | |
377 (cons face | |
378 (if (listp prev) prev (list prev))))))) | |
379 (setq part-start part-end)))) | |
380 | |
381 (defun facemenu-discard-redundant-faces (face-list &optional mask) | |
382 "Remove from FACE-LIST any faces that won't show at all. | |
383 This means they have no non-nil elements that aren't also non-nil in an | |
384 earlier face." | |
385 (let ((useful nil)) | |
386 (cond ((null face-list) nil) | |
387 ((null mask) | |
388 (cons (car face-list) | |
389 (facemenu-discard-redundant-faces | |
390 (cdr face-list) | |
391 (copy-sequence (internal-get-face (car face-list)))))) | |
392 ((let ((i (length mask)) | |
393 (face (internal-get-face (car face-list)))) | |
394 (while (>= (setq i (1- i)) 0) | |
395 (if (and (aref face i) | |
396 (not (aref mask i))) | |
397 (progn (setq useful t) | |
398 (aset mask i t)))) | |
399 useful) | |
400 (cons (car face-list) | |
401 (facemenu-discard-redundant-faces (cdr face-list) mask))) | |
402 (t (facemenu-discard-redundant-faces (cdr face-list) mask))))) | |
403 | |
279 (defun facemenu-iterate (func iterate-list) | 404 (defun facemenu-iterate (func iterate-list) |
280 "Apply FUNC to each element of LIST until one returns non-nil. | 405 "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." | 406 Returns the non-nil value it found, or nil if all were nil." |
282 (while (and iterate-list (not (funcall func (car iterate-list)))) | 407 (while (and iterate-list (not (funcall func (car iterate-list)))) |
283 (setq iterate-list (cdr iterate-list))) | 408 (setq iterate-list (cdr iterate-list))) |
286 (facemenu-update) | 411 (facemenu-update) |
287 (add-hook 'menu-bar-final-items 'Face) | 412 (add-hook 'menu-bar-final-items 'Face) |
288 (add-hook 'after-change-functions 'facemenu-after-change) | 413 (add-hook 'after-change-functions 'facemenu-after-change) |
289 | 414 |
290 ;;; facemenu.el ends here | 415 ;;; facemenu.el ends here |
291 |