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

Diff of /emacs/lisp/faces.el

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

revision 1.258 by miles, Mon Apr 15 06:16:28 2002 UTC revision 1.259 by rms, Fri Apr 26 22:31:16 2002 UTC
# Line 846  of the default face.  Value is FACE." Line 846  of the default face.  Value is FACE."
846  ;;; Interactively modifying faces.  ;;; Interactively modifying faces.
847  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
848    
849  (defun read-face-name (prompt)  (defun read-face-name (prompt &optional string-describing-default multiple)
850    "Read and return a face symbol, prompting with PROMPT.    "Read a face, defaulting to the face or faces on the char after point.
851  PROMPT should not end with a blank, since this function appends one.  If it has a `read-face-name' property, that overrides the `face' property.
852  Value is a symbol naming a known face."  PROMPT describes what you will do with the face (don't end in a space).
853    (let ((face-list (mapcar #'(lambda (x) (cons (symbol-name x) x))  STRING-DESCRIBING-DEFAULT describes what default you will use
854                             (face-list)))  if this function returns nil.
855          (def (thing-at-point 'symbol))  If MULTIPLE is non-nil, return a list of faces (possibly only one).
856          face)  Otherwise, return a single face."
857      (cond ((assoc def face-list)    (let ((faceprop (or (get-char-property (point) 'read-face-name)
858             (setq prompt (concat prompt " (default " def "): ")))                        (get-char-property (point) 'face)))
859            (t (setq def nil)          faces)
860               (setq prompt (concat prompt ": "))))      ;; Make a list of the named faces that the `face' property uses.
861      (while (equal "" (setq face (completing-read      (if (listp faceprop)
862                                   prompt face-list nil t nil nil def))))          (dolist (f faceprop)
863      (intern face)))            (if (symbolp f)
864                  (push f faces)))
865          (if (symbolp faceprop)
866              (setq faces (list faceprop))))
867        ;; If there are none, try to get a face name from the buffer.
868        (if (and (null faces)
869                 (memq (intern-soft (thing-at-point 'symbol)) (face-list)))
870            (setq faces (list (intern-soft (thing-at-point 'symbol)))))
871    
872        ;; If we only want one, and the default is more than one,
873        ;; discard the unwanted ones now.
874        (unless multiple
875          (if faces
876              (setq faces (list (car faces)))))
877        (let* ((input
878                ;; Read the input.
879                (completing-read
880                 (if (or faces string-describing-default)
881                     (format "%s (default %s): " prompt
882                             (if faces (mapconcat 'symbol-name faces ", ")
883                               string-describing-default))
884                   prompt)
885                 obarray 'custom-facep t))
886               ;; Canonicalize the output.
887               (output
888                (if (equal input "")
889                    faces
890                  (if (stringp input)
891                      (list (intern input))
892                    input))))
893          ;; Return either a list of faces or just one face.
894          (if multiple
895              output
896            (car output)))))
897    
898    
899    
900    
901  (defun face-valid-attribute-values (attribute &optional frame)  (defun face-valid-attribute-values (attribute &optional frame)
# Line 1137  The sample text is a string that comes f Line 1172  The sample text is a string that comes f
1172            (save-excursion            (save-excursion
1173              (save-match-data              (save-match-data
1174                (search-backward face-name)                (search-backward face-name)
1175                (help-xref-button 0 'help-customize-face face-name)))                (help-xref-button 0 'help-customize-face face)))
1176            (let ((beg (point)))            (let ((beg (point))
1177                    (line-beg (line-beginning-position)))
1178              (insert list-faces-sample-text)              (insert list-faces-sample-text)
1179              ;; Hyperlink to a help buffer for the face.              ;; Hyperlink to a help buffer for the face.
1180              (save-excursion              (save-excursion
# Line 1147  The sample text is a string that comes f Line 1183  The sample text is a string that comes f
1183                  (help-xref-button 0 'help-face face)))                  (help-xref-button 0 'help-face face)))
1184              (insert "\n")              (insert "\n")
1185              (put-text-property beg (1- (point)) 'face face)              (put-text-property beg (1- (point)) 'face face)
1186                ;; Make all face commands default to the proper face
1187                ;; anywhere in the line.
1188                (put-text-property line-beg (1- (point)) 'read-face-name face)
1189              ;; If the sample text has multiple lines, line up all of them.              ;; If the sample text has multiple lines, line up all of them.
1190              (goto-char beg)              (goto-char beg)
1191              (forward-line 1)              (forward-line 1)
# Line 1167  The sample text is a string that comes f Line 1206  The sample text is a string that comes f
1206              (copy-face (car faces) (car faces) frame disp-frame)              (copy-face (car faces) (car faces) frame disp-frame)
1207              (setq faces (cdr faces)))))))              (setq faces (cdr faces)))))))
1208    
   
1209  (defun describe-face (face &optional frame)  (defun describe-face (face &optional frame)
1210    "Display the properties of face FACE on FRAME.    "Display the properties of face FACE on FRAME.
1211    Interactevely, FACE defaults to the faces of the character after point
1212    and FRAME defaults to the selected frame.
1213    
1214  If the optional argument FRAME is given, report on face FACE in that frame.  If the optional argument FRAME is given, report on face FACE in that frame.
1215  If FRAME is t, report on the defaults for face FACE (for new frames).  If FRAME is t, report on the defaults for face FACE (for new frames).
1216  If FRAME is omitted or nil, use the selected frame."  If FRAME is omitted or nil, use the selected frame."
1217    (interactive (list (read-face-name "Describe face")))    (interactive (list (read-face-name "Describe face" "= `default' face" t)))
1218    (let* ((attrs '((:family . "Family")    (let* ((attrs '((:family . "Family")
1219                    (:width . "Width")                    (:width . "Width")
1220                    (:height . "Height")                    (:height . "Height")
# Line 1192  If FRAME is omitted or nil, use the sele Line 1233  If FRAME is omitted or nil, use the sele
1233          (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))          (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
1234                                          attrs))))                                          attrs))))
1235      (help-setup-xref (list #'describe-face face) (interactive-p))      (help-setup-xref (list #'describe-face face) (interactive-p))
1236        (unless face
1237          (setq face 'default))
1238        (if (not (listp face))
1239            (setq face (list face)))
1240      (with-output-to-temp-buffer (help-buffer)      (with-output-to-temp-buffer (help-buffer)
1241        (save-excursion        (save-excursion
1242          (set-buffer standard-output)          (set-buffer standard-output)
1243          (dolist (a attrs)          (dolist (f face)
1244            (let ((attr (face-attribute face (car a) frame)))            (insert "Face: " (symbol-name f))
1245              (insert (make-string (- max-width (length (cdr a))) ?\ )            (if (not (facep f))
1246                      (cdr a) ": " (format "%s" attr) "\n")))                (insert "   undefined face.\n")
1247          (insert "\nDocumentation:\n\n"              (let ((customize-label "customize this face"))
1248                  (or (face-documentation face)                (princ (concat " (" customize-label ")\n"))
1249                      "not documented as a face."))                (insert "Documentation: "
1250          (let ((customize-label "customize"))                        (or (face-documentation f)
1251            (terpri)                            "not documented as a face.")
1252            (terpri)                        "\n\n")
1253            (princ (concat "You can " customize-label " this face."))                (with-current-buffer standard-output
1254            (with-current-buffer standard-output                  (save-excursion
1255              (save-excursion                    (re-search-backward
1256                (re-search-backward                     (concat "\\(" customize-label "\\)") nil t)
1257                 (concat "\\(" customize-label "\\)") nil t)                    (help-xref-button 1 'help-customize-face f)))
1258                (help-xref-button 1 'help-customize-face face)))))                (dolist (a attrs)
1259                    (let ((attr (face-attribute f (car a) frame)))
1260                      (insert (make-string (- max-width (length (cdr a))) ?\ )
1261                              (cdr a) ": " (format "%s" attr) "\n")))))
1262              (terpri)))
1263        (print-help-return-message))))        (print-help-return-message))))
1264    
1265    

Legend:
Removed from v.1.258  
changed lines
  Added in v.1.259

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