--- /dev/null
+;; gtk-font-menu.el --- Managing menus of GTK fonts.
+
+;; Copyright (C) 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
+;; Copyright (C) 1997 Sun Microsystems
+
+;; Author: Jamie Zawinski <jwz@jwz.org>
+;; Restructured by: Jonathan Stigelman <Stig@hackvan.com>
+;; Mule-ized by: Martin Buchholz
+;; More restructuring for MS-Windows by Andy Piper <andy@xemacs.org>
+;; GTK-ized by: William Perry <wmperry@xemacs.org>
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+;;; Code:
+
+;; #### - implement these...
+;;
+;;; (defvar font-menu-ignore-proportional-fonts nil
+;;; "*If non-nil, then the font menu will only show fixed-width fonts.")
+
+(require 'font-menu)
+
+(defvar gtk-font-menu-registry-encoding nil
+ "Registry and encoding to use with font menu fonts.")
+
+(defvar gtk-fonts-menu-junk-families
+ (mapconcat
+ #'identity
+ '("cursor" "glyph" "symbol" ; Obvious losers.
+ "\\`Ax...\\'" ; FrameMaker fonts - there are just way too
+ ; many of these, and there is a different
+ ; font family for each font face! Losers.
+ ; "Axcor" -> "Applix Courier Roman",
+ ; "Axcob" -> "Applix Courier Bold", etc.
+ )
+ "\\|")
+ "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
+
+(defun hack-font-truename (fn)
+ "Filter the output of `font-instance-truename' to deal with Japanese fontsets."
+ (if (string-match "," (font-instance-truename fn))
+ (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-")))
+ (flist (split-string (font-instance-truename fn) ","))
+ ret)
+ (while flist
+ (if (string-equal fpnt (nth 8 (split-string (car flist) "-")))
+ (progn (setq ret (car flist)) (setq flist nil))
+ (setq flist (cdr flist))
+ ))
+ ret)
+ (font-instance-truename fn)))
+
+(defvar gtk-font-regexp-ascii nil
+ "This is used to filter out font families that can't display ASCII text.
+It must be set at run-time.")
+
+;;;###autoload
+(defun gtk-reset-device-font-menus (device &optional debug)
+ "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
+This is run the first time that a font-menu is needed for each device.
+If you don't like the lazy invocation of this function, you can add it to
+`create-device-hook' and that will make the font menus respond more quickly
+when they are selected for the first time. If you add fonts to your system,
+or if you change your font path, you can call this to re-initialize the menus."
+ ;; by Stig@hackvan.com
+ ;; #### - this should implement a `menus-only' option, which would
+ ;; recalculate the menus from the cache w/o having to do list-fonts again.
+ (unless gtk-font-regexp-ascii
+ (setq gtk-font-regexp-ascii (if (featurep 'mule)
+ (charset-registry 'ascii)
+ "iso8859-1")))
+ (setq gtk-font-menu-registry-encoding
+ (if (featurep 'mule) "*-*" "iso8859-1"))
+ (let ((case-fold-search t)
+ family size weight entry monospaced-p
+ dev-cache cache families sizes weights)
+ (dolist (name (cond ((null debug) ; debugging kludge
+ (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
+ ((stringp debug) (split-string debug "\n"))
+ (t debug)))
+ (when (and (string-match gtk-font-regexp-ascii name)
+ (string-match gtk-font-regexp name))
+ (setq weight (capitalize (match-string 1 name))
+ size (string-to-int (match-string 6 name)))
+ (or (string-match gtk-font-regexp-foundry-and-family name)
+ (error "internal error"))
+ (setq family (capitalize (match-string 1 name)))
+ (or (string-match gtk-font-regexp-spacing name)
+ (error "internal error"))
+ (setq monospaced-p (string= "m" (match-string 1 name)))
+ (unless (string-match gtk-fonts-menu-junk-families family)
+ (setq entry (or (vassoc family cache)
+ (car (setq cache
+ (cons (vector family nil nil t)
+ cache)))))
+ (or (member family families) (push family families))
+ (or (member weight weights) (push weight weights))
+ (or (member size sizes) (push size sizes))
+ (or (member weight (aref entry 1)) (push weight (aref entry 1)))
+ (or (member size (aref entry 2)) (push size (aref entry 2)))
+ (aset entry 3 (and (aref entry 3) monospaced-p)))))
+ ;;
+ ;; Hack scalable fonts.
+ ;; Some fonts come only in scalable versions (the only size is 0)
+ ;; and some fonts come in both scalable and non-scalable versions
+ ;; (one size is 0). If there are any scalable fonts at all, make
+ ;; sure that the union of all point sizes contains at least some
+ ;; common sizes - it's possible that some sensible sizes might end
+ ;; up not getting mentioned explicitly.
+ ;;
+ (if (member 0 sizes)
+ (let ((common '(60 80 100 120 140 160 180 240)))
+ (while common
+ (or;;(member (car common) sizes) ; not enough slack
+ (let ((rest sizes)
+ (done nil))
+ (while (and (not done) rest)
+ (if (and (> (car common) (- (car rest) 5))
+ (< (car common) (+ (car rest) 5)))
+ (setq done t))
+ (setq rest (cdr rest)))
+ done)
+ (setq sizes (cons (car common) sizes)))
+ (setq common (cdr common)))
+ (setq sizes (delq 0 sizes))))
+
+ (setq families (sort families 'string-lessp)
+ weights (sort weights 'string-lessp)
+ sizes (sort sizes '<))
+
+ (dolist (entry cache)
+ (aset entry 1 (sort (aref entry 1) 'string-lessp))
+ (aset entry 2 (sort (aref entry 2) '<)))
+
+ (setq dev-cache (assq device device-fonts-cache))
+ (or dev-cache
+ (setq dev-cache (car (push (list device) device-fonts-cache))))
+ (setcdr
+ dev-cache
+ (vector
+ cache
+ (mapcar (lambda (x)
+ (vector x
+ (list 'font-menu-set-font x nil nil)
+ ':style 'radio ':active nil ':selected nil))
+ families)
+ (mapcar (lambda (x)
+ (vector (if (/= 0 (% x 10))
+ ;; works with no LISP_FLOAT_TYPE
+ (concat (int-to-string (/ x 10)) "."
+ (int-to-string (% x 10)))
+ (int-to-string (/ x 10)))
+ (list 'font-menu-set-font nil nil x)
+ ':style 'radio ':active nil ':selected nil))
+ sizes)
+ (mapcar (lambda (x)
+ (vector x
+ (list 'font-menu-set-font nil x nil)
+ ':style 'radio ':active nil ':selected nil))
+ weights)))
+ (cdr dev-cache)))
+
+;; Extract font information from a face. We examine both the
+;; user-specified font name and the canonical (`true') font name.
+;; These can appear to have totally different properties.
+;; For examples, see the prolog above.
+
+;; We use the user-specified one if possible, else use the truename.
+;; If the user didn't specify one (with "-dt-*-*", for example)
+;; get the truename and use the possibly suboptimal data from that.
+;;;###autoload
+(defun* gtk-font-menu-font-data (face dcache)
+ (defvar gtk-font-regexp)
+ (defvar gtk-font-regexp-foundry-and-family)
+ (let* ((case-fold-search t)
+ (domain (if font-menu-this-frame-only-p
+ (selected-frame)
+ (selected-device)))
+ (name (font-instance-name (face-font-instance face domain)))
+ (truename (font-instance-truename
+ (face-font-instance face domain
+ (if (featurep 'mule) 'ascii))))
+ family size weight entry slant)
+ (when (string-match gtk-font-regexp-foundry-and-family name)
+ (setq family (capitalize (match-string 1 name)))
+ (setq entry (vassoc family (aref dcache 0))))
+ (when (and (null entry)
+ (string-match gtk-font-regexp-foundry-and-family truename))
+ (setq family (capitalize (match-string 1 truename)))
+ (setq entry (vassoc family (aref dcache 0))))
+ (when (null entry)
+ (return-from gtk-font-menu-font-data (make-vector 5 nil)))
+
+ (when (string-match gtk-font-regexp name)
+ (setq weight (capitalize (match-string 1 name)))
+ (setq size (string-to-int (match-string 6 name))))
+
+ (when (string-match gtk-font-regexp truename)
+ (when (not (member weight (aref entry 1)))
+ (setq weight (capitalize (match-string 1 truename))))
+ (when (not (member size (aref entry 2)))
+ (setq size (string-to-int (match-string 6 truename))))
+ (setq slant (capitalize (match-string 2 truename))))
+
+ (vector entry family size weight slant)))
+
+(defun gtk-font-menu-load-font (family weight size slant resolution)
+ "Try to load a font with the requested properties.
+The weight, slant and resolution are only hints."
+ (when (integerp size) (setq size (int-to-string size)))
+ (let (font)
+ (catch 'got-font
+ (dolist (weight (list weight "*"))
+ (dolist (slant
+ (cond ((string-equal slant "O") '("O" "I" "*"))
+ ((string-equal slant "I") '("I" "O" "*"))
+ ((string-equal slant "*") '("*"))
+ (t (list slant "*"))))
+ (dolist (resolution
+ (if (string-equal resolution "*-*")
+ (list resolution)
+ (list resolution "*-*")))
+ (when (setq font
+ (make-font-instance
+ (concat "-*-" family "-" weight "-" slant "-*-*-*-"
+ size "-" resolution "-*-*-"
+ gtk-font-menu-registry-encoding)
+ nil t))
+ (throw 'got-font font))))))))
+
+(provide 'gtk-font-menu)
+
+;;; gtk-font-menu.el ends here
projects / chise / xemacs-chise.git- / blobdiff