git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/msw-font-menu.el

   1 ;; msw-font-menu.el --- Managing menus of mswindows fonts.
   2
   3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
   4
   5 ;; Adapted from x-font-menu.el by Andy Piper <andy@xemacs.org>
   6
   7 ;; This file is part of XEmacs.
   8
   9 ;; XEmacs is free software; you can redistribute it and/or modify it
  10 ;; under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; XEmacs is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with XEmacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; mswindows fonts look like:
  25 ;;;     fontname[:[weight][ style][:pointsize[:effects]]][:charset]
  26 ;;; ie:
  27 ;;;     Lucida Console:Regular:10
  28 ;;; minimal:
  29 ;;;     Courier New
  30 ;;; maximal:
  31 ;;;     Courier New:Bold Italic:10:underline strikeout:western
  32
  33 ;;; Code:
  34
  35 ;; #### - implement these...
  36 ;;
  37 ;;; (defvar font-menu-ignore-proportional-fonts nil
  38 ;;;   "*If non-nil, then the font menu will only show fixed-width fonts.")
  39
  40 (require 'font-menu)
  41
  42 (defvar mswindows-font-menu-registry-encoding nil
  43   "Registry and encoding to use with font menu fonts.")
  44
  45 (defvar mswindows-font-menu-junk-families
  46   (purecopy
  47    (mapconcat
  48     #'identity
  49     '("Symbol"
  50       )
  51     "\\|"))
  52   "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
  53
  54 (defvar mswindows-font-regexp-ascii nil
  55   "This is used to filter out font families that can't display ASCII text.
  56 It must be set at run-time.")
  57
  58 ;;;###autoload
  59 (defun mswindows-reset-device-font-menus (device &optional debug)
  60   "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
  61 This is run the first time that a font-menu is needed for each device.
  62 If you don't like the lazy invocation of this function, you can add it to
  63 `create-device-hook' and that will make the font menus respond more quickly
  64 when they are selected for the first time.  If you add fonts to your system,
  65 or if you change your font path, you can call this to re-initialize the menus."
  66   (unless mswindows-font-regexp-ascii
  67     (setq mswindows-font-regexp-ascii (if (featurep 'mule)
  68                                           (charset-registry 'ascii)
  69                                         "Western")))
  70   (setq mswindows-font-menu-registry-encoding (if (featurep 'mule) "" "Western"))
  71   (let ((case-fold-search t)
  72         family size weight entry
  73         dev-cache cache families sizes weights)
  74     (dolist (name (cond ((null debug)   ; debugging kludge
  75                          (list-fonts "::::" device))
  76                         ((stringp debug) (split-string debug "\n"))
  77                         (t debug)))
  78       (when (and (string-match mswindows-font-regexp-ascii name)
  79                  (string-match mswindows-font-regexp name))
  80         (setq weight (capitalize (match-string 2 name))
  81               size   (string-to-int (or (match-string 4 name) "0"))
  82               family (match-string 1 name))
  83         (unless (string-match mswindows-font-menu-junk-families family)
  84           (setq entry (or (vassoc name cache)
  85                           (car (setq cache
  86                                      (cons (vector family nil nil t)
  87                                            cache)))))
  88           (or (member family families) (push family families))
  89           (or (member weight weights)  (push weight weights))
  90           (or (member size   sizes)    (push size   sizes))
  91           (or (member weight (aref entry 1)) (push weight (aref entry 1)))
  92           (or (member size   (aref entry 2)) (push size   (aref entry 2))))))
  93       ;;
  94       ;; Hack scalable fonts.
  95       ;; Some fonts come only in scalable versions (the only size is 0)
  96       ;; and some fonts come in both scalable and non-scalable versions
  97       ;; (one size is 0).  If there are any scalable fonts at all, make
  98       ;; sure that the union of all point sizes contains at least some
  99       ;; common sizes - it's possible that some sensible sizes might end
 100       ;; up not getting mentioned explicitly.
 101       ;;
 102       (if (member 0 sizes)
 103           (let ((common '(6 8 10 12 14 16 18 24)))
 104             (while common
 105               (or;;(member (car common) sizes)   ; not enough slack
 106                (let ((rest sizes)
 107                      (done nil))
 108                  (while (and (not done) rest)
 109                    (if (and (> (car common) (- (car rest) 1))
 110                             (< (car common) (+ (car rest) 1)))
 111                        (setq done t))
 112                    (setq rest (cdr rest)))
 113                  done)
 114                (setq sizes (cons (car common) sizes)))
 115               (setq common (cdr common)))
 116             (setq sizes (delq 0 sizes))))
 117
 118       (setq families (sort families 'string-lessp)
 119             weights  (sort weights 'string-lessp)
 120             sizes    (sort sizes '<))
 121
 122       (dolist (entry cache)
 123         (aset entry 1 (sort (aref entry 1) 'string-lessp))
 124         (aset entry 2 (sort (aref entry 2) '<)))
 125
 126       (setq dev-cache (assq device device-fonts-cache))
 127       (or dev-cache
 128           (setq dev-cache (car (push (list device) device-fonts-cache))))
 129       (setcdr
 130        dev-cache
 131        (vector
 132         cache
 133         (mapcar (lambda (x)
 134                   (vector x
 135                           (list 'font-menu-set-font x nil nil)
 136                           ':style 'radio ':active nil ':selected nil))
 137                 families)
 138         (mapcar (lambda (x)
 139                   (vector (int-to-string x)
 140                           (list 'font-menu-set-font nil nil x)
 141                           ':style 'radio ':active nil ':selected nil))
 142                 sizes)
 143         (mapcar (lambda (x)
 144                   (vector x
 145                           (list 'font-menu-set-font nil x nil)
 146                           ':style 'radio ':active nil ':selected nil))
 147                 weights)))
 148       (cdr dev-cache)))
 149
 150 ;; Extract font information from a face.  We examine both the
 151 ;; user-specified font name and the canonical (`true') font name.
 152 ;; These can appear to have totally different properties.
 153
 154 ;; We use the user-specified one if possible, else use the truename.
 155 ;; If the user didn't specify one get the truename and use the
 156 ;; possibly suboptimal data from that.
 157 ;;;###autoload
 158 (defun* mswindows-font-menu-font-data (face dcache)
 159   (let* ((case-fold-search t)
 160          (domain (if font-menu-this-frame-only-p
 161                                   (selected-frame)
 162                                 (selected-device)))
 163          (name (font-instance-name (face-font-instance face domain)))
 164          (truename (font-instance-truename
 165                     (face-font-instance face domain
 166                                         (if (featurep 'mule) 'ascii))))
 167          family size weight entry slant)
 168     (when (string-match mswindows-font-regexp name)
 169       (setq family (match-string 1 name))
 170       (setq entry (vassoc family (aref dcache 0))))
 171     (when (and (null entry)
 172                (string-match mswindows-font-regexp truename))
 173       (setq family (match-string 1 truename))
 174       (setq entry  (vassoc family (aref dcache 0))))
 175     (when (null entry)
 176       (return-from mswindows-font-menu-font-data (make-vector 5 nil)))
 177
 178     (when (string-match mswindows-font-regexp name)
 179       (setq weight (match-string 2 name))
 180       (setq size   (string-to-int (match-string 4 name))))
 181
 182     (when (string-match mswindows-font-regexp truename)
 183       (when (not (member weight (aref entry 1)))
 184         (setq weight (match-string 2 truename)))
 185       (when (not (member size   (aref entry 2)))
 186         (setq size (string-to-int (match-string 4 truename))))
 187       (setq slant (match-string 5 truename)))
 188
 189     (vector entry family size weight slant)))
 190
 191 (defun mswindows-font-menu-load-font (family weight size slant resolution)
 192   "Try to load a font with the requested properties.
 193 The weight, slant and resolution are only hints."
 194   (when (integerp size) (setq size (int-to-string size)))
 195   (let (font)
 196     (catch 'got-font
 197       (dolist (weight (list weight ""))
 198         (dolist (slant
 199                  ;; oblique is not currently implemented
 200                  (cond ((string-equal slant "Oblique") '(" Italic" ""))
 201                        ((string-equal slant "Italic") '(" Italic" ""))
 202                        (t (list slant ""))))
 203           (when (setq font
 204                       (make-font-instance
 205                        (concat  family ":" weight slant ":"
 206                                 size "::"
 207                                 mswindows-font-menu-registry-encoding)
 208                        nil t))
 209             (throw 'got-font font)))))))
 210
 211 (provide 'mswindows-font-menu)
 212
 213 ;;; msw-font-menu.el ends here