/[emacs]/emacs/lisp/facemenu.el
ViewVC logotype

Diff of /emacs/lisp/facemenu.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.67 by miles, Thu May 9 18:04:27 2002 UTC revision 1.67.2.1 by miles, Fri Apr 4 06:20:04 2003 UTC
# Line 38  Line 38 
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    
# Line 86  Line 86 
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)
# Line 118  the binding is made in `facemenu-keymap' Line 116  the binding is made in `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
# Line 166  when they are created." Line 164  when they are created."
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)
# Line 184  when they are created." Line 182  when they are created."
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))
# Line 215  when they are created." Line 213  when they are created."
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))
# Line 238  when they are created." Line 236  when they are created."
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")
# Line 247  when they are created." Line 245  when they are created."
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)
# Line 330  requested face. Line 328  requested face.
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"))
# Line 352  requested face. Line 350  requested 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: "))
# Line 376  requested face. Line 374  requested face.
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: "))
# Line 401  requested face. Line 399  requested face.
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))
# Line 409  typing a character to insert cancels the Line 407  typing a character to insert cancels the
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    
# Line 442  This sets the `read-only' text property; Line 440  This sets the `read-only' text property;
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
# Line 458  This sets the `read-only' text property; Line 456  This sets the `read-only' text property;
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
# Line 500  of colors that the current display can h Line 498  of colors that the current display can h
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    
# Line 654  This is called whenever you create a new Line 652  This is called whenever you create a new
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))))
# Line 695  This is called whenever you use a new co Line 693  This is called whenever you use a new co
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)))
# Line 713  This is called whenever you use a new co Line 711  This is called whenever you use a new co
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)
# Line 735  Returns the non-nil value it found, or n Line 733  Returns the non-nil value it found, or n
733    
734  (facemenu-update)  (facemenu-update)
735    
736    (provide 'facemenu)
737  ;;; facemenu.el ends here  ;;; facemenu.el ends here

Legend:
Removed from v.1.67  
changed lines
  Added in v.1.67.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26