Mercurial > hg > xemacs-beta

comparison lisp/font.el @ 294:4b85ae5eabfb r21-0b45

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b45
author cvs
date Mon, 13 Aug 2007 10:38:01 +0200
parents c42ec1d1cded
children afd57c14dfc8
comparison
equal deleted inserted replaced
293:403535bfea94 294:4b85ae5eabfb
138 (defvar font-rgb-file nil 138 (defvar font-rgb-file nil
139 "Where the RGB file was found.") 139 "Where the RGB file was found.")
140 140
141 (defvar font-maximum-slippage "1pt" 141 (defvar font-maximum-slippage "1pt"
142 "How much a font is allowed to vary from the desired size.") 142 "How much a font is allowed to vary from the desired size.")
143
144 (defvar font-family-mappings
145 '(
146 ("serif" . ("new century schoolbook"
147 "utopia"
148 "charter"
149 "times"
150 "lucidabright"
151 "garamond"
152 "palatino"
153 "times new roman"
154 "baskerville"
155 "bookman"
156 "bodoni"
157 "computer modern"
158 "rockwell"
159 ))
160 ("sans-serif" . ("lucida"
161 "helvetica"
162 "gills-sans"
163 "avant-garde"
164 "univers"
165 "optima"))
166 ("elfin" . ("tymes"))
167 ("monospace" . ("courier"
168 "courier new"
169 "fixed"
170 "lucidatypewriter"
171 "clean"
172 "terminal"))
173 ("cursive" . ("sirene"
174 "zapf chancery"))
175 )
176 "A list of font family mappings.")
177 143
178 (define-font-keywords :family :style :size :registry :encoding) 144 (define-font-keywords :family :style :size :registry :encoding)
179 145
180 (define-font-keywords 146 (define-font-keywords
181 :weight :extra-light :light :demi-light :medium :normal :demi-bold 147 :weight :extra-light :light :demi-light :medium :normal :demi-bold
518 (let ((- "[-?]") 484 (let ((- "[-?]")
519 (registry "[^-]*") 485 (registry "[^-]*")
520 (encoding "[^-]+")) 486 (encoding "[^-]+"))
521 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")))) 487 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
522 488
489 (defvar font-x-family-mappings
490 '(
491 ("serif" . ("new century schoolbook"
492 "utopia"
493 "charter"
494 "times"
495 "lucidabright"
496 "garamond"
497 "palatino"
498 "times new roman"
499 "baskerville"
500 "bookman"
501 "bodoni"
502 "computer modern"
503 "rockwell"
504 ))
505 ("sans-serif" . ("lucida"
506 "helvetica"
507 "gills-sans"
508 "avant-garde"
509 "univers"
510 "optima"))
511 ("elfin" . ("tymes"))
512 ("monospace" . ("courier"
513 "fixed"
514 "lucidatypewriter"
515 "clean"
516 "terminal"))
517 ("cursive" . ("sirene"
518 "zapf chancery"))
519 )
520 "A list of font family mappings on X devices.")
521
523 (defun x-font-create-object (fontname &optional device) 522 (defun x-font-create-object (fontname &optional device)
524 (let ((case-fold-search t)) 523 (let ((case-fold-search t))
525 (if (or (not (stringp fontname)) 524 (if (or (not (stringp fontname))
526 (not (string-match font-x-font-regexp fontname))) 525 (not (string-match font-x-font-regexp fontname)))
527 (make-font) 526 (make-font)
581 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) 580 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0))))
582 (aref menu 0))) 581 (aref menu 0)))
583 (normal (mapcar (function (lambda (x) (if x (aref x 0)))) 582 (normal (mapcar (function (lambda (x) (if x (aref x 0))))
584 (aref menu 1)))) 583 (aref menu 1))))
585 (sort (font-unique (nconc scaled normal)) 'string-lessp)))) 584 (sort (font-unique (nconc scaled normal)) 'string-lessp))))
586 (cons "monospace" (mapcar 'car font-family-mappings)))) 585 (cons "monospace" (mapcar 'car font-x-family-mappings))))
587 586
588 (defvar font-default-cache nil) 587 (defvar font-default-cache nil)
589 588
590 ;;;###autoload 589 ;;;###autoload
591 (defun font-default-font-for-device (&optional device) 590 (defun font-default-font-for-device (&optional device)
669 (cur-family nil) ; current family we are checking 668 (cur-family nil) ; current family we are checking
670 ) 669 )
671 (while (and family (not done)) 670 (while (and family (not done))
672 (setq cur-family (car family) 671 (setq cur-family (car family)
673 family (cdr family)) 672 family (cdr family))
674 (if (assoc cur-family font-family-mappings) 673 (if (assoc cur-family font-x-family-mappings)
675 ;; If the family name is an alias as defined by 674 ;; If the family name is an alias as defined by
676 ;; font-family-mappings, then append those families 675 ;; font-x-family-mappings, then append those families
677 ;; to the front of 'family' and continue in the loop. 676 ;; to the front of 'family' and continue in the loop.
678 (setq family (append 677 (setq family (append
679 (cdr-safe (assoc cur-family 678 (cdr-safe (assoc cur-family
680 font-family-mappings)) 679 font-x-family-mappings))
681 family)) 680 family))
682 ;; Not an alias for a list of fonts, so we just check it. 681 ;; Not an alias for a list of fonts, so we just check it.
683 ;; First, convert all '-' to spaces so that we don't screw up 682 ;; First, convert all '-' to spaces so that we don't screw up
684 ;; the oh-so wonderful X font model. Wheee. 683 ;; the oh-so wonderful X font model. Wheee.
685 (let ((x (length cur-family))) 684 (let ((x (length cur-family)))
748 (cur-family nil) ; current family we are checking 747 (cur-family nil) ; current family we are checking
749 ) 748 )
750 (while (and family (not done)) 749 (while (and family (not done))
751 (setq cur-family (car family) 750 (setq cur-family (car family)
752 family (cdr family)) 751 family (cdr family))
753 (if (assoc cur-family font-family-mappings) 752 (if (assoc cur-family font-x-family-mappings)
754 ;; If the family name is an alias as defined by 753 ;; If the family name is an alias as defined by
755 ;; font-family-mappings, then append those families 754 ;; font-x-family-mappings, then append those families
756 ;; to the front of 'family' and continue in the loop. 755 ;; to the front of 'family' and continue in the loop.
756 ;; #### jhar: I don't know about ns font names, so using X mappings
757 (setq family (append 757 (setq family (append
758 (cdr-safe (assoc cur-family 758 (cdr-safe (assoc cur-family
759 font-family-mappings)) 759 font-x-family-mappings))
760 family)) 760 family))
761 ;; CARL: Need help here - I am not familiar with the NS font 761 ;; CARL: Need help here - I am not familiar with the NS font
762 ;; model 762 ;; model
763 (setq font-name "UNKNOWN FORMULA GOES HERE" 763 (setq font-name "UNKNOWN FORMULA GOES HERE"
764 done (try-font-name font-name device)))) 764 done (try-font-name font-name device))))
768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
769 ;;; The window-system dependent code (mswindows-style) 769 ;;; The window-system dependent code (mswindows-style)
770 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 770 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
771 771
772 ;;; mswindows fonts look like: 772 ;;; mswindows fonts look like:
773 ;;; fontname[:[weight][ style][:pointsize[:effects[:charset]]]] 773 ;;; fontname[:[weight][ style][:pointsize[:effects]]][:charset]
774 ;;; A minimal mswindows font spec looks like: 774 ;;; A minimal mswindows font spec looks like:
775 ;;; Courier New 775 ;;; Courier New
776 ;;; A maximal mswindows font spec looks like: 776 ;;; A maximal mswindows font spec looks like:
777 ;;; Courier New:Bold Italic:10:underline strikeout:ansi 777 ;;; Courier New:Bold Italic:10:underline strikeout:western
778 ;;; Missing parts of the font spec should be filled in with these values: 778 ;;; Missing parts of the font spec should be filled in with these values:
779 ;;; Courier New:Normal:10::ansi 779 ;;; Courier New:Normal:10::western
780 ;; "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$" 780 ;; "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$"
781 (defvar font-mswindows-font-regexp 781 (defvar font-mswindows-font-regexp
782 (let 782 (let
783 ((- ":") 783 ((- ":")
784 (fontname "\\([a-zA-Z ]+\\)") 784 (fontname "\\([a-zA-Z ]+\\)")
796 (:light . "Light") 796 (:light . "Light")
797 (:demi-light . "Demilight") 797 (:demi-light . "Demilight")
798 (:demi . "Demi") 798 (:demi . "Demi")
799 (:book . "Book") 799 (:book . "Book")
800 (:medium . "Medium") 800 (:medium . "Medium")
801 (:normal . "Medium") 801 (:normal . "Normal")
802 (:demi-bold . "Demibold") 802 (:demi-bold . "Demibold")
803 (:bold . "Bold") 803 (:bold . "Bold")
804 (:regular . "Regular") 804 (:regular . "Regular")
805 (:extra-bold . "Extrabold")) 805 (:extra-bold . "Extrabold"))
806 "An assoc list mapping keywords to actual mswindows specific strings 806 "An assoc list mapping keywords to actual mswindows specific strings
807 for use in the 'weight' field of an mswindows font string.") 807 for use in the 'weight' field of an mswindows font string.")
808 808
809 (defvar font-mswindows-family-mappings
810 '(
811 ("serif" . ("times new roman"
812 "century schoolbook"
813 "book antiqua"
814 "bookman old style"))
815 ("sans-serif" . ("arial"
816 "verdana"
817 "lucida sans unicode"))
818 ("monospace" . ("courier new"
819 "lucida console"
820 "courier"
821 "terminal"))
822 ("cursive" . ("roman"
823 "script"))
824 )
825 "A list of font family mappings on mswindows devices.")
809 826
810 (defun mswindows-font-create-object (fontname &optional device) 827 (defun mswindows-font-create-object (fontname &optional device)
811 (let ((case-fold-search t) 828 (let ((case-fold-search t)
812 (font (mswindows-font-canonicalize-name fontname))) 829 (font (mswindows-font-canonicalize-name fontname)))
813 (if (or (not (stringp font)) 830 (if (or (not (stringp font))
814 (not (string-match font-mswindows-font-regexp font))) 831 (not (string-match font-mswindows-font-regexp font)))
815 (make-font) 832 (make-font)
816 (let ((name (match-string 1 font)) 833 (let ((family (match-string 1 font))
817 (weight (match-string 2 font)) 834 (weight (match-string 2 font))
818 (style (match-string 3 font)) 835 (style (match-string 3 font))
819 (pointsize (match-string 4 font)) 836 (pointsize (match-string 4 font))
820 (effects (match-string 5 font)) 837 (effects (match-string 5 font))
821 (charset (match-string 6 font)) 838 (charset (match-string 6 font))
822 (retval nil) 839 (retval nil)
823 (size nil) 840 (size nil)
824 (case-fold-search t) 841 (case-fold-search t)
825 ) 842 )
826 (if pointsize (setq size (/ (string-to-int pointsize) 10))) 843 (if pointsize (setq size (concat pointsize "pt")))
827 (if weight (setq weight (intern-soft (concat ":" (downcase weight))))) 844 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
828 (setq retval (make-font :family name 845 (setq retval (make-font :family family
829 :weight weight 846 :weight weight
830 :size size)) 847 :size size
848 :encoding charset))
831 (set-font-bold-p retval (eq :bold weight)) 849 (set-font-bold-p retval (eq :bold weight))
832 (cond 850 (cond
833 ((null style) nil) 851 ((null style) nil)
834 ((string-match "^[iI]talic" style) 852 ((string-match "^ *[iI]talic" style)
835 (set-font-italic-p retval t))) 853 (set-font-italic-p retval t)))
854 (cond
855 ((null effects) nil)
856 ((string-match "^[uU]nderline [sS]trikeout" effects)
857 (set-font-underline-p retval t)
858 (set-font-strikethru-p retval t))
859 ((string-match "[uU]nderline" effects)
860 (set-font-underline-p retval t))
861 ((string-match "[sS]trikeout" effects)
862 (set-font-strikethru-p retval t)))
836 retval)))) 863 retval))))
837 864
838 (defun mswindows-font-create-name (fontobj &optional device) 865 (defun mswindows-font-create-name (fontobj &optional device)
839 (if (and (not (or (font-family fontobj) 866 (if (and (not (or (font-family fontobj)
840 (font-weight fontobj) 867 (font-weight fontobj)
845 (face-font 'default) 872 (face-font 'default)
846 (or device (setq device (selected-device))) 873 (or device (setq device (selected-device)))
847 (let* ((default (font-default-object-for-device device)) 874 (let* ((default (font-default-object-for-device device))
848 (family (or (font-family fontobj) 875 (family (or (font-family fontobj)
849 (font-family default))) 876 (font-family default)))
850 (weight (or (font-weight fontobj) :medium)) 877 (weight (or (font-weight fontobj) :regular))
851 (style (font-style fontobj)) 878 (style (font-style fontobj))
852 (size (or (if font-running-xemacs 879 (size (or (if font-running-xemacs
853 (font-size fontobj)) 880 (font-size fontobj))
854 (font-size default))) 881 (font-size default)))
855 (registry (or (font-registry fontobj) 882 (underline-p (font-underline-p fontobj))
856 (font-registry default))) 883 (strikeout-p (font-strikethru-p fontobj))
857 (encoding (or (font-encoding fontobj) 884 (encoding (or (font-encoding fontobj)
858 (font-encoding default)))) 885 (font-encoding default))))
859 (if (stringp family) 886 (if (stringp family)
860 (setq family (list family))) 887 (setq family (list family)))
861 (setq weight (font-higher-weight weight 888 (setq weight (font-higher-weight weight
869 (cur-family nil) ; current family we are checking 896 (cur-family nil) ; current family we are checking
870 ) 897 )
871 (while (and family (not done)) 898 (while (and family (not done))
872 (setq cur-family (car family) 899 (setq cur-family (car family)
873 family (cdr family)) 900 family (cdr family))
874 (if (assoc cur-family font-family-mappings) 901 (if (assoc cur-family font-mswindows-family-mappings)
875 ;; If the family name is an alias as defined by 902 ;; If the family name is an alias as defined by
876 ;; font-family-mappings, then append those families 903 ;; font-mswindows-family-mappings, then append those families
877 ;; to the front of 'family' and continue in the loop. 904 ;; to the front of 'family' and continue in the loop.
878 (setq family (append 905 (setq family (append
879 (cdr-safe (assoc cur-family 906 (cdr-safe (assoc cur-family
880 font-family-mappings)) 907 font-mswindows-family-mappings))
881 family)) 908 family))
882 ;; We treat oblique and italic as equivalent. Don't ask. 909 ;; We treat oblique and italic as equivalent. Don't ask.
883 ;; Courier New:Bold Italic:10:underline strikeout:ansi 910 ;; Courier New:Bold Italic:10:underline strikeout:western
884 (setq font-name (format "%s:%s%s:%s:%s:%s" 911 (setq font-name (format "%s:%s%s:%s:%s:%s"
885 cur-family weight 912 cur-family weight
886 (if (font-italic-p fontobj) 913 (if (font-italic-p fontobj)
887 " Italic" "") 914 " Italic" "")
888 (if size 915 (if size
889 (int-to-string (* 10 size)) "10") 916 (int-to-string size) "10")
890 "" 917 (if underline-p
891 "") 918 (if strikeout-p
919 "underline strikeout"
920 "underline")
921 (if strikeout-p "strikeout" ""))
922 (if encoding
923 encoding ""))
892 done (try-font-name font-name device)))) 924 done (try-font-name font-name device))))
893 (if done font-name))))) 925 (if done font-name)))))
894 926
895 927
896 ;;; Cache building code 928 ;;; Cache building code