Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 859a2309aef8
children e04119814345
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
1 ;;; font.el --- New font model 1 ;;; font.el --- New font model
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/02/08 00:56:14 3 ;; Created: 1997/03/03 15:15:42
4 ;; Version: 1.33 4 ;; Version: 1.34
5 ;; Keywords: faces 5 ;; Keywords: faces
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
371 (defun font-create-name (fontobj &optional device) 371 (defun font-create-name (fontobj &optional device)
372 (let* ((type (device-type device)) 372 (let* ((type (device-type device))
373 (func (car (cdr-safe (assq type font-window-system-mappings))))) 373 (func (car (cdr-safe (assq type font-window-system-mappings)))))
374 (and func (fboundp func) (funcall func fontobj device)))) 374 (and func (fboundp func) (funcall func fontobj device))))
375 375
376 ;;;###autoload
376 (defun font-create-object (fontname &optional device) 377 (defun font-create-object (fontname &optional device)
377 (let* ((type (device-type device)) 378 (let* ((type (device-type device))
378 (func (car (cdr (cdr-safe (assq type font-window-system-mappings)))))) 379 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
379 (and func (fboundp func) (funcall func fontname device)))) 380 (and func (fboundp func) (funcall func fontname device))))
380 381
531 (sort (unique (nconc scaled normal)) 'string-lessp)))) 532 (sort (unique (nconc scaled normal)) 'string-lessp))))
532 (mapcar 'car font-family-mappings))) 533 (mapcar 'car font-family-mappings)))
533 534
534 (defvar font-default-cache nil) 535 (defvar font-default-cache nil)
535 536
537 ;;;###autoload
536 (defun font-default-font-for-device (&optional device) 538 (defun font-default-font-for-device (&optional device)
537 (or device (setq device (selected-device))) 539 (or device (setq device (selected-device)))
538 (if font-running-xemacs 540 (if font-running-xemacs
539 (font-truename 541 (font-truename
540 (make-font-specifier 542 (make-font-specifier
542 (let ((font (cdr-safe (assq 'font (frame-parameters device))))) 544 (let ((font (cdr-safe (assq 'font (frame-parameters device)))))
543 (if (and (fboundp 'fontsetp) (fontsetp font)) 545 (if (and (fboundp 'fontsetp) (fontsetp font))
544 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2) 546 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
545 font)))) 547 font))))
546 548
549 ;;;###autoload
547 (defun font-default-object-for-device (&optional device) 550 (defun font-default-object-for-device (&optional device)
548 (let ((font (font-default-font-for-device device))) 551 (let ((font (font-default-font-for-device device)))
549 (or (cdr-safe 552 (or (cdr-safe
550 (assoc font font-default-cache)) 553 (assoc font font-default-cache))
551 (progn 554 (progn
552 (setq font-default-cache (cons (cons font 555 (setq font-default-cache (cons (cons font
553 (font-create-object font)) 556 (font-create-object font))
554 font-default-cache)) 557 font-default-cache))
555 (cdr-safe (assoc font font-default-cache)))))) 558 (cdr-safe (assoc font font-default-cache))))))
556 559
560 ;;;###autoload
557 (defun font-default-family-for-device (&optional device) 561 (defun font-default-family-for-device (&optional device)
558 (or device (setq device (selected-device))) 562 (or device (setq device (selected-device)))
559 (font-family (font-default-object-for-device device))) 563 (font-family (font-default-object-for-device device)))
560 564
565 ;;;###autoload
561 (defun font-default-size-for-device (&optional device) 566 (defun font-default-size-for-device (&optional device)
562 (or device (setq device (selected-device))) 567 (or device (setq device (selected-device)))
563 ;; face-height isn't the right thing (always 1 pixel too high?) 568 ;; face-height isn't the right thing (always 1 pixel too high?)
564 ;; (if font-running-xemacs 569 ;; (if font-running-xemacs
565 ;; (format "%dpx" (face-height 'default device)) 570 ;; (format "%dpx" (face-height 'default device))
691 done (try-font-name font-name device)))) 696 done (try-font-name font-name device))))
692 (if done font-name)))) 697 (if done font-name))))
693 698
694 699
695 ;;; Cache building code 700 ;;; Cache building code
701 ;;;###autoload
696 (defun x-font-build-cache (&optional device) 702 (defun x-font-build-cache (&optional device)
697 (let ((hashtable (make-hash-table :test 'equal :size 15)) 703 (let ((hashtable (make-hash-table :test 'equal :size 15))
698 (fonts (mapcar 'x-font-create-object 704 (fonts (mapcar 'x-font-create-object
699 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))) 705 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
700 (plist nil) 706 (plist nil)
721 727
722 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 728 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
723 ;;; Now overwrite the original copy of set-face-font with our own copy that 729 ;;; Now overwrite the original copy of set-face-font with our own copy that
724 ;;; can deal with either syntax. 730 ;;; can deal with either syntax.
725 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 731 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
732 ;;; ###autoload
726 (defun font-set-face-font (&optional face font &rest args) 733 (defun font-set-face-font (&optional face font &rest args)
727 (if (interactive-p) 734 (cond
728 (call-interactively 'font-original-set-face-font) 735 ((and (vectorp font) (= (length font) 12))
729 (cond 736 (let ((font-name (font-create-name font)))
730 ((and (vectorp font) (= (length font) 12)) 737 (set-face-property face 'font-specification font)
731 (let ((font-name (font-create-name font))) 738 (cond
732 (set-face-property face 'font-specification font) 739 ((null font-name) ; No matching font!
733 (cond 740 nil)
734 ((null font-name) ; No matching font! 741 ((listp font-name) ; For TTYs
735 nil) 742 (let (cur)
736 ((listp font-name) ; For TTYs 743 (while font-name
737 (let (cur) 744 (setq cur (car font-name)
738 (while font-name 745 font-name (cdr font-name))
739 (setq cur (car font-name) 746 (apply 'set-face-property face (car cur) (cdr cur) args))))
740 font-name (cdr font-name)) 747 (font-running-xemacs
741 (apply 'set-face-property face (car cur) (cdr cur) args)))) 748 (apply 'set-face-font face font-name args)
742 (font-running-xemacs 749 (apply 'set-face-underline-p face (font-underline-p font) args)
743 (apply 'font-original-set-face-font face font-name args) 750 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
744 (apply 'set-face-underline-p face (font-underline-p font) args) 751 (fboundp 'set-face-display-table))
745 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font)) 752 (apply 'set-face-display-table
746 (fboundp 'set-face-display-table)) 753 face font-caps-display-table args))
747 (apply 'set-face-display-table 754 (apply 'set-face-property face 'strikethru (or
748 face font-caps-display-table args)) 755 (font-linethrough-p font)
749 (apply 'set-face-property face 'strikethru (or 756 (font-strikethru-p font))
750 (font-linethrough-p font) 757 args))
751 (font-strikethru-p font)) 758 (t
752 args)) 759 (condition-case nil
753 (t 760 (apply 'set-face-font face font-name args)
754 (condition-case nil 761 (error
755 (apply 'font-original-set-face-font face font-name args) 762 (let ((args (car-safe args)))
756 (error 763 (and (or (font-bold-p font)
757 (let ((args (car-safe args))) 764 (memq (font-weight font) '(:bold :demi-bold)))
758 (and (or (font-bold-p font) 765 (make-face-bold face args t))
759 (memq (font-weight font) '(:bold :demi-bold))) 766 (and (font-italic-p font) (make-face-italic face args t)))))
760 (make-face-bold face args t)) 767 (apply 'set-face-underline-p face (font-underline-p font) args)))))
761 (and (font-italic-p font) (make-face-italic face args t))))) 768 (t
762 (apply 'set-face-underline-p face (font-underline-p font) args))))) 769 ;; Let the original set-face-font signal any errors
763 (t 770 (set-face-property face 'font-specification nil)
764 ;; Let the original set-face-font signal any errors 771 (apply 'set-face-font face font args))))
765 (set-face-property face 'font-specification nil)
766 (apply 'font-original-set-face-font face font args)))))
767 772
768 773
769 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 774 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
770 ;;; Now for emacsen specific stuff 775 ;;; Now for emacsen specific stuff
771 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1074 (apply 'format "RGB%02x%02x%02xff" vals))) 1079 (apply 'format "RGB%02x%02x%02xff" vals)))
1075 (otherwise "black"))) 1080 (otherwise "black")))
1076 1081
1077 (defun font-set-face-background (&optional face color &rest args) 1082 (defun font-set-face-background (&optional face color &rest args)
1078 (interactive) 1083 (interactive)
1079 (if (interactive-p) 1084 (condition-case nil
1080 (call-interactively 'font-original-set-face-background) 1085 (cond
1081 (cond 1086 ((font-rgb-color-p color)
1082 ((font-rgb-color-p color) 1087 (apply 'set-face-background face
1083 (apply 'font-original-set-face-background face 1088 (font-normalize-color color) args))
1084 (font-normalize-color color) args)) 1089 (t
1085 (t 1090 (apply 'set-face-background face color args)))
1086 (apply 'font-original-set-face-background face color args))))) 1091 (error nil)))
1087 1092
1088 (defun font-set-face-foreground (&optional face color &rest args) 1093 (defun font-set-face-foreground (&optional face color &rest args)
1089 (interactive) 1094 (interactive)
1090 (if (interactive-p) 1095 (condition-case nil
1091 (call-interactively 'font-original-set-face-foreground) 1096 (cond
1092 (cond 1097 ((font-rgb-color-p color)
1093 ((font-rgb-color-p color) 1098 (apply 'set-face-foreground face (font-normalize-color color) args))
1094 (apply 'font-original-set-face-foreground face 1099 (t
1095 (font-normalize-color color) args)) 1100 (apply 'set-face-foreground face color args)))
1096 (t 1101 (error nil)))
1097 (apply 'font-original-set-face-foreground face color args)))))
1098
1099 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1100 ;;; Do the actual overwriting of some functions
1101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1102 (defmacro font-overwrite-fn (func)
1103 (` (let ((our-func (intern (format "font-%s" (, func))))
1104 (new-func (intern (format "font-original-%s" (, func))))
1105 (old-func (and (fboundp (, func)) (symbol-function (, func)))))
1106 (if (not (fboundp new-func))
1107 (progn
1108 (if old-func
1109 (fset new-func old-func)
1110 (fset new-func 'ignore))
1111 (fset (, func) our-func))))))
1112
1113 (font-overwrite-fn 'set-face-foreground)
1114 (font-overwrite-fn 'set-face-background)
1115 (font-overwrite-fn 'set-face-font)
1116 1102
1117 (provide 'font) 1103 (provide 'font)