[MD:592] bdf font

[Yoshiki Hayashi <penny@xxxxxxxxxxxxxxxx>]

YAMAMOTO Akishige <yamamoto@xxxxxxxxx> writes:

> bdf 関連のコードはすべて、src/mw32bdf.c にあります。
> 
> # ちょっと不具合があったので、以前この ML にパッチを流しました。

もしかして、0.50b3のソースではまずいのでしょうか。
まだ1.00のソースはダウンロードしていないのです。(^^;;

Xの方も読んでみました。
(一時間はかかってダウンロードしたのに、BDFのところはたったの26KB(;_;))
こちらの方はFONTはxlfd or some private nameとなっていました。
しかし、ここがxlfdで無いと、どうやって判定して良いのか分からないので、
xlfdであると仮定して、やまもとさんのコードを参考にしながら、
bdf-font-listを作成とupdateする関数を力ずくで書いてみました。
適当に自分の好みで変数名などを変更しています。とりあえずは動きます。
でも、非常に遅いです。その上、elispを書く力がないので、とても汚いコー
ドになっています。

もう少しがんばってelispを勉強してみます。

----
Yoshiki Hayashi

(defvar w32-bdf-font-list-cache nil)
(defvar w32-bdf-font-list-filename "~/.bdffont")
(defvar w32-bdf-font-directory "/freeware/Meadow/font/")

(defun w32-get-bdf-info (filename)
  "Get metric information of bdf font. 
Return alist ((SLANT slant) (SETWIDTH_NAME setwidth_name)
(CHARSET_REGISTRY carset-registry) (CHARSET_ENCODING charset_encoding))"
  (catch 'fbound
    (with-temp-buffer
	(while 1
	  (save-excursion
	    (goto-char (point-max))
	    (insert-file-contents filename nil (point) (+ (point) 512)))
	  (if (and (search-forward-regexp
				   "FONT -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-\n]*\\)$" nil t)
		   (not (eq (point) (point-max))))
	      (throw 'fbound (list (cons 'slant (match-string 4)) 
				   (cons 'setwidth_name (match-string 5))
				   (cons 'charset_registry (match-string 13))
				   (cons 'charset_encoding (match-string 14))))
	    (if (search-forward-regexp "^ENDPROPERTIES" nil t)
		(error "can not find FONT field"))
	    (goto-char (point-max))
	    (beginning-of-line))))))


(defun w32-save-bdf-font-list ()
  "write w32-bdf-font-list-cache to file w32-bdf-font-list-filename." 
  (if w32-bdf-font-list-cache
      (w32-bdf-font-list))
      (with-temp-buffer
        (insert ";; -*- emacs-lisp -*-\n")
        (insert ";; Meadow bdf font list. automatically created by w32-save-bdf-font-list\n")
	(insert "(setq w32-bdf-font-list-cache '")
       (let ((print-quoted t)
              (print-readably t))
          (prin1 w32-bdf-font-list-cache (current-buffer))
	  (goto-char (point-max))
	  (insert ")"))
        (write-file w32-bdf-font-list-filename)))
 
(defun w32-bdf-font-list ()
  "set variable w32-bdf-font-list-cache."
  (let ((filelist (w32-get-bdf-files w32-bdf-font-directory))
	filename
	fonts)
    (while filelist
      (setq filename (car filelist))
      (setq fonts (cons (w32-bdf-font-info filename) fonts))
      (setq filelist (cdr filelist)))
    (setq w32-bdf-font-list-cache fonts)))

(defun w32-bdf-font-list-cache-update ()
  (if w32-bdf-font-list-cache
      nil
    (if (file-exist-p w32-bdf-font-list-filename)
	(load w32-bdf-font-list-filename)
      (w32-bdf-font-list)))
  (let ((filelist (nreverse (w32-get-bdf-files w32-bdf-font-directory)))
	(bflist w32-bdf-font-list-cache)
	dfname)
    (while (setq dfname (car filelist))
      (setq exname (car (car bflist)))
      (cond ((string= dfname (car exname))
	     (if (not (equal (nth 5 (file-attributes dfname)) (cdr exname)))
		 (setcar bflist w32-bdf-font-info dfname))
	     (setq filelist (cdr filelist)
		   bflist (cdr bflist)))
	    ((string< dfname (car exname))
	     (setcdr bflist (cons (car bflist) (cdr bflist)))
	     (setcar bflist (w32-bdf-font-info dfname))
	     (setq filelist (cdr filelist))
	     (setq bflist (cdr bflist)))
	    ((string< (car exname) dfname)
	     (setcar bflist (car (cdr bflist)))
	     (setcdr bflist (cdr (cdr bflist))))))
    (if bflist
	(while bflist
	  (setcar bflist (car (cdr bflist)))
	  (setcdr bflist (cdr (cdr bflist)))
	  (setq bflist (cdr bflist))))))

(defun w32-bdf-font-list-update ()
  (w32-bdf-font-list-cache-update)
  (w32-save-bdf-font-list))

(defun w32-bdf-font-info (filename)
  (cons (cons filename (nth 5 (file-attributes filename)))
	(w32-get-bdf-info filename)))
	


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; bdf font directory maintenance

(defun w32-get-bdf-files (dir)
  "Enumerate bdf font filnames in the directory.
DIR is the absolute directory path where
you store the bdf font files."
  (let ((files nil)
        (dirs (directory-files w32-bdf-font-directory)))
    (while dirs
      (if (and (not (string= (car dirs) "."))
               (not (string= (car dirs) "..")))
          (let ((filename (expand-file-name (car dirs) dir)))
	    (if (file-directory-p filename)
                (setq files (append (w32-get-bdf-files filename) files))
              (if (string-match "^.*\\.bdf$" filename)
                  (setq files (cons filename files))))))
      (setq dirs (cdr dirs)))
    files))