Mercurial > hg > xemacs-beta

comparison lisp/utils/facemenu.el @ 100:4be1180a9e89 r20-1b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b2
author cvs
date Mon, 13 Aug 2007 09:15:11 +0200
parents c7528f8e288d
children 1370575f1259
comparison
equal deleted inserted replaced
99:2d83cbd90d8d 100:4be1180a9e89
1 ;;; facemenu.el --- create a face menu for interactively adding fonts to text 1 ;;; facemenu.el --- create a face menu for interactively adding fonts to text
2 ;; Copyright (c) 1994, 1995 Free Software Foundation, Inc. 2 ;; Copyright (c) 1994, 1995, 1996 Free Software Foundation, Inc.
3 3
4 ;; XEmacs version: Mike Sperber <sperber@informatik.uni-tuebingen.de> 4 ;; XEmacs version: Mike Sperber <sperber@informatik.uni-tuebingen.de>
5 ;; Original author: Boris Goldowsky <boris@gnu.ai.mit.edu> 5 ;; Original author: Boris Goldowsky <boris@gnu.ai.mit.edu>
6 ;; Keywords: faces 6 ;; Keywords: faces
7 7
20 ;; You should have received a copy of the GNU General Public License 20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; 02111-1307, USA. 23 ;; 02111-1307, USA.
24 24
25 ;;; Synched up with: FSF 19.30. 25 ;;; Synched up with: FSF 19.34.
26 26
27 ;;; Commentary: 27 ;;; Commentary:
28
28 ;; This file defines a menu of faces (bold, italic, etc) which allows you to 29 ;; This file defines a menu of faces (bold, italic, etc) which allows you to
29 ;; set the face used for a region of the buffer. Some faces also have 30 ;; set the face used for a region of the buffer. Some faces also have
30 ;; keybindings, which are shown in the menu. Faces with names beginning with 31 ;; keybindings, which are shown in the menu. Faces with names beginning with
31 ;; "fg:" or "bg:", as in "fg:red", are treated specially. 32 ;; "fg:" or "bg:", as in "fg:red", are treated specially.
32 ;; Such faces are assumed to consist only of a foreground (if "fg:") or 33 ;; Such faces are assumed to consist only of a foreground (if "fg:") or
36 ;; "Foreground" and "Background" submenus. 37 ;; "Foreground" and "Background" submenus.
37 ;; 38 ;;
38 ;; The menu also contains submenus for indentation and justification-changing 39 ;; The menu also contains submenus for indentation and justification-changing
39 ;; commands. 40 ;; commands.
40 41
41 ;;; Installation:
42 ;; Just do a (require 'facemenu).
43 ;; If you want the menu bound to a mouse button under XEmacs, do
44 ;; (define-key global-map '(control button2) 'facemenu-menu)
45
46 ;;; Usage: 42 ;;; Usage:
47 ;; Selecting a face from the menu or typing the keyboard equivalent will 43 ;; Selecting a face from the menu or typing the keyboard equivalent will
48 ;; change the region to use that face. If you use transient-mark-mode and the 44 ;; change the region to use that face. If you use transient-mark-mode and the
49 ;; region is not active, the face will be remembered and used for the next 45 ;; region is not active, the face will be remembered and used for the next
50 ;; insertion. It will be forgotten if you move point or make other 46 ;; insertion. It will be forgotten if you move point or make other
52 ;; 48 ;;
53 ;; Faces can be selected from the keyboard as well. 49 ;; Faces can be selected from the keyboard as well.
54 ;; The standard keybindings are M-g (or ESC g) + letter: 50 ;; The standard keybindings are M-g (or ESC g) + letter:
55 ;; M-g i = "set italic", M-g b = "set bold", etc. 51 ;; M-g i = "set italic", M-g b = "set bold", etc.
56 52
53 ;;; Customization:
54 ;; An alternative set of keybindings that may be easier to type can be set up
55 ;; using "Alt" or "Hyper" keys. This requires that you either have or create
56 ;; an Alt or Hyper key on your keyboard. On my keyboard, there is a key
57 ;; labeled "Alt", but to make it act as an Alt key I have to put this command
58 ;; into my .xinitrc:
59 ;; xmodmap -e "add Mod3 = Alt_L"
60 ;; Or, I can make it into a Hyper key with this:
61 ;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L"
62 ;; Check with local X-perts for how to do it on your system.
63 ;; Then you can define your keybindings with code like this in your .emacs:
64 ;; (setq facemenu-keybindings
65 ;; '((default . [?\H-d])
66 ;; (bold . [?\H-b])
67 ;; (italic . [?\H-i])
68 ;; (bold-italic . [?\H-l])
69 ;; (underline . [?\H-u])))
70 ;; (setq facemenu-keymap global-map)
71 ;; (setq facemenu-key nil)
72 ;; (define-key global-map [?\H-c] 'facemenu-set-foreground) ; set fg color
73 ;; (define-key global-map [?\H-C] 'facemenu-set-background) ; set bg color
74 ;; (require 'facemenu)
57 ;; 75 ;;
58 ;; The order of the faces that appear in the menu and their keybindings can be 76 ;; The order of the faces that appear in the menu and their keybindings can be
59 ;; controlled by setting the variables `facemenu-keybindings' and 77 ;; controlled by setting the variables `facemenu-keybindings' and
60 ;; `facemenu-new-faces-at-end'. List faces that you don't use in documents 78 ;; `facemenu-new-faces-at-end'. List faces that you don't use in documents
61 ;; (eg, `region') in `facemenu-unlisted-faces'. 79 ;; (eg, `region') in `facemenu-unlisted-faces'.
77 95
78 ;;; Code: 96 ;;; Code:
79 97
80 (provide 'facemenu) 98 (provide 'facemenu)
81 99
100 ;; XEmacs
82 (require 'easymenu) 101 (require 'easymenu)
83 102
84 ;;; Provide some binding for startup: 103 ;;; Provide some binding for startup:
85 ;;; XEmacs -- goto-line is a *much* better binding for M-g. 104 ;;; XEmacs -- goto-line is a *much* better binding for M-g.
86 ;;;dont ###autoload (define-key global-map "\M-g" 'facemenu-keymap) 105 ;;;dont ###autoload (define-key global-map "\M-g" 'facemenu-keymap)
110 (defvar facemenu-new-faces-at-end t 129 (defvar facemenu-new-faces-at-end t
111 "Where in the menu to insert newly-created faces. 130 "Where in the menu to insert newly-created faces.
112 This should be nil to put them at the top of the menu, or t to put them 131 This should be nil to put them at the top of the menu, or t to put them
113 just before \"Other\" at the end.") 132 just before \"Other\" at the end.")
114 133
134 ;; XEmacs -- additional faces
115 (defvar facemenu-unlisted-faces 135 (defvar facemenu-unlisted-faces
116 '(modeline region secondary-selection highlight scratch-face 136 '(modeline region secondary-selection highlight scratch-face
117 gui-button-face isearch hyperlink 137 gui-button-face isearch hyperlink
118 modeline modeline-buffer-id modeline-mousable modeline-mousable-minor-mode 138 modeline modeline-buffer-id modeline-mousable modeline-mousable-minor-mode
119 pointer primary-selection secondary-selection list-mode-item-selected 139 pointer primary-selection secondary-selection list-mode-item-selected
213 "Keymap for face-changing commands. 233 "Keymap for face-changing commands.
214 `Facemenu-update' fills in the keymap according to the bindings 234 `Facemenu-update' fills in the keymap according to the bindings
215 requested in `facemenu-keybindings'.") 235 requested in `facemenu-keybindings'.")
216 (defalias 'facemenu-keymap facemenu-keymap) 236 (defalias 'facemenu-keymap facemenu-keymap)
217 237
238
239 (defvar facemenu-add-face-function nil
240 "Function called at beginning of text to change or `nil'.
241 This function is passed the FACE to set and END of text to change, and must
242 return a string which is inserted. It may set `facemenu-end-add-face'.")
243
244 (defvar facemenu-end-add-face nil
245 "String to insert or function called at end of text to change or `nil'.
246 This function is passed the FACE to set, and must return a string which is
247 inserted.")
248
249 (defvar facemenu-remove-face-function nil
250 "When non-`nil' function called to remove faces.
251 This function is passed the START and END of text to change.
252 May also be `t' meaning to use `facemenu-add-face-function'.")
253
218 ;;; Internal Variables 254 ;;; Internal Variables
219 255
220 (defvar facemenu-color-alist nil 256 (defvar facemenu-color-alist nil
221 ;; Don't initialize here; that doesn't work if preloaded. 257 ;; Don't initialize here; that doesn't work if preloaded.
222 "Alist of colors, used for completion. 258 "Alist of colors, used for completion.
258 294
259 Otherwise, this command specifies the face for the next character 295 Otherwise, this command specifies the face for the next character
260 inserted. Moving point or switching buffers before 296 inserted. Moving point or switching buffers before
261 typing a character to insert cancels the specification." 297 typing a character to insert cancels the specification."
262 (interactive (list (read-face-name "Use face: "))) 298 (interactive (list (read-face-name "Use face: ")))
263 (setq zmacs-region-stays t) 299 (setq zmacs-region-stays t) ; XEmacs
264 (barf-if-buffer-read-only) 300 (barf-if-buffer-read-only)
265 (facemenu-add-new-face face) 301 (facemenu-add-new-face face)
266 (facemenu-update-facemenu-menu) 302 (facemenu-update-facemenu-menu) ; XEmacs
267 (if (and (facemenu-region-active-p) 303 (if (and (facemenu-region-active-p)
268 (not current-prefix-arg)) 304 (not current-prefix-arg))
269 (let ((start (or start (region-beginning))) 305 (let ((start (or start (region-beginning)))
270 (end (or end (region-end)))) 306 (end (or end (region-end))))
271 (facemenu-add-face face start end)) 307 (facemenu-add-face face start end))
302 (or (facemenu-get-face face) 338 (or (facemenu-get-face face)
303 (error "Unknown color: %s" color)) 339 (error "Unknown color: %s" color))
304 (facemenu-set-face face start end))) 340 (facemenu-set-face face start end)))
305 341
306 ;;;###autoload 342 ;;;###autoload
307 (defun facemenu-set-face-from-menu (face) 343 (defun facemenu-set-face-from-menu (face start end)
308 "Set the face of the region or next character typed. 344 "Set the face of the region or next character typed.
309 This function is designed to be called from a menu; the face to use 345 This function is designed to be called from a menu; the face to use
310 is the menu item's name. 346 is the menu item's name.
311 347
312 If the region is active and there is no prefix argument, 348 If the region is active and there is no prefix argument,
313 this command sets the region to the requested face. 349 this command sets the region to the requested face.
314 350
315 Otherwise, this command specifies the face for the next character 351 Otherwise, this command specifies the face for the next character
316 inserted. Moving point or switching buffers before 352 inserted. Moving point or switching buffers before
317 typing a character to insert cancels the specification." 353 typing a character to insert cancels the specification."
318 (let ((start (if (and (facemenu-region-active-p) 354 (interactive (list last-command-event
319 (not current-prefix-arg)) 355 (if (and (facemenu-region-active-p)
320 (region-beginning))) 356 (not current-prefix-arg))
321 (end (if (and (facemenu-region-active-p) 357 (region-beginning))
322 (not current-prefix-arg)) 358 (if (and (facemenu-region-active-p)
323 (region-end)))) 359 (not current-prefix-arg))
324 (barf-if-buffer-read-only) 360 (region-end))))
325 (setq zmacs-region-stays t) 361 (barf-if-buffer-read-only)
326 (facemenu-get-face face) 362 (setq zmacs-region-stays t) ; XEmacs
327 (if start 363 (facemenu-get-face face)
328 (facemenu-add-face face start end) 364 (if start
329 (facemenu-self-insert-face face)))) 365 (facemenu-add-face face start end)
330 366 (facemenu-self-insert-face face))) ; XEmacs
367
368 ;; XEmacs
331 (defun facemenu-self-insert-face (face) 369 (defun facemenu-self-insert-face (face)
332 (setq self-insert-face (cond 370 (setq self-insert-face (cond
333 ((null self-insert-face) face) 371 ((null self-insert-face) face)
334 ((consp self-insert-face) 372 ((consp self-insert-face)
335 (facemenu-active-faces (cons face self-insert-face))) 373 (facemenu-active-faces (cons face self-insert-face)))
415 ((consp face) (mapcar 453 ((consp face) (mapcar
416 #'(lambda (face) 454 #'(lambda (face)
417 (facemenu-sized-face (facemenu-face-strip-size face) 455 (facemenu-sized-face (facemenu-face-strip-size face)
418 size)) 456 size))
419 face)) 457 face))
420 (t (facemenu-sized-face face size)))) 458 ;;[BV 9-Feb-97] strip-face from this face too, please!
459 (t (facemenu-sized-face (facemenu-face-strip-size face) size))))
421 460
422 (defun facemenu-adjust-size (from to) 461 (defun facemenu-adjust-size (from to)
423 "Adjust the size of the text between FROM and TO according 462 "Adjust the size of the text between FROM and TO according
424 to the values of the 'size property in that region." 463 to the values of the 'size property in that region."
425 (let ((pos from) 464 (let ((pos from)
458 ;;;###autoload 497 ;;;###autoload
459 (defun facemenu-set-invisible (start end) 498 (defun facemenu-set-invisible (start end)
460 "Make the region invisible. 499 "Make the region invisible.
461 This sets the `invisible' text property; it can be undone with 500 This sets the `invisible' text property; it can be undone with
462 `facemenu-remove-special'." 501 `facemenu-remove-special'."
463 (interactive "r") 502 (interactive "_r")
464 (put-text-property start end 'invisible t)) 503 (put-text-property start end 'invisible t))
465 504
466 ;;;###autoload 505 ;;;###autoload
467 (defun facemenu-set-intangible (start end) 506 (defun facemenu-set-intangible (start end)
468 "Make the region intangible: disallow moving into it. 507 "Make the region intangible: disallow moving into it.
469 This sets the `intangible' text property; it can be undone with 508 This sets the `intangible' text property; it can be undone with
470 `facemenu-remove-special'." 509 `facemenu-remove-special'."
471 (interactive "r") 510 (interactive "_r")
472 (put-text-property start end 'intangible t)) 511 (put-text-property start end 'intangible t))
473 512
474 ;;;###autoload 513 ;;;###autoload
475 (defun facemenu-set-read-only (start end) 514 (defun facemenu-set-read-only (start end)
476 "Make the region unmodifiable. 515 "Make the region unmodifiable.
477 This sets the `read-only' text property; it can be undone with 516 This sets the `read-only' text property; it can be undone with
478 `facemenu-remove-special'." 517 `facemenu-remove-special'."
479 (interactive "r") 518 (interactive "_r")
480 (put-text-property start end 'read-only t)) 519 (put-text-property start end 'read-only t))
481 520
482 ;;;###autoload 521 ;;;###autoload
483 (defun facemenu-remove-props (start end) 522 (defun facemenu-remove-props (start end)
484 "Remove all text properties that facemenu added to region." 523 "Remove all text properties that facemenu added to region."
499 538
500 ;;;###autoload 539 ;;;###autoload
501 (defun list-text-properties-at (p) 540 (defun list-text-properties-at (p)
502 "Pop up a buffer listing text-properties at LOCATION." 541 "Pop up a buffer listing text-properties at LOCATION."
503 (interactive "d") 542 (interactive "d")
504 (let ((props (text-properties-at p))) 543 (let ((props (text-properties-at p))
544 category
545 str)
505 (if (null props) 546 (if (null props)
506 (message "None") 547 (message "None")
507 (with-output-to-temp-buffer "*Text Properties*" 548 (if (and (not (cdr (cdr props)))
508 (princ (format "Text properties at %d:\n\n" p)) 549 (not (eq (car props) 'category))
509 (while props 550 (< (length (setq str (format "Text property at %d: %s %S"
510 (princ (format "%-20s %S\n" 551 p (car props) (car (cdr props)))))
511 (car props) (car (cdr props)))) 552 (frame-width)))
512 (setq props (cdr (cdr props)))))))) 553 (message "%s" str)
554 (with-output-to-temp-buffer "*Text Properties*"
555 (princ (format "Text properties at %d:\n\n" p))
556 (while props
557 (if (eq (car props) 'category)
558 (setq category (car (cdr props))))
559 (princ (format "%-20s %S\n"
560 (car props) (car (cdr props))))
561 (setq props (cdr (cdr props))))
562 (if category
563 (progn
564 (setq props (symbol-plist category))
565 (princ (format "\nCategory %s:\n\n" category))
566 (while props
567 (princ (format "%-20s %S\n"
568 (car props) (car (cdr props))))
569 (if (eq (car props) 'category)
570 (setq category (car (cdr props))))
571 (setq props (cdr (cdr props)))))))))))
513 572
514 ;;;###autoload 573 ;;;###autoload
515 (defun facemenu-read-color (&optional prompt) 574 (defun facemenu-read-color (&optional prompt)
516 "Read a color using the minibuffer." 575 "Read a color using the minibuffer."
517 (if (string-match "XEmacs" emacs-version) 576 (if (string-match "XEmacs" emacs-version)
594 determine the correct answer." 653 determine the correct answer."
595 (cond ((equal a b) t) 654 (cond ((equal a b) t)
596 ((and (equal (facemenu-color-values a) 655 ((and (equal (facemenu-color-values a)
597 (facemenu-color-values b)))))) 656 (facemenu-color-values b))))))
598 657
599 (defun facemenu-add-face (face start end) 658 (defun facemenu-add-face (face &optional start end)
600 "Add FACE to text between START and END. 659 "Add FACE to text between START and END.
601 For each section of that region that has a different face property, FACE will 660 For each section of that region that has a different face property, FACE will
602 be consed onto it, and other faces that are completely hidden by that will be 661 be consed onto it, and other faces that are completely hidden by that will be
603 removed from the list. 662 removed from the list.
604 663
605 As a special case, if FACE is `default', then the region is left with NO face 664 As a special case, if FACE is `default', then the region is left with NO face
606 text property. Otherwise, selecting the default face would not have any 665 text property. Otherwise, selecting the default face would not have any
607 effect." 666 effect."
608 (interactive "*_xFace:\nr") 667 (interactive "*_xFace:\nr")
609 (if (eq face 'default) 668 (if (and (eq face 'default)
610 (remove-text-properties start end '(face default)) 669 (not (eq facemenu-remove-face-function t)))
611 (let ((part-start start) part-end) 670 (if facemenu-remove-face-function
612 (while (not (= part-start end)) 671 (funcall facemenu-remove-face-function start end)
613 (setq part-end (next-single-property-change part-start 'face nil end)) 672 (if (and start (< start end))
614 (let* ((prev (get-text-property part-start 'face)) 673 (remove-text-properties start end '(face default))
615 (size (get-text-property part-start 'size)) 674 (setq self-insert-face 'default
616 (face (if size (facemenu-sized-face face size) face))) 675 self-insert-face-command this-command)))
617 (put-text-property part-start part-end 'face 676 (if facemenu-add-face-function
618 (if (null prev) 677 (save-excursion
619 face 678 (if end (goto-char end))
620 (facemenu-active-faces 679 (save-excursion
621 (cons face 680 (if start (goto-char start))
622 (if (listp prev) prev (list prev))))))) 681 (insert-before-markers
623 (setq part-start part-end))))) 682 (funcall facemenu-add-face-function face end)))
624 683 (if facemenu-end-add-face
684 (insert (if (stringp facemenu-end-add-face)
685 facemenu-end-add-face
686 (funcall facemenu-end-add-face face)))))
687 (if (and start (< start end))
688 (let ((part-start start) part-end)
689 (while (not (= part-start end))
690 (setq part-end (next-single-property-change part-start 'face
691 nil end))
692 (let ((prev (get-text-property part-start 'face)))
693 (put-text-property part-start part-end 'face
694 (if (null prev)
695 face
696 (facemenu-active-faces
697 (cons face
698 (if (listp prev)
699 prev
700 (list prev)))))))
701 (setq part-start part-end)))
702 (setq self-insert-face (if (eq last-command self-insert-face-command)
703 (cons face (if (listp self-insert-face)
704 self-insert-face
705 (list self-insert-face)))
706 face)
707 self-insert-face-command this-command)))))
708
709 ;; XEmacs
625 (defun facemenu-face-attributes (face) 710 (defun facemenu-face-attributes (face)
626 "Create a vector of the relevant face attributes of face FACE." 711 "Create a vector of the relevant face attributes of face FACE."
627 (if (string-match "XEmacs" emacs-version) 712 (if (string-match "XEmacs" emacs-version)
628 (apply 'vector (mapcar #'(lambda (prop) 713 (apply 'vector (mapcar #'(lambda (prop)
629 (face-property-instance face prop)) 714 (face-property-instance face prop))