/[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.78 by rms, Sat Jun 25 22:24:10 2005 UTC revision 1.79 by lute, Mon Jun 27 07:30:53 2005 UTC
# Line 1  Line 1 
1  ;;; facemenu.el --- create a face menu for interactively adding fonts to text  ;;; facemenu.el --- create a face menu for interactively adding fonts to text
2    
3  ;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc.  ;; Copyright (c) 1994, 1995, 1996, 2001, 2002, 2005 Free Software Foundation, Inc.
4    
5  ;; Author: Boris Goldowsky <boris@gnu.org>  ;; Author: Boris Goldowsky <boris@gnu.org>
6  ;; Keywords: faces  ;; Keywords: faces
# Line 135  just before \"Other\" at the end." Line 135  just before \"Other\" at the end."
135    `(modeline region secondary-selection highlight scratch-face    `(modeline region secondary-selection highlight scratch-face
136      ,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-")      ,(purecopy "^font-lock-") ,(purecopy "^gnus-") ,(purecopy "^message-")
137      ,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-")      ,(purecopy "^ediff-") ,(purecopy "^term-") ,(purecopy "^vc-")
138      ,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-"))      ,(purecopy "^widget-") ,(purecopy "^custom-") ,(purecopy "^vm-")
139        ,(purecopy "^fg:") ,(purecopy "^bg:"))
140    "*List of faces not to include in the Face menu.    "*List of faces not to include in the Face menu.
141  Each element may be either a symbol, which is the name of a face, or a string,  Each element may be either a symbol, which is the name of a face, or a string,
142  which is a regular expression to be matched against face names.  Matching  which is a regular expression to be matched against face names.  Matching
# Line 365  typing a character to insert cancels the Line 366  typing a character to insert cancels the
366                           (region-beginning))                           (region-beginning))
367                       (if (and mark-active (not current-prefix-arg))                       (if (and mark-active (not current-prefix-arg))
368                           (region-end))))                           (region-end))))
369    (unless (color-defined-p color)    (facemenu-add-face (facemenu-add-new-color color 'facemenu-foreground-menu)
370      (message "Color `%s' undefined" color))                       start end))
   (facemenu-add-new-color color 'facemenu-foreground-menu)  
   (facemenu-add-face (list (list :foreground color)) start end))  
371    
372  ;;;###autoload  ;;;###autoload
373  (defun facemenu-set-background (color &optional start end)  (defun facemenu-set-background (color &optional start end)
# Line 389  typing a character to insert cancels the Line 388  typing a character to insert cancels the
388                           (region-beginning))                           (region-beginning))
389                       (if (and mark-active (not current-prefix-arg))                       (if (and mark-active (not current-prefix-arg))
390                           (region-end))))                           (region-end))))
391    (unless (color-defined-p color)    (facemenu-add-face (facemenu-add-new-color color 'facemenu-background-menu)
392      (message "Color `%s' undefined" color))                       start end))
   (facemenu-add-new-color color 'facemenu-background-menu)  
   (facemenu-add-face (list (list :background color)) start end))  
393    
394  ;;;###autoload  ;;;###autoload
395  (defun facemenu-set-face-from-menu (face start end)  (defun facemenu-set-face-from-menu (face start end)
# Line 413  typing a character to insert cancels the Line 410  typing a character to insert cancels the
410                       (if (and mark-active (not current-prefix-arg))                       (if (and mark-active (not current-prefix-arg))
411                           (region-end))))                           (region-end))))
412    (barf-if-buffer-read-only)    (barf-if-buffer-read-only)
   (facemenu-get-face face)  
413    (if start    (if start
414        (facemenu-add-face face start end)        (facemenu-add-face face start end)
415      (facemenu-add-face face)))      (facemenu-add-face face)))
# Line 648  use the selected frame.  If t, then the Line 644  use the selected frame.  If t, then the
644        (setq face-list (cdr face-list)))        (setq face-list (cdr face-list)))
645      (nreverse active-list)))      (nreverse active-list)))
646    
 (defun facemenu-get-face (symbol)  
   "Make sure FACE exists.  
 If not, create it and add it to the appropriate menu.  Return the SYMBOL."  
   (let ((name (symbol-name symbol)))  
     (cond ((facep symbol))  
           (t (make-face symbol))))  
   symbol)  
   
647  (defun facemenu-add-new-face (face)  (defun facemenu-add-new-face (face)
648    "Add FACE (a face) to the Face menu.    "Add FACE (a face) to the Face menu.
649    
# Line 715  This is called whenever you create a new Line 703  This is called whenever you create a new
703               (define-key menu key (cons name function))))))               (define-key menu key (cons name function))))))
704    nil) ; Return nil for facemenu-iterate    nil) ; Return nil for facemenu-iterate
705    
706  (defun facemenu-add-new-color (color &optional menu)  (defun facemenu-add-new-color (color menu)
707    "Add COLOR (a color name string) to the appropriate Face menu.    "Add COLOR (a color name string) to the appropriate Face menu.
708  MENU should be `facemenu-foreground-menu' or  MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'.
709  `facemenu-background-menu'.  Create the appropriate face and return it.
710    
711  This is called whenever you use a new color."  This is called whenever you use a new color."
712    (let* (name    (let (symbol docstring)
713           symbol      (unless (color-defined-p color)
714           docstring        (error "Color `%s' undefined" color))
          function menu-val key  
          (color-p (memq menu '(facemenu-foreground-menu  
                                facemenu-background-menu))))  
     (unless (stringp color)  
       (error "%s is not a color" color))  
     (setq name color  
           symbol (intern name))  
   
715      (cond ((eq menu 'facemenu-foreground-menu)      (cond ((eq menu 'facemenu-foreground-menu)
716             (setq docstring             (setq docstring
717                   (format "Select foreground color %s for subsequent insertion."                   (format "Select foreground color %s for subsequent insertion."
718                           name)))                           color)
719                     symbol (intern (concat "fg:" color)))
720               (set-face-foreground (make-face symbol) color))
721            ((eq menu 'facemenu-background-menu)            ((eq menu 'facemenu-background-menu)
722             (setq docstring             (setq docstring
723                   (format "Select background color %s for subsequent insertion."                   (format "Select background color %s for subsequent insertion."
724                           name))))                           color)
725                     symbol (intern (concat "bg:" color)))
726               (set-face-background (make-face symbol) color))
727              (t (error "MENU should be `facemenu-foreground-menu' or `facemenu-background-menu'")))
728      (cond ((facemenu-iterate ; check if equivalent face is already in the menu      (cond ((facemenu-iterate ; check if equivalent face is already in the menu
729              (lambda (m) (and (listp m)              (lambda (m) (and (listp m)
730                               (symbolp (car m))                               (symbolp (car m))
731                               (stringp (cadr m))                               (stringp (cadr m))
732                               (string-equal (cadr m) color)))                               (string-equal (cadr m) color)))
733              (cdr (symbol-function menu))))              (cdr (symbol-function menu))))
734            (t   ; No keyboard equivalent.  Figure out where to put it:            (t    ; No keyboard equivalent.  Figure out where to put it:
735             (setq key (vector symbol)             (let ((key (vector symbol))
736                   function 'facemenu-set-face-from-menu                   (function 'facemenu-set-face-from-menu)
737                   menu-val (symbol-function menu))                   (menu-val (symbol-function menu)))
738             (if (and facemenu-new-faces-at-end               (if (and facemenu-new-faces-at-end
739                     (> (length menu-val) 3))                        (> (length menu-val) 3))
740                 (define-key-after menu-val key (cons name function)                   (define-key-after menu-val key (cons color function)
741                   (car (nth (- (length menu-val) 3) menu-val)))                     (car (nth (- (length menu-val) 3) menu-val)))
742               (define-key menu key (cons name function))))))                 (define-key menu key (cons color function))))))
743    nil) ; Return nil for facemenu-iterate      symbol))
744    
745  (defun facemenu-complete-face-list (&optional oldlist)  (defun facemenu-complete-face-list (&optional oldlist)
746    "Return list of all faces that look different.    "Return list of all faces that look different.

Legend:
Removed from v.1.78  
changed lines
  Added in v.1.79

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