list-fonts-display
So, I notice that there is list-faces-display and list-colors-display
(very nice), but there is no list-fonts-display.
Why?
I wrote one that works pretty well for windows.
Maybe somebody else that understands windows and x fonts would
improve this?
-jeff
================================================================
(defun facemenu-get-face-font (symbol)
(let ((name (symbol-name symbol)))
(cond ((find-face symbol) symbol)
((string-match "^font:" name)
(let* ((face (make-face symbol))
(font (substring name 5)))
(if (font-instance-p (make-font-instance font nil t))
(set-face-font face (make-font-instance font))
(if (font-instance-p (make-font-instance (concat font
"::::Symbol") nil t))
(set-face-font face (make-font-instance (concat font
"::::Symbol")))
(progn;;(warn "Font `%s' undefined" font)
(setq symbol nil)))))
symbol)
(t (facemenu-get-face symbol)))))
(defun list-fonts-regexp (regexp)
(let ((result nil))
(dolist (font-string (list-fonts "") (nreverse result))
(when (or (null regexp) (string-match regexp font-string))
(push font-string result)))))
(defun my-list-fonts (&optional pattern do-fontname)
(let ((result nil) font (families nil))
(dolist (font-string (list-fonts ""))
;; windows list-fonts returns fonts like "Tera Special::::Symbol",
mswindows-font-create-object returns courier
;; So, I have to smash the pattern to include a pointsize
(when (or (null pattern) (string-match pattern font-string))
(setq font-string
(if (string-match "^\\([a-zA-Z ]+\\):\\([a-zA-Z]*\\)\\(
[a-zA-Z]*\\)?:\\([0-9]*\\):\\([a-zA-Z ]*\\):\\([a-zA-Z 0-9]*\\)$" font-string)
(let ((family (match-string 1 font-string))
(weight (match-string 2 font-string))
(style (match-string 3 font-string))
(pointsize (match-string 4 font-string))
(effects (match-string 5 font-string))
(charset (match-string 6 font-string)))
(concat family ":" ":" (if (equal pointsize
"") "10" pointsize) ":" effects ":" charset))
font-string))
;;(setq font (make-fontobj font-string))
(setq font (if (string-match "[-*]" font-string)
(x-font-create-object font-string)
(mswindows-font-create-object font-string)))
(if (and (font-family font) (not (member (car (font-family font)) result)))
(push (if do-fontname font-string (car (font-family font))) result))))
(nreverse result)))
(require 'facemenu)
(defun list-fonts-display (&optional list matching)
(interactive)
(if (null matching) (setq matching ""))
(setq list (facemenu-unique (my-list-fonts "")))
(with-output-to-temp-buffer "*Fonts*"
(save-excursion
(set-buffer standard-output)
(let ((facemenu-unlisted-faces t)
s)
(while list
(let ((face (facemenu-get-face-font
(intern (concat "font:" (car list))))))
(setq s (point))
(insert (car list))
(indent-to 30)
(setq s (point))
(cond (face
(insert " " "abcdefghijklmnopqrstuvwxyz
ABCDEFGHIJKLMNOPQRSTUVWXYZ" "\n")
(put-text-property s (point) 'face face))
(t (insert "invalid\n"))))
(setq list (cdr list)))))))