Mercurial > hg > xemacs-beta

view lisp/x-font-menu.el @ 5882:bbe4146603db

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp lisp/ChangeLog addition: 2015-04-01 Aidan Kehoe <kehoea@parhasard.net> When calling #'string-match with a REGEXP without regular expression special characters, call #'search, #'mismatch, #'find, etc. instead, making our code less likely to side-effect other functions' match data and a little faster. * apropos.el (apropos-command): * apropos.el (apropos): Call (position ?\n ...) rather than (string-match "\n" ...) here. * buff-menu.el: * buff-menu.el (buffers-menu-omit-invisible-buffers): Don't fire up the regexp engine just to check if a string starts with a space. * buff-menu.el (select-buffers-tab-buffers-by-mode): Don't fire up the regexp engine just to compare mode basenames. * buff-menu.el (format-buffers-tab-line): * buff-menu.el (build-buffers-tab-internal): Moved to being a label within the following. * buff-menu.el (buffers-tab-items): Use the label. * bytecomp.el (byte-compile-log-1): Don't fire up the regexp engine just to look for a newline. * cus-edit.el (get): Ditto. * cus-edit.el (custom-variable-value-create): Ditto, but for a colon. * descr-text.el (describe-text-sexp): Ditto. * descr-text.el (describe-char-unicode-data): Use #'split-string-by-char given that we're just looking for a semicolon. * descr-text.el (describe-char): Don't fire up the regexp engine just to look for a newline. * disass.el (disassemble-internal): Ditto. * files.el (file-name-sans-extension): Implement this using #'position. * files.el (file-name-extension): Correct this function's docstring, implement it in terms of #'position. * files.el (insert-directory): Don't fire up the regexp engine to split a string by space; don't reverse the list of switches, this is actually a longstand bug as far as I can see. * gnuserv.el (gnuserv-process-filter): Use #'position here, instead of consing inside #'split-string needlessly. * gtk-file-dialog.el (gtk-file-dialog-update-dropdown): Use #'split-string-by-char here, don't fire up #'split-string for directory-sep-char. * gtk-font-menu.el (hack-font-truename): Implement this more cheaply in terms of #'find, #'split-string-by-char, #'equal, rather than #'string-match, #'split-string, #'string-equal. * hyper-apropos.el (hyper-apropos-grok-functions): * hyper-apropos.el (hyper-apropos-grok-variables): Look for a newline using #'position rather than #'string-match in these functions. * info.el (Info-insert-dir): * info.el (Info-insert-file-contents): * info.el (Info-follow-reference): * info.el (Info-extract-menu-node-name): * info.el (Info-menu): Look for fixed strings using #'position or #'search as appropriate in this file. * ldap.el (ldap-decode-string): * ldap.el (ldap-encode-string): #'encode-coding-string, #'decode-coding-string are always available, don't check if they're fboundp. * ldap.el (ldap-decode-address): * ldap.el (ldap-encode-address): Use #'split-string-by-char in these functions. * lisp-mnt.el (lm-creation-date): * lisp-mnt.el (lm-last-modified-date): Don't fire up the regexp engine just to look for spaces in this file. * menubar-items.el (default-menubar): Use (not (mismatch ...)) rather than #'string-match here, for simple regexp. Use (search "beta" ...) rather than (string-match "beta" ...) * menubar-items.el (sort-buffers-menu-alphabetically): * menubar-items.el (sort-buffers-menu-by-mode-then-alphabetically): * menubar-items.el (group-buffers-menu-by-mode-then-alphabetically): Don't fire up the regexp engine to check if a string starts with a space or an asterisk. Use the more fine-grained results of #'compare-strings; compare case-insensitively for the buffer menu. * menubar-items.el (list-all-buffers): * menubar-items.el (tutorials-menu-filter): Use #'equal rather than #'string-equal, which, in this context, has the drawback of not having a bytecode, and no redeeming features. * minibuf.el: * minibuf.el (un-substitute-in-file-name): Use #'count, rather than counting the occurences of $ using the regexp engine. * minibuf.el (read-file-name-internal-1): Don't fire up the regexp engine to search for ?=. * mouse.el (mouse-eval-sexp): Check for newline with #'find. * msw-font-menu.el (mswindows-reset-device-font-menus): Split a string by newline with #'split-string-by-char. * mule/japanese.el: * mule/japanese.el ("Japanese"): Use #'search rather than #'string-match; canoncase before comparing; fix a bug I had introduced where I had been making case insensitive comparisons where the case mattered. * mule/korea-util.el (default-korean-keyboard): Look for ?3 using #'find, not #'string-march. * mule/korea-util.el (quail-hangul-switch-hanja): Search for a fixed string using #'search. * mule/mule-cmds.el (set-locale-for-language-environment): #'position, #'substitute rather than #'string-match, #'replace-in-string. * newcomment.el (comment-make-extra-lines): Use #'search rather than #'string-match for a simple string. * package-get.el (package-get-remote-filename): Use #'position when looking for ?@ * process.el (setenv): * process.el (read-envvar-name): Use #'position when looking for ?=. * replace.el (map-query-replace-regexp): Use #'split-string-by-char instead of using an inline implementation of it. * select.el (select-convert-from-cf-text): * select.el (select-convert-from-cf-unicodetext): Use #'position rather than #'string-match in these functions. * setup-paths.el (paths-emacs-data-root-p): Use #'search when looking for simple string. * sound.el (load-sound-file): Use #'split-string-by-char rather than an inline reimplementation of same. * startup.el (splash-screen-window-body): * startup.el (splash-screen-tty-body): Search for simple strings using #'search. * version.el (emacs-version): Ditto. * x-font-menu.el (hack-font-truename): Implement this more cheaply in terms of #'find, #'split-string-by-char, #'equal, rather than #'string-match, #'split-string, #'string-equal. * x-font-menu.el (x-reset-device-font-menus-core): Use #'split-string-by-char here. * x-init.el (x-initialize-keyboard): Search for a simple string using #'search.
author Aidan Kehoe <kehoea@parhasard.net>
date Wed, 01 Apr 2015 14:28:20 +0100
parents cc6f0266bc36
children
line wrap: on
line source

;;; x-font-menu.el --- Managing menus of X 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>

;; 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 3 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.
;;; 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)

(when (featurep 'xft-fonts)
  (require 'fontconfig))

(globally-declare-boundp
 '(x-font-regexp
   x-font-regexp-foundry-and-family
   x-font-regexp-spacing))

(globally-declare-boundp
 '(charset-registries
   fc-find-available-font-families
   fc-find-available-weights-for-family
   fc-font-match
   fc-font-slant-translate-from-string
   fc-font-slant-translate-to-string
   fc-font-weight-translate-from-string
   fc-font-weight-translate-to-string
   fc-name-parse
   fc-name-unparse
   fc-pattern-add-family
   fc-pattern-add-size
   fc-pattern-add-slant
   fc-pattern-add-weight
   fc-pattern-get-family
   fc-pattern-get-size
   fc-pattern-get-slant
   fc-pattern-get-successp
   fc-pattern-get-weight
   make-fc-pattern
   xlfd-font-name-p))

(defvar x-font-menu-registry-encoding nil
  "Registry and encoding to use with font menu fonts.")

(defvar x-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.
     )
   "\\|")
  "Regexp matching font families which should not be menu-selectable.
E.g. cursor fonts.")

(defun hack-font-truename (fn)
  ;; #### Are "font sets" XFontSets?
  ;; #### Is this useful if not configure'd --with-xfs?
  ;; #### This is duplicated in gtk-font-menu.el.
  "Filter the output of `font-instance-truename' to deal with font sets."
  (let ((font-instance-truename (font-instance-truename fn)))
    (if (find ?, font-instance-truename)
        (let ((fpnt (nth 8 (split-string-by-char (font-instance-name fn) ?-)))
              (flist (split-string-by-char font-instance-truename ?,))
              ret)
          (while flist
            (if (equal fpnt (nth 8 (split-string-by-char (car flist) ?-)))
                (progn (setq ret (car flist)) (setq flist nil))
              (setq flist (cdr flist))))
          ret)
      font-instance-truename)))

(defvar x-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.")

;; #### move these to font-menu.el, and maybe make them defcustoms
(defvar font-menu-common-sizes
  '(60 80 100 110 120 130 140 150 160 170 180 200 220 240 300 360)
  "List of commonly desired font sizes in decipoints.")

;;;###autoload
(defun x-reset-device-font-menus (device &optional debug)
  (if (featurep 'xft-fonts)
      (x-reset-device-font-menus-xft device debug)
    (x-reset-device-font-menus-core device debug)))

(defun fc-make-font-menu-entry (family)
  (let ((weights (fc-find-available-weights-for-family family)))
    (vector
     family
     (mapcar 
      (lambda (weight-symbol) 
        (let ((pair (assoc weight-symbol
                           '((:light "Light")
                             (:medium "Medium")
                             (:demibold "Demibold")
                             (:bold "Bold")
                             (:black "Black")))))
          (if pair (cadr pair))))
      weights)
     '(0)
     nil)))

(defun x-reset-device-font-menus-xft (device &optional debug)
  (let* ((families-1 (fc-find-available-font-families device))
	 (families (delete-if (lambda (x)
				(string-match x-fonts-menu-junk-families x))
			      (sort families-1 'string-lessp)))
	 (data
	  (vector
	   (mapcar 'fc-make-font-menu-entry families)
	   (mapcar 
            (lambda (family)
              (vector family `(font-menu-set-font ,family nil nil)
                      :style 'radio :active nil :selected nil))
	    families)
	   (mapcar
	    (lambda (size)
              (vector
               (number-to-string size)
               `(font-menu-set-font nil nil ,size)
               :style 'radio :active nil :selected nil))
	    ;; common size list in decipoints, fontconfig wants points
	    (mapcar (lambda (x) (/ x 10)) font-menu-common-sizes))
	   (mapcar
	    (lambda (weight)
              (vector
               weight
               `(font-menu-set-font nil ,weight nil)
               :style 'radio :active nil :selected nil))
	    '("Light" "Medium" "Demibold" "Bold" "Black"))))
	 ;; get or initialize the entry for device
	 (dev-cache (or (assq device device-fonts-cache)
			(car (push (list device) device-fonts-cache)))))
    ;; update the device-fonts-cache entry for device in place
    (setcdr dev-cache data)
    data))

(defun x-reset-device-font-menus-core (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 font-list again.
  (unless x-font-regexp-ascii
    (setq x-font-regexp-ascii 
          (if (fboundp 'charset-registries) 
              (elt (charset-registries 'ascii) 0)
            "iso8859-1")))
  (setq x-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
			 (font-list "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device
				     font-menu-max-number))
			((stringp debug) (split-string-by-char debug ?\n))
			(t debug)))
      (when (and (string-match x-font-regexp-ascii name)
		 (string-match x-font-regexp name))
	(setq weight (capitalize (match-string 1 name))
	      size   (string-to-int (match-string 6 name)))
	(or (string-match x-font-regexp-foundry-and-family name)
	    (error "internal error"))
	(setq family (capitalize (match-string 1 name)))
	(or (string-match x-font-regexp-spacing name)
	    (error "internal error"))
	(setq monospaced-p (string= "m" (match-string 1 name)))
	(unless (string-match x-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 font-menu-common-sizes))
	  (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 (delete* 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))
			    (number-to-string (/ x 10.0))
			  (number-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 x-font-menu-font-data (face dcache)
   (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))))
     (if (featurep 'xft-fonts)
	 (if (xlfd-font-name-p name)
	     ;; #### this call to x-font-menu-font-data-core originally
	     ;; had 4 args, and that's probably the right way to go
	     (x-font-menu-font-data-core face dcache)
	   (x-font-menu-font-data-xft face dcache name (selected-device)))
       ;; #### this one, too
       (x-font-menu-font-data-core face dcache))))

(defun x-font-menu-font-data-xft (face dcache name domain)
  ;; DOMAIN is expected to be a device.
  (let* ((truename (font-instance-truename
		    (face-font-instance face domain
					(if (featurep 'mule) 'ascii))))
	 entry)
    (if (xlfd-font-name-p truename)
	(progn
	  nil)
      (progn
	(let* ((pattern (fc-font-match domain (fc-name-parse name)))
	       (family (and pattern
			    (fc-pattern-get-family pattern 0))))
	  (if (fc-pattern-get-successp family)
	    (setq entry (vassoc family (aref dcache 0))))
	  (if (null entry)
	      (make-vector 5 nil)
	    (let ((weight (fc-pattern-get-weight pattern 0))
		  (size (fc-pattern-get-size pattern 0))
		  (slant (fc-pattern-get-slant pattern 0)))
	      (vector
	       entry
	       (if (fc-pattern-get-successp family) 
		   family)
	       (if (fc-pattern-get-successp size)
		   size)
	       (if (fc-pattern-get-successp weight)
		   (fc-font-weight-translate-to-string weight))
	       (if (fc-pattern-get-successp slant)
		   (fc-font-slant-translate-to-string slant))))))))))

(defun x-font-menu-font-data-core (face dcache)
  (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 x-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 x-font-regexp-foundry-and-family truename))
      (setq family (capitalize (match-string 1 truename)))
      (setq entry  (vassoc family (aref dcache 0))))

    (if (null entry)
	(make-vector 5 nil)

      (when (string-match x-font-regexp name)
	(setq weight (capitalize    (match-string 1 name)))
	(setq size   (string-to-int (match-string 6 name))))
      
      (when (string-match x-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 x-font-menu-load-font (family weight size slant resolution)
  (if (featurep 'xft-fonts)
      (x-font-menu-load-font-xft family weight size slant resolution)
    (x-font-menu-load-font-core family weight size slant resolution)))

(defun x-font-menu-load-font-xft (family weight size slant resolution)
  (let ((pattern (make-fc-pattern)))
    (fc-pattern-add-family pattern family)
    (if weight 
	(fc-pattern-add-weight pattern
			       (fc-font-weight-translate-from-string weight)))
    (if size
	(fc-pattern-add-size pattern size))
    (if slant
	(fc-pattern-add-slant pattern
			      (fc-font-slant-translate-from-string slant)))
    (make-font-instance (fc-name-unparse pattern))))

(defun x-font-menu-load-font-core (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 "-*-*-"
				  x-font-menu-registry-encoding)
			 nil t))
	      (throw 'got-font font))))))))

(provide 'x-font-menu)

;;; x-font-menu.el ends here