Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 108:360340f9fd5f r20-1b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b6
author cvs
date Mon, 13 Aug 2007 09:18:39 +0200
parents 0d2f883870bc
children fe104dbd9147
comparison
equal deleted inserted replaced
107:523141596bda 108:360340f9fd5f
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.
374 (defun font-create-name (fontobj &optional device) 374 (defun font-create-name (fontobj &optional device)
375 (let* ((type (device-type device)) 375 (let* ((type (device-type device))
376 (func (car (cdr-safe (assq type font-window-system-mappings))))) 376 (func (car (cdr-safe (assq type font-window-system-mappings)))))
377 (and func (fboundp func) (funcall func fontobj device)))) 377 (and func (fboundp func) (funcall func fontobj device))))
378 378
379 ;;;###autoload
379 (defun font-create-object (fontname &optional device) 380 (defun font-create-object (fontname &optional device)
380 (let* ((type (device-type device)) 381 (let* ((type (device-type device))
381 (func (car (cdr (cdr-safe (assq type font-window-system-mappings)))))) 382 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
382 (and func (fboundp func) (funcall func fontname device)))) 383 (and func (fboundp func) (funcall func fontname device))))
383 384
534 (sort (unique (nconc scaled normal)) 'string-lessp)))) 535 (sort (unique (nconc scaled normal)) 'string-lessp))))
535 (mapcar 'car font-family-mappings))) 536 (mapcar 'car font-family-mappings)))
536 537
537 (defvar font-default-cache nil) 538 (defvar font-default-cache nil)
538 539
540 ;;;###autoload
539 (defun font-default-font-for-device (&optional device) 541 (defun font-default-font-for-device (&optional device)
540 (or device (setq device (selected-device))) 542 (or device (setq device (selected-device)))
541 (if font-running-xemacs 543 (if font-running-xemacs
542 (font-truename 544 (font-truename
543 (make-font-specifier 545 (make-font-specifier
545 (let ((font (cdr-safe (assq 'font (frame-parameters device))))) 547 (let ((font (cdr-safe (assq 'font (frame-parameters device)))))
546 (if (and (fboundp 'fontsetp) (fontsetp font)) 548 (if (and (fboundp 'fontsetp) (fontsetp font))
547 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2) 549 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
548 font)))) 550 font))))
549 551
552 ;;;###autoload
550 (defun font-default-object-for-device (&optional device) 553 (defun font-default-object-for-device (&optional device)
551 (let ((font (font-default-font-for-device device))) 554 (let ((font (font-default-font-for-device device)))
552 (or (cdr-safe 555 (or (cdr-safe
553 (assoc font font-default-cache)) 556 (assoc font font-default-cache))
554 (progn 557 (progn
555 (setq font-default-cache (cons (cons font 558 (setq font-default-cache (cons (cons font
556 (font-create-object font)) 559 (font-create-object font))
557 font-default-cache)) 560 font-default-cache))
558 (cdr-safe (assoc font font-default-cache)))))) 561 (cdr-safe (assoc font font-default-cache))))))
559 562
563 ;;;###autoload
560 (defun font-default-family-for-device (&optional device) 564 (defun font-default-family-for-device (&optional device)
561 (or device (setq device (selected-device))) 565 (or device (setq device (selected-device)))
562 (font-family (font-default-object-for-device device))) 566 (font-family (font-default-object-for-device device)))
563 567
568 ;;;###autoload
564 (defun font-default-size-for-device (&optional device) 569 (defun font-default-size-for-device (&optional device)
565 (or device (setq device (selected-device))) 570 (or device (setq device (selected-device)))
566 ;; face-height isn't the right thing (always 1 pixel too high?) 571 ;; face-height isn't the right thing (always 1 pixel too high?)
567 ;; (if font-running-xemacs 572 ;; (if font-running-xemacs
568 ;; (format "%dpx" (face-height 'default device)) 573 ;; (format "%dpx" (face-height 'default device))
694 done (try-font-name font-name device)))) 699 done (try-font-name font-name device))))
695 (if done font-name)))) 700 (if done font-name))))
696 701
697 702
698 ;;; Cache building code 703 ;;; Cache building code
704 ;;;###autoload
699 (defun x-font-build-cache (&optional device) 705 (defun x-font-build-cache (&optional device)
700 (let ((hashtable (make-hash-table :test 'equal :size 15)) 706 (let ((hashtable (make-hash-table :test 'equal :size 15))
701 (fonts (mapcar 'x-font-create-object 707 (fonts (mapcar 'x-font-create-object
702 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))) 708 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
703 (plist nil) 709 (plist nil)
724 730
725 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 731 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
726 ;;; Now overwrite the original copy of set-face-font with our own copy that 732 ;;; Now overwrite the original copy of set-face-font with our own copy that
727 ;;; can deal with either syntax. 733 ;;; can deal with either syntax.
728 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 734 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
735 ;;; ###autoload
729 (defun font-set-face-font (&optional face font &rest args) 736 (defun font-set-face-font (&optional face font &rest args)
730 (if (interactive-p) 737 (cond
731 (call-interactively 'font-original-set-face-font) 738 ((and (vectorp font) (= (length font) 12))
732 (cond 739 (let ((font-name (font-create-name font)))
733 ((and (vectorp font) (= (length font) 12)) 740 (set-face-property face 'font-specification font)
734 (let ((font-name (font-create-name font))) 741 (cond
735 (set-face-property face 'font-specification font) 742 ((null font-name) ; No matching font!
736 (cond 743 nil)
737 ((null font-name) ; No matching font! 744 ((listp font-name) ; For TTYs
738 nil) 745 (let (cur)
739 ((listp font-name) ; For TTYs 746 (while font-name
740 (let (cur) 747 (setq cur (car font-name)
741 (while font-name 748 font-name (cdr font-name))
742 (setq cur (car font-name) 749 (apply 'set-face-property face (car cur) (cdr cur) args))))
743 font-name (cdr font-name)) 750 (font-running-xemacs
744 (apply 'set-face-property face (car cur) (cdr cur) args)))) 751 (apply 'set-face-font face font-name args)
745 (font-running-xemacs 752 (apply 'set-face-underline-p face (font-underline-p font) args)
746 (apply 'font-original-set-face-font face font-name args) 753 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
747 (apply 'set-face-underline-p face (font-underline-p font) args) 754 (fboundp 'set-face-display-table))
748 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font)) 755 (apply 'set-face-display-table
749 (fboundp 'set-face-display-table)) 756 face font-caps-display-table args))
750 (apply 'set-face-display-table 757 (apply 'set-face-property face 'strikethru (or
751 face font-caps-display-table args)) 758 (font-linethrough-p font)
752 (apply 'set-face-property face 'strikethru (or 759 (font-strikethru-p font))
753 (font-linethrough-p font) 760 args))
754 (font-strikethru-p font)) 761 (t
755 args)) 762 (condition-case nil
756 (t 763 (apply 'set-face-font face font-name args)
757 (condition-case nil 764 (error
758 (apply 'font-original-set-face-font face font-name args) 765 (let ((args (car-safe args)))
759 (error 766 (and (or (font-bold-p font)
760 (let ((args (car-safe args))) 767 (memq (font-weight font) '(:bold :demi-bold)))
761 (and (or (font-bold-p font) 768 (make-face-bold face args t))
762 (memq (font-weight font) '(:bold :demi-bold))) 769 (and (font-italic-p font) (make-face-italic face args t)))))
763 (make-face-bold face args t)) 770 (apply 'set-face-underline-p face (font-underline-p font) args)))))
764 (and (font-italic-p font) (make-face-italic face args t))))) 771 (t
765 (apply 'set-face-underline-p face (font-underline-p font) args))))) 772 ;; Let the original set-face-font signal any errors
766 (t 773 (set-face-property face 'font-specification nil)
767 ;; Let the original set-face-font signal any errors 774 (apply 'set-face-font face font args))))
768 (set-face-property face 'font-specification nil)
769 (apply 'font-original-set-face-font face font args)))))
770 775
771 776
772 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 777 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
773 ;;; Now for emacsen specific stuff 778 ;;; Now for emacsen specific stuff
774 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 779 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1077 (apply 'format "RGB%02x%02x%02xff" vals))) 1082 (apply 'format "RGB%02x%02x%02xff" vals)))
1078 (otherwise "black"))) 1083 (otherwise "black")))
1079 1084
1080 (defun font-set-face-background (&optional face color &rest args) 1085 (defun font-set-face-background (&optional face color &rest args)
1081 (interactive) 1086 (interactive)
1082 (if (interactive-p) 1087 (condition-case nil
1083 (call-interactively 'font-original-set-face-background) 1088 (cond
1084 (cond 1089 ((font-rgb-color-p color)
1085 ((font-rgb-color-p color) 1090 (apply 'set-face-background face
1086 (apply 'font-original-set-face-background face 1091 (font-normalize-color color) args))
1087 (font-normalize-color color) args)) 1092 (t
1088 (t 1093 (apply 'set-face-background face color args)))
1089 (apply 'font-original-set-face-background face color args))))) 1094 (error nil)))
1090 1095
1091 (defun font-set-face-foreground (&optional face color &rest args) 1096 (defun font-set-face-foreground (&optional face color &rest args)
1092 (interactive) 1097 (interactive)
1093 (if (interactive-p) 1098 (condition-case nil
1094 (call-interactively 'font-original-set-face-foreground) 1099 (cond
1095 (cond 1100 ((font-rgb-color-p color)
1096 ((font-rgb-color-p color) 1101 (apply 'set-face-foreground face (font-normalize-color color) args))
1097 (apply 'font-original-set-face-foreground face 1102 (t
1098 (font-normalize-color color) args)) 1103 (apply 'set-face-foreground face color args)))
1099 (t 1104 (error nil)))
1100 (apply 'font-original-set-face-foreground face color args)))))
1101
1102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1103 ;;; Do the actual overwriting of some functions
1104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1105 (defmacro font-overwrite-fn (func)
1106 (` (let ((our-func (intern (format "font-%s" (, func))))
1107 (new-func (intern (format "font-original-%s" (, func))))
1108 (old-func (and (fboundp (, func)) (symbol-function (, func)))))
1109 (if (not (fboundp new-func))
1110 (progn
1111 (if old-func
1112 (fset new-func old-func)
1113 (fset new-func 'ignore))
1114 (fset (, func) our-func))))))
1115
1116 (font-overwrite-fn 'set-face-foreground)
1117 (font-overwrite-fn 'set-face-background)
1118 (font-overwrite-fn 'set-face-font)
1119 1105
1120 (provide 'font) 1106 (provide 'font)