annotate lisp/font.el @ 502:7039e6323819

[xemacs-hg @ 2001-05-04 22:41:46 by ben] ----------------------- byte-comp warning fixes ----------------- New functions for cleanly eliminating byte-compiler warnings. Their definitions require no changes at all in bytecomp.el, meaning that any package that wants to use them and be compatible with older versions of XEmacs need only copy the code and rename the functions (i.e. prefix them with the package name). Eliminate byte-compiler warnings using the new functions in bytecomp-runtime.el. Move coding-system-put,get,category, since they're not Mule-specific and are used in prefer-coding-system. font.el was incredibly ugly. Clean it up. Avoid using defsubst for any exported functions, to avoid possible compatibility problems if we later change the internal interface. (It happened before, with face accessors, between 19.8 and 19.9). Fix tons of warnings. Clean up (new function gpm-is-supported-p eliminates duplicate code in gpm-create/delete-device-hook) and eliminate warnings. ---------- make byte-recompile-directory work in the --------- core `lisp' dir, even in the absence of a Mule XEmacs (i.e. make it skip the Mule files rather than trying to compile them). now you should be able to do `touch *.el' in the `lisp' dir, then M-x byte-recompile-directory, and get no warnings. Avoid trying to compile Mule files in byte-recompile-directory when we're not in a Mule XEmacs, since we're highly likely to get syntax errors. Add a coding-system cookie to all Mule files so that byte-recompile-directory ignores them. Magic cookie function moved to files.el from code-files.el (for use by bytecomp even in a non-coding-system XEmacs), and changed names and semantics for use by bytecomp. NOTE: IMO this is an internal function that we can change as we like (and there is absolutely no code anywhere else using the function). ---------------- GUI improvements: menus, help ------------------- Rearrange order of keymap declarations to be alphabetical. Improve help on help to include all bindings, and group by category. Add bindings for new Info commands. Remove warnings. Use command-hyper-apropos in place of command-apropos. Add a function to do the equivalent of command-apropos. Evals its help-text argument so you can put expressions there. Used now by help-for-help. Add binding to continue text searches. Expand index searches to work over multiple info documents. Add commands to search text/index in User and Lispref. Add new entry, "Uncomment Region" (parallels "Comment Out Region"). Redo Help menu; add bindings for new Info commands to search the index or text of the User and Lispref manuals. Add command for mark-paragraph, activate-region. Make Edit->R accelerator be rectangle, not register (more commonly used), and put rectangle first. Fix the Edit Init File entry to never load the .elc file. Simplify the default-popup-menu. Add Cmds->Tabs menu. Use kp-left not kp_left, etc. ---------------- Miscellaneous bug fixes/cleanup ------------------- byte-compiler-options: Correct doc string. easy-menu-do-define: fix extra quote. fill-paragraph-or-region:Rewrite to be more correct -- use call-interactively so that we always get exactly the same behavior as if the functions were called directly. No need to fiddle with zmacs-region-stays, now that bogus clearing of it (2001-04-28 src/ChangeLog) is removed. Put dialog titles back in -- this time correctly. Fix various other problems with leaks and such. key-sequence-list-description: Clean up fun to always correctly canonicalize. Clean up Kinsoku comments, synch comment-region with FSF 20.7. * simple.el (region-exists-p): * simple.el (region-active-p): Add comment about which one is correct to use in menu specs. * sound.el (load-sound-file): Minor code clean up. * startup.el: * startup.el (command-line-early): * startup.el (initial-scratch-message): Comment changes. Add info about sample.init.el to splash screen. Improve initial-scratch-message and clarify purpose of Scratch buffer. Fix byte-compile warning. ------------------------ Added features ------------------------- Add new variable to control whether etags checks all parent directories for tag files. (On by default.) * hash-table.el: New file, useful utility functions. * dumped-lisp.el (preloaded-file-list): Dump hash-table.el. ------------ notable bug fix: Windows event code -------------- Get critical quit working. ------------ notable bug fix and new feature: regex code -------------- Shy groups were implemented in a horrible, half-assed way that would cause them to screw up regex searching in most cases. Fixed to work correctly. Also extended back-reference syntax past 9. Only is recognized as such if there are at least that many non-shy groups; and optionally will warn about such uses, to catch old code that might be using them differently. (Added variable to control this in search.c -- `warn-about-possibly-incompatible-back- references', on by default for the moment. Declared in lisp.h. ---------------- process/SIGIO improvements ------------------- define USE_GETADDRINFO to replace more complex conditional, and use it. the code conditionalized on this in unix_open_network_stream had *serious* problems handling errors. it's now fixed, and major amounts of duplicate code between the two versions were combined. don't disable SIGIO and other interrupts unless CONNECT_NEEDS_SLOWED_INTERRUPTS is defined -- don't penalize OS's without bugs. similarly for a freebsd bug that was affecting all OS's. * s\ultrix.h: define CONNECT_NEEDS_SLOWED_INTERRUPTS, since that's the OS mentioned as having a kernel bug. * sysdep.c (request_sigio_on_device): * sysdep.c (unrequest_sigio_on_device): fix SIGIO problems on Linux. add check for O_ASYNC in case it's defined and FASYNC isn't. add comment about other ways to do SIGIO on Linux. * callproc.c (Fold_call_process_internal): * process.c (Fstart_process_internal): Deal with the possibility that `default-directory' doesn't have terminating slash. Correct comments about vfork. ---------------- Miscellaneous bug fixes/cleanup ------------------- * callint.c (Finteractive): Add lots of documentation -- exactly what the Lisp equivalents of all the interactive specs are. * console.h (struct console): change type of quit_char to Emchar. * event-msw.c (lstream_type_create_mswindows_selectable): spacing change. Eliminate events-mod.h and combine into events.h. * emacs.c: * emacs.c (make_arg_list_1): * emacs.c (main_1): A couple of char->Extbyte changes, add a comment. * glyphs-msw.c: Correct indentation of function defns to not exceed 80 cols. Try (sort of) to fix some code that sets the colors of the progress gauge. (Commented out) * keymap.c (syms_of_keymap): use DEFSYMBOL. * process.c (read_process_output): No need to fiddle with zmacs_region_stays, now that bogus clearing of it (see below) is removed. * search.c (Freplace_match): warning fix.
author ben
date Fri, 04 May 2001 22:42:35 +0000
parents 576fb035e263
children cd662ad69f40
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 ;;; font.el --- New font model
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
2
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
3 ;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
4 ;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
5
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 ;; Author: wmperry
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
7 ;; Maintainer: XEmacs Development Team
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 ;; Created: 1997/09/05 15:44:37
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
9 ;; Keywords: faces
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 ;; Version: 1.52
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
11
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
12 ;; XEmacs is free software; you can redistribute it and/or modify it
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
13 ;; under the terms of the GNU General Public License as published by
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
14 ;; the Free Software Foundation; either version 1, or (at your option)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
15 ;; any later version.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
16
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
17 ;; XEmacs is distributed in the hope that it will be useful, but
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
20 ;; General Public License for more details.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
22 ;; You should have received a copy of the GNU General Public License
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
23 ;; along with XEmacs; see the file COPYING. If not, write to the Free
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
25 ;; 02111-1307, USA.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
26
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
27 ;;; Synched up with: Not in FSF
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
28
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
29 ;;; Commentary:
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
31 ;;; Code:
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
32
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
33 (globally-declare-fboundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
34 '(x-list-fonts
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
35 mswindows-list-fonts ns-list-fonts internal-facep fontsetp get-font-info
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
36 get-fontset-info mswindows-define-rgb-color cancel-function-timers))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
37
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
38 (globally-declare-boundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
39 '(global-face-data
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
40 x-font-regexp x-font-regexp-foundry-and-family))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
41
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 (require 'cl)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 (eval-and-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 (defvar device-fonts-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 (condition-case ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 (require 'custom)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 (error nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 nil ;; We've got what we needed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 ;; We have the old custom-library, hack around it!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 (defmacro defgroup (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 (defmacro defcustom (var value doc &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 `(defvar ,var ,value ,doc))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 (if (not (fboundp 'try-font-name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 (defun try-font-name (fontname &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 (case window-system
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 ((x pm) (car-safe (x-list-fonts fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 (mswindows (car-safe (mswindows-list-fonts fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 (ns (car-safe (ns-list-fonts fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 (otherwise nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 (if (not (fboundp 'facep))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 (defun facep (face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 "Return t if X is a face name or an internal face vector."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 (if (not window-system)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 nil ; FIXME if FSF ever does TTY faces
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 (and (or (internal-facep face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 (and (symbolp face) (assq face global-face-data)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 (if (not (fboundp 'set-face-property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 (defun set-face-property (face property value &optional locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 tag-set how-to-add)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 "Change a property of FACE."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 (and (symbolp face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 (put face property value))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 (if (not (fboundp 'face-property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 (defun face-property (face property &optional locale tag-set exact-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 "Return FACE's value of the given PROPERTY."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 (and (symbolp face) (get face property))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 (require 'disp-table)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 ;;; Lots of variables / keywords for use later in the program
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 ;;; Not much should need to be modified
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 "Whether we are running in XEmacs or not.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 (defmacro define-font-keywords (&rest keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 `(eval-and-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 (let ((keywords (quote ,keys)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 (while keywords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 (or (boundp (car keywords))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 (set (car keywords) (car keywords)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 (setq keywords (cdr keywords))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 (defconst font-window-system-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 '((x . (x-font-create-name x-font-create-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 (ns . (ns-font-create-name ns-font-create-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 (mswindows . (mswindows-font-create-name mswindows-font-create-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 (tty . (tty-font-create-plist tty-font-create-object)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 "An assoc list mapping device types to the function used to create
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 a font name from a font structure.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 (defconst ns-font-weight-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 '((:extra-light . "extralight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 (:light . "light")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 (:demi-light . "demilight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 (:medium . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 (:normal . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 (:demi-bold . "demibold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 (:bold . "bold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 (:extra-bold . "extrabold"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 "An assoc list mapping keywords to actual NeXTstep specific
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 information to use")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 (defconst x-font-weight-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 '((:extra-light . "extralight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 (:light . "light")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (:demi-light . "demilight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 (:demi . "demi")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 (:book . "book")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 (:medium . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 (:normal . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 (:demi-bold . "demibold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 (:bold . "bold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 (:extra-bold . "extrabold"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 "An assoc list mapping keywords to actual Xwindow specific strings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 for use in the 'weight' field of an X font string.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 (defconst font-possible-weights
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 (mapcar 'car x-font-weight-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 (defvar font-rgb-file nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 "Where the RGB file was found.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 (defvar font-maximum-slippage "1pt"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 "How much a font is allowed to vary from the desired size.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 (define-font-keywords :family :style :size :registry :encoding)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 (define-font-keywords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 :weight :extra-light :light :demi-light :medium :normal :demi-bold
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 :bold :extra-bold)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 (defvar font-style-keywords nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
156 (defun set-font-family (fontobj family)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 (aset fontobj 1 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
159 (defun set-font-weight (fontobj weight)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 (aset fontobj 3 weight))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
162 (defun set-font-style (fontobj style)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 (aset fontobj 5 style))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
165 (defun set-font-size (fontobj size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 (aset fontobj 7 size))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
168 (defun set-font-registry (fontobj reg)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 (aset fontobj 9 reg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
171 (defun set-font-encoding (fontobj enc)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 (aset fontobj 11 enc))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
174 (defun font-family (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 (aref fontobj 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
177 (defun font-weight (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 (aref fontobj 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
180 (defun font-style (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 (aref fontobj 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
183 (defun font-size (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 (aref fontobj 7))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
186 (defun font-registry (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 (aref fontobj 9))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
189 (defun font-encoding (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 (aref fontobj 11))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 (eval-when-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 (defmacro define-new-mask (attr mask)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 (setq font-style-keywords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 (cons (cons (quote ,attr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 (cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 (quote ,(intern (format "set-font-%s-p" attr)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 (quote ,(intern (format "font-%s-p" attr)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 font-style-keywords))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
201 (defconst ,(intern (format "font-%s-mask" attr)) (lsh 1 ,mask)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 ,(format
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 "Bitmask for whether a font is to be rendered in %s or not."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 attr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 (defun ,(intern (format "font-%s-p" attr)) (fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 ,(format "Whether FONTOBJ will be renderd in `%s' or not." attr)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
207 (if (/= 0 (logand (font-style fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 ,(intern (format "font-%s-mask" attr))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 ,(format "Set whether FONTOBJ will be renderd in `%s' or not."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 attr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 (val
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
216 (set-font-style fontobj (logior (font-style fontobj)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
217 ,(intern
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
218 (format "font-%s-mask" attr)))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 ((,(intern (format "font-%s-p" attr)) fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 (set-font-style fontobj (- (font-style fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 ,(intern
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 (format "font-%s-mask" attr)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 )))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 (let ((mask 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 (define-new-mask bold (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 (define-new-mask italic (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 (define-new-mask oblique (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 (define-new-mask dim (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 (define-new-mask underline (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 (define-new-mask overline (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 (define-new-mask linethrough (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 (define-new-mask strikethru (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 (define-new-mask reverse (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 (define-new-mask blink (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 (define-new-mask smallcaps (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 (define-new-mask bigcaps (setq mask (1+ mask)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 (define-new-mask dropcaps (setq mask (1+ mask))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 (defvar font-caps-display-table
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 (let ((table (make-display-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 (i 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 ;; Standard ASCII characters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 (while (< i 26)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 (aset table (+ i ?a) (+ i ?A))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 ;; Now ISO translations
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 (setq i 224)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 (while (< i 247) ;; Agrave - Ouml
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 (aset table i (- i 32))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 (setq i 248)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 (while (< i 255) ;; Oslash - Thorn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 (aset table i (- i 32))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 ;;; Utility functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
261 (defun set-font-style-by-keywords (fontobj styles)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 (make-local-variable 'font-func)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 (declare (special font-func))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 (if (listp styles)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 (while styles
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 styles (cdr styles))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 (and (fboundp font-func) (funcall font-func fontobj t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 (and (fboundp font-func) (funcall font-func fontobj t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
272 (defun font-properties-from-style (fontobj)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
273 (let ((todo font-style-keywords)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 type func retval)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 (while todo
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 (setq func (cdr (cdr (car todo)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 type (car (pop todo)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 (if (funcall func fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 (setq retval (cons type retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 (defun font-unique (list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 (let ((retval)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 (cur))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 (while list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 (setq cur (car list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 list (cdr list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 (if (member cur retval)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 (setq retval (cons cur retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 (nreverse retval)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 (defun font-higher-weight (w1 w2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 (let ((index1 (length (memq w1 font-possible-weights)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 (index2 (length (memq w2 font-possible-weights))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 ((<= index1 index2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 (or w1 w2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 ((not w2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 w1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 w2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 (defun font-spatial-to-canonical (spec &optional device)
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 428
diff changeset
305 "Convert SPEC (in inches, millimeters, points, or picas) into points."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 ;; 1 in = 6 pa = 25.4 mm = 72 pt
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 ((numberp spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 ((null spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 (let ((num nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 (type nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 ;; If for any reason we get null for any of this, default
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 ;; to 1024x768 resolution on a 17" screen
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 (pix-width (float (or (device-pixel-width device) 1024)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 (mm-width (float (or (device-mm-width device) 293)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 (retval nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 (let ((math-func (intern (match-string 1 spec)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 (other (font-spatial-to-canonical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 (substring spec (match-end 0) nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 (default (font-spatial-to-canonical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 (font-default-size-for-device device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 (if (fboundp math-func)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 (setq type "px"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 spec (int-to-string (funcall math-func default other)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 (setq type "px"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 spec (int-to-string other)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 ((string-match "[^0-9.]+$" spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 (setq type (substring spec (match-beginning 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 spec (substring spec 0 (match-beginning 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 (setq type "px"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 spec spec)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 (setq num (string-to-number spec))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 ((member type '("pixel" "px" "pix"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 (setq retval (* num (/ pix-width mm-width) (/ 25.4 72.0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 ((member type '("point" "pt"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 (setq retval num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 ((member type '("pica" "pa"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 (setq retval (* num 12.0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 ((member type '("inch" "in"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 (setq retval (* num 72.0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 ((string= type "mm")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 (setq retval (* num (/ 72.0 25.4))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 ((string= type "cm")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 (setq retval (* num 10 (/ 72.0 25.4))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 (setq retval num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 ;;; The main interface routines - constructors and accessor functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 (defun make-font (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 (vector :family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 (if (stringp (plist-get args :family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 (list (plist-get args :family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 (plist-get args :family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 :weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 (plist-get args :weight)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 :style
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 (if (numberp (plist-get args :style))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 (plist-get args :style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 :size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 (plist-get args :size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 :registry
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 (plist-get args :registry)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 :encoding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 (plist-get args :encoding)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 (defun font-create-name (fontobj &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 (let* ((type (device-type device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 (func (car (cdr-safe (assq type font-window-system-mappings)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 (and func (fboundp func) (funcall func fontobj device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 (defun font-create-object (fontname &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 (let* ((type (device-type device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 (and func (fboundp func) (funcall func fontname device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 (defun font-combine-fonts-internal (fontobj-1 fontobj-2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 (let ((retval (make-font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 (size-1 (and (font-size fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 (font-spatial-to-canonical (font-size fontobj-1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 (size-2 (and (font-size fontobj-2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 (font-spatial-to-canonical (font-size fontobj-2)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 (set-font-weight retval (font-higher-weight (font-weight fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 (font-weight fontobj-2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 (set-font-family retval (font-unique (append (font-family fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 (font-family fontobj-2))))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
400 (set-font-style retval (logior (font-style fontobj-1)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
401 (font-style fontobj-2)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 (set-font-registry retval (or (font-registry fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 (font-registry fontobj-2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 (set-font-encoding retval (or (font-encoding fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 (font-encoding fontobj-2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 (set-font-size retval (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 ((and size-1 size-2 (>= size-2 size-1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 (font-size fontobj-2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 ((and size-1 size-2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 (font-size fontobj-1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 (size-1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 (font-size fontobj-1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 (size-2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 (font-size fontobj-2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 (t nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 (defun font-combine-fonts (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 ((null args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 (error "Wrong number of arguments to font-combine-fonts"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 ((= (length args) 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 (car args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 (let ((retval (font-combine-fonts-internal (nth 0 args) (nth 1 args))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 (setq args (cdr (cdr args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 (while args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 (setq retval (font-combine-fonts-internal retval (car args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 args (cdr args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 ;;; The window-system dependent code (TTY-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 (defun tty-font-create-object (fontname &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 (make-font :size "12pt"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 (defun tty-font-create-plist (fontobj &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 (list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 (cons 'underline (font-underline-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 (cons 'highlight (if (or (font-bold-p fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 (memq (font-weight fontobj) '(:bold :demi-bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 (cons 'dim (font-dim-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 (cons 'blinking (font-blink-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 (cons 'reverse (font-reverse-p fontobj))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 ;;; The window-system dependent code (X-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 (defvar font-x-font-regexp (or (and font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 (boundp 'x-font-regexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 x-font-regexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 (let
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 ((- "[-?]")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 (foundry "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 (family "[^-]*")
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
461 ;(weight "\\(bold\\|demibold\\|medium\\|black\\)")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 (weight\? "\\([^-]*\\)")
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
463 ;(slant "\\([ior]\\)")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 (slant\? "\\([^-]?\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 (swidth "\\([^-]*\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 (adstyle "\\([^-]*\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 (pixelsize "\\(\\*\\|[0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 (resx "\\([*0]\\|[0-9][0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 (resy "\\([*0]\\|[0-9][0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 (spacing "[cmp?*]")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 (avgwidth "\\(\\*\\|[0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 (registry "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 (encoding "[^-]+")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 (concat "\\`\\*?[-?*]"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 foundry - family - weight\? - slant\? - swidth - adstyle -
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 pixelsize - pointsize - resx - resy - spacing - avgwidth -
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 registry - encoding "\\'"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 ))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 (defvar font-x-registry-and-encoding-regexp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 (or (and font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 (boundp 'x-font-regexp-registry-and-encoding)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 (symbol-value 'x-font-regexp-registry-and-encoding))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 (let ((- "[-?]")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 (registry "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 (encoding "[^-]+"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 (defvar font-x-family-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 '(
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 ("serif" . ("new century schoolbook"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 "utopia"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 "charter"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 "times"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 "lucidabright"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 "garamond"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 "palatino"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 "times new roman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 "baskerville"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 "bookman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 "bodoni"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 "computer modern"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505 "rockwell"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 ("sans-serif" . ("lucida"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 "helvetica"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 "gills-sans"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 "avant-garde"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 "univers"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 "optima"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 ("elfin" . ("tymes"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 ("monospace" . ("courier"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 "fixed"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 "lucidatypewriter"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 "clean"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 "terminal"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 ("cursive" . ("sirene"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 "zapf chancery"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 "A list of font family mappings on X devices.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 (defun x-font-create-object (fontname &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525 (let ((case-fold-search t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 (if (or (not (stringp fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 (not (string-match font-x-font-regexp fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528 (make-font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 (let ((family nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 (size nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 (weight (match-string 1 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 (slant (match-string 2 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 (swidth (match-string 3 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 (adstyle (match-string 4 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 (pxsize (match-string 5 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 (ptsize (match-string 6 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 (retval nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 (case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 (if (not (string-match x-font-regexp-foundry-and-family fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 (setq family (list (downcase (match-string 1 fontname)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 (if (string= "*" weight) (setq weight nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 (if (string= "*" slant) (setq slant nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 (if (string= "*" swidth) (setq swidth nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 (if (string= "*" adstyle) (setq adstyle nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 (if (string= "*" pxsize) (setq pxsize nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 (if (string= "*" ptsize) (setq ptsize nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 (if ptsize (setq size (/ (string-to-int ptsize) 10)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 (if (and (not size) pxsize) (setq size (concat pxsize "px")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 (if (and adstyle (not (equal adstyle "")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 (setq family (append family (list (downcase adstyle)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 (setq retval (make-font :family family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 :weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 :size size))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 (set-font-bold-p retval (eq :bold weight))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 ((null slant) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 ((member slant '("i" "I"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 (set-font-italic-p retval t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 ((member slant '("o" "O"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 (set-font-oblique-p retval t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 (when (string-match font-x-registry-and-encoding-regexp fontname)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 (set-font-registry retval (match-string 1 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 (set-font-encoding retval (match-string 2 fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 (defun x-font-families-for-device (&optional device no-resetp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 (ignore-errors (require 'x-font-menu))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 (if (boundp 'device-fonts-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 (if (and (not menu) (not no-resetp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 (reset-device-font-menus device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 (x-font-families-for-device device t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 (aref menu 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 (aref menu 1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 (sort (font-unique (nconc scaled normal)) 'string-lessp))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 (cons "monospace" (mapcar 'car font-x-family-mappings))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 (defvar font-default-cache nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 (defun font-default-font-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 (if font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 (font-truename
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 (make-font-specifier
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 (face-font-name 'default device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 (let ((font (cdr-safe (assq 'font (frame-parameters device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 (if (and (fboundp 'fontsetp) (fontsetp font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 font))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 (defun font-default-object-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 (let ((font (font-default-font-for-device device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 (or (cdr-safe (assoc font font-default-cache))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 (let ((object (font-create-object font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 (push (cons font object) font-default-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 object))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 (defun font-default-family-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 (font-family (font-default-object-for-device (or device (selected-device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 (defun font-default-registry-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 (font-registry (font-default-object-for-device (or device (selected-device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 (defun font-default-encoding-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 (font-encoding (font-default-object-for-device (or device (selected-device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 (defun font-default-size-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 ;; face-height isn't the right thing (always 1 pixel too high?)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 ;; (if font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 ;; (format "%dpx" (face-height 'default device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 (font-size (font-default-object-for-device (or device (selected-device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 (defun x-font-create-name (fontobj &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 (if (and (not (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 (font-weight fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 (font-size fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 (font-registry fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 (font-encoding fontobj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 (= (font-style fontobj) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 (face-font 'default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 (let* ((default (font-default-object-for-device device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 (family (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 (font-family default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 (x-font-families-for-device device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 (weight (or (font-weight fontobj) :medium))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 (size (or (if font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 (font-size fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 (font-size default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 (registry (or (font-registry fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 (font-registry default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 "*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 (encoding (or (font-encoding fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 (font-encoding default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 "*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 (if (stringp family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 (setq family (list family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 (setq weight (font-higher-weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 (and (font-bold-p fontobj) :bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 (if (stringp size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 (setq size (truncate (font-spatial-to-canonical size device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 (let ((done nil) ; Did we find a good font yet?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 (font-name nil) ; font name we are currently checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 (cur-family nil) ; current family we are checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 (while (and family (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 (setq cur-family (car family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 family (cdr family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 (if (assoc cur-family font-x-family-mappings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 ;; If the family name is an alias as defined by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 ;; font-x-family-mappings, then append those families
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 ;; to the front of 'family' and continue in the loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 (setq family (append
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 (cdr-safe (assoc cur-family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 font-x-family-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 ;; Not an alias for a list of fonts, so we just check it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 ;; First, convert all '-' to spaces so that we don't screw up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 ;; the oh-so wonderful X font model. Wheee.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 (let ((x (length cur-family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 (while (> x 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 (if (= ?- (aref cur-family (1- x)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 (aset cur-family (1- x) ? ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 (setq x (1- x))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 ;; We treat oblique and italic as equivalent. Don't ask.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 (let ((slants '("o" "i")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 (while (and slants (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 (setq font-name (format "-*-%s-%s-%s-*-*-*-%s-*-*-*-*-%s-%s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 cur-family weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 (if (or (font-italic-p fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 (font-oblique-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 (car slants)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 "r")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 (if size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 (int-to-string (* 10 size)) "*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 registry
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 encoding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 slants (cdr slants)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 done (try-font-name font-name device))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 (if done font-name)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 ;;; The window-system dependent code (NS-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 (defun ns-font-families-for-device (&optional device no-resetp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 ;; For right now, assume we are going to have the same storage for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 ;; device fonts for NS as we do for X. Is this a valid assumption?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 (if (boundp 'device-fonts-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 (if (and (not menu) (not no-resetp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 (reset-device-font-menus device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 (ns-font-families-for-device device t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 (aref menu 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 (aref menu 1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 (sort (font-unique (nconc scaled normal)) 'string-lessp))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 (defun ns-font-create-name (fontobj &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 (let ((family (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 (ns-font-families-for-device device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 (weight (or (font-weight fontobj) :medium))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721 (style (or (font-style fontobj) (list :normal)))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
722 (size (font-size fontobj)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 ;; Create a font, wow!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 (if (stringp family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 (setq family (list family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 (if (or (symbolp style) (numberp style))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 (setq style (list style)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 (setq weight (font-higher-weight weight (car-safe (memq :bold style))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 (if (stringp size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 (setq size (font-spatial-to-canonical size device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 "medium"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 (let ((done nil) ; Did we find a good font yet?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 (font-name nil) ; font name we are currently checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 (cur-family nil) ; current family we are checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 (while (and family (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 (setq cur-family (car family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 family (cdr family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 (if (assoc cur-family font-x-family-mappings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 ;; If the family name is an alias as defined by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 ;; font-x-family-mappings, then append those families
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 ;; to the front of 'family' and continue in the loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 ;; #### jhar: I don't know about ns font names, so using X mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 (setq family (append
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 (cdr-safe (assoc cur-family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 font-x-family-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 ;; CARL: Need help here - I am not familiar with the NS font
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 ;; model
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 (setq font-name "UNKNOWN FORMULA GOES HERE"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 done (try-font-name font-name device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 (if done font-name))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 ;;; The window-system dependent code (mswindows-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 ;;; mswindows fonts look like:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 ;;; fontname[:[weight][ style][:pointsize[:effects]]][:charset]
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 ;;; A minimal mswindows font spec looks like:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763 ;;; Courier New
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 ;;; A maximal mswindows font spec looks like:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 ;;; Courier New:Bold Italic:10:underline strikeout:western
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 ;;; Missing parts of the font spec should be filled in with these values:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 ;;; Courier New:Regular:10::western
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768 ;; "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 (defvar font-mswindows-font-regexp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 (let
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 ((- ":")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 (fontname "\\([a-zA-Z ]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 (weight "\\([a-zA-Z]*\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 (style "\\( [a-zA-Z]*\\)?")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 (pointsize "\\([0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776 (effects "\\([a-zA-Z ]*\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 (charset "\\([a-zA-Z 0-9]*\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 (concat "^"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 fontname - weight style - pointsize - effects - charset "$")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 (defconst mswindows-font-weight-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 '((:extra-light . "Extralight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 (:light . "Light")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 (:demi-light . "Demilight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 (:demi . "Demi")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 (:book . "Book")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 (:medium . "Medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 (:normal . "Normal")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 (:demi-bold . "Demibold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791 (:bold . "Bold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 (:regular . "Regular")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 (:extra-bold . "Extrabold"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 "An assoc list mapping keywords to actual mswindows specific strings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 for use in the 'weight' field of an mswindows font string.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 (defvar font-mswindows-family-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 '(
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 ("serif" . ("times new roman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 "century schoolbook"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 "book antiqua"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 "bookman old style"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 ("sans-serif" . ("arial"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 "verdana"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 "lucida sans unicode"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 ("monospace" . ("courier new"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 "lucida console"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 "courier"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 "terminal"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 ("cursive" . ("roman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 "script"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 "A list of font family mappings on mswindows devices.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 (defun mswindows-font-create-object (fontname &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 (let ((case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 (font (mswindows-font-canonicalize-name fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 (if (or (not (stringp font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 (not (string-match font-mswindows-font-regexp font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 (make-font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 (let ((family (match-string 1 font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 (weight (match-string 2 font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 (style (match-string 3 font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 (pointsize (match-string 4 font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 (effects (match-string 5 font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 (charset (match-string 6 font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 (retval nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 (size nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 (case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 (if pointsize (setq size (concat pointsize "pt")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 (setq retval (make-font :family family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 :weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 :size size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 :encoding charset))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 (set-font-bold-p retval (eq :bold weight))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 ((null style) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 ((string-match "^ *[iI]talic" style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 (set-font-italic-p retval t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 ((null effects) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 ((string-match "^[uU]nderline [sS]trikeout" effects)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 (set-font-underline-p retval t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 (set-font-strikethru-p retval t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 ((string-match "[uU]nderline" effects)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 (set-font-underline-p retval t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 ((string-match "[sS]trikeout" effects)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 (set-font-strikethru-p retval t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 (defun mswindows-font-create-name (fontobj &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 (if (and (not (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 (font-weight fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 (font-size fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 (font-registry fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858 (font-encoding fontobj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 (= (font-style fontobj) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 (face-font 'default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 (let* ((default (font-default-object-for-device device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 (family (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 (font-family default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 (weight (or (font-weight fontobj) :regular))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 (size (or (if font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 (font-size fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 (font-size default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 (underline-p (font-underline-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 (strikeout-p (font-strikethru-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 (encoding (or (font-encoding fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 (font-encoding default))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 (if (stringp family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 (setq family (list family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 (setq weight (font-higher-weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 (and (font-bold-p fontobj) :bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 (if (stringp size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 (setq size (truncate (font-spatial-to-canonical size device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 (setq weight (or (cdr-safe
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 (assq weight mswindows-font-weight-mappings)) ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 (let ((done nil) ; Did we find a good font yet?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 (font-name nil) ; font name we are currently checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 (cur-family nil) ; current family we are checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 (while (and family (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 (setq cur-family (car family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 family (cdr family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 (if (assoc cur-family font-mswindows-family-mappings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 ;; If the family name is an alias as defined by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 ;; font-mswindows-family-mappings, then append those families
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 ;; to the front of 'family' and continue in the loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 (setq family (append
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 (cdr-safe (assoc cur-family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 font-mswindows-family-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 ;; We treat oblique and italic as equivalent. Don't ask.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 ;; Courier New:Bold Italic:10:underline strikeout:western
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 (setq font-name (format "%s:%s%s:%s:%s:%s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 cur-family weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 (if (font-italic-p fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 " Italic" "")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 (if size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 (int-to-string size) "10")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904 (if underline-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 (if strikeout-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 "underline strikeout"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 "underline")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 (if strikeout-p "strikeout" ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 (if encoding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 encoding ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911 done (try-font-name font-name device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
912 (if done font-name)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
913
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 ;;; Cache building code
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 (defun x-font-build-cache (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918 (let ((hash-table (make-hash-table :test 'equal :size 15))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 (fonts (mapcar 'x-font-create-object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 (plist nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 (cur nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 (while fonts
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 (setq cur (car fonts)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 fonts (cdr fonts)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 plist (cl-gethash (car (font-family cur)) hash-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 (if (not (memq (font-weight cur) (plist-get plist 'weights)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928 (setq plist (plist-put plist 'weights (cons (font-weight cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 (plist-get plist 'weights)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 (if (not (member (font-size cur) (plist-get plist 'sizes)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 (setq plist (plist-put plist 'sizes (cons (font-size cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 (plist-get plist 'sizes)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 (if (and (font-oblique-p cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 (not (memq 'oblique (plist-get plist 'styles))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 (if (and (font-italic-p cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 (not (memq 'italic (plist-get plist 'styles))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 (cl-puthash (car (font-family cur)) plist hash-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 hash-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 ;;; Now overwrite the original copy of set-face-font with our own copy that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 ;;; can deal with either syntax.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 ;;; ###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 (defun font-set-face-font (&optional face font &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950 ((and (vectorp font) (= (length font) 12))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951 (let ((font-name (font-create-name font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 (set-face-property face 'font-specification font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 ((null font-name) ; No matching font!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 ((listp font-name) ; For TTYs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 (let (cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 (while font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 (setq cur (car font-name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 font-name (cdr font-name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 (apply 'set-face-property face (car cur) (cdr cur) args))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 (font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 (apply 'set-face-font face font-name args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 (apply 'set-face-underline-p face (font-underline-p font) args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 (fboundp 'set-face-display-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967 (apply 'set-face-display-table
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 face font-caps-display-table args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969 (apply 'set-face-property face 'strikethru (or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 (font-linethrough-p font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 (font-strikethru-p font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 (apply 'set-face-font face font-name args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 (error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 (let ((args (car-safe args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 (and (or (font-bold-p font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 (memq (font-weight font) '(:bold :demi-bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 (make-face-bold face args t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 (and (font-italic-p font) (make-face-italic face args t)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 (apply 'set-face-underline-p face (font-underline-p font) args)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 ;; Let the original set-face-font signal any errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 (set-face-property face 'font-specification nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 (apply 'set-face-font face font args))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 ;;; Now for emacsen specific stuff
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 (defun font-update-device-fonts (device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 ;; Update all faces that were created with the 'font' package
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 ;; to appear correctly on the new device. This should be in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 ;; create-device-hook. This is XEmacs 19.12+ specific
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 (let ((faces (face-list 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 (cur nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 (font-spec nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 (while faces
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 (setq cur (car faces)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 faces (cdr faces)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002 font-spec (face-property cur 'font-specification))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 (if font-spec
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 (set-face-font cur font-spec device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006 (defun font-update-one-face (face &optional device-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 ;; Update FACE on all devices in DEVICE-LIST
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 ;; DEVICE_LIST defaults to a list of all active devices
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 (setq device-list (or device-list (device-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 (if (devicep device-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 (setq device-list (list device-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 (let* ((cur-device nil)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1013 (font-spec (face-property face 'font-specification)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 (if (not font-spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 ;; Hey! Don't mess with fonts we didn't create in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 ;; first place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 (while device-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019 (setq cur-device (car device-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020 device-list (cdr device-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021 (if (not (device-live-p cur-device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022 ;; Whoah!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1023 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1024 (if font-spec
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1025 (set-face-font face font-spec cur-device)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 ;;; Various color related things
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 ((fboundp 'display-warning)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 (fset 'font-warn 'display-warning))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 ((fboundp 'w3-warn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 (fset 'font-warn 'w3-warn))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1035 ((fboundp 'url-warn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 (fset 'font-warn 'url-warn))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037 ((fboundp 'warn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038 (defun font-warn (class message &optional level)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039 (warn "(%s/%s) %s" class (or level 'warning) message)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1040 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 (defun font-warn (class message &optional level)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043 (set-buffer (get-buffer-create "*W3-WARNINGS*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1044 (goto-char (point-max))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1047 (display-buffer (current-buffer))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1048
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1049 (defun font-lookup-rgb-components (color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1050 "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 The list (R G B) is returned, or an error is signaled if the lookup fails."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 (let ((lib-list (if (boundp 'x-library-search-path)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 x-library-search-path
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054 ;; This default is from XEmacs 19.13 - hope it covers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1055 ;; everyone.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1056 (list "/usr/X11R6/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 "/usr/X11R5/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1058 "/usr/lib/X11R6/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059 "/usr/lib/X11R5/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1060 "/usr/local/X11R6/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 "/usr/local/X11R5/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062 "/usr/local/lib/X11R6/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063 "/usr/local/lib/X11R5/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 "/usr/X11/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1065 "/usr/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1066 "/usr/local/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 "/usr/X386/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1068 "/usr/x386/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 "/usr/XFree86/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1070 "/usr/unsupported/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 "/usr/athena/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1072 "/usr/local/x11r5/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1073 "/usr/lpp/Xamples/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 "/usr/openwin/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 "/usr/openwin/share/lib/X11/")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1076 (file font-rgb-file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1077 r g b)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 (if (not file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079 (while lib-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080 (setq file (expand-file-name "rgb.txt" (car lib-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 (if (file-readable-p file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082 (setq lib-list nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 font-rgb-file file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084 (setq lib-list (cdr lib-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 file nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1086 (if (null file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087 (list 0 0 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089 (set-buffer (find-file-noselect file))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090 (if (not (= (aref (buffer-name) 0) ? ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091 (rename-buffer (generate-new-buffer-name " *rgb-tmp-buffer*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093 (save-restriction
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 (widen)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 (goto-char (point-min))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 (if (re-search-forward (format "\t%s$" (regexp-quote color)) nil t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 (beginning-of-line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 (setq r (* (read (current-buffer)) 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100 g (* (read (current-buffer)) 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101 b (* (read (current-buffer)) 256)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1102 (font-warn 'color (format "No such color: %s" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103 (setq r 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 g 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105 b 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 (list r g b) ))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108 (defun font-hex-string-to-number (string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109 "Convert STRING to an integer by parsing it as a hexadecimal number."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 (?1 . 1) (?b . 11) (?B . 11)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112 (?2 . 2) (?c . 12) (?C . 12)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113 (?3 . 3) (?d . 13) (?D . 13)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 (?4 . 4) (?e . 14) (?E . 14)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 (?5 . 5) (?f . 15) (?F . 15)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1116 (?6 . 6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117 (?7 . 7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 (?8 . 8)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 (?9 . 9)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 (n 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1121 (i 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122 (lim (length string)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 (while (< i lim)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124 (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 n ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128 (defun font-parse-rgb-components (color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129 "Parse RGB color specification and return a list of integers (R G B).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 #FEFEFE and rgb:fe/fe/fe style specifications are parsed."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131 (let ((case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132 r g b str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 (cond ((string-match "^#[0-9a-f]+$" color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135 ((= (length color) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 (setq r (font-hex-string-to-number (substring color 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137 g (font-hex-string-to-number (substring color 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 b (font-hex-string-to-number (substring color 3 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139 r (* r 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 g (* g 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141 b (* b 4096)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1142 ((= (length color) 7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1143 (setq r (font-hex-string-to-number (substring color 1 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1144 g (font-hex-string-to-number (substring color 3 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 b (font-hex-string-to-number (substring color 5 7))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 r (* r 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147 g (* g 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 b (* b 256)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 ((= (length color) 10)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 (setq r (font-hex-string-to-number (substring color 1 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 g (font-hex-string-to-number (substring color 4 7))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 b (font-hex-string-to-number (substring color 7 10))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 r (* r 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 g (* g 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 b (* b 16)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156 ((= (length color) 13)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 (setq r (font-hex-string-to-number (substring color 1 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 g (font-hex-string-to-number (substring color 5 9))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 b (font-hex-string-to-number (substring color 9 13))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 (font-warn 'color (format "Invalid RGB color specification: %s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 (setq r 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164 g 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 b 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 ((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 (if (or (> (- (match-end 1) (match-beginning 1)) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 (> (- (match-end 2) (match-beginning 2)) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 (> (- (match-end 3) (match-beginning 3)) 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 (error "Invalid RGB color specification: %s" color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172 (setq str (match-string 1 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1173 r (* (font-hex-string-to-number str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174 (expt 16 (- 4 (length str))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175 str (match-string 2 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1176 g (* (font-hex-string-to-number str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177 (expt 16 (- 4 (length str))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1178 str (match-string 3 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1179 b (* (font-hex-string-to-number str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1180 (expt 16 (- 4 (length str)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1181 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1182 (font-warn 'html (format "Invalid RGB color specification: %s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1183 color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1184 (setq r 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185 g 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1186 b 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1187 (list r g b) ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1188
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1189 (defun font-rgb-color-p (obj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1190 (or (and (vectorp obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1191 (= (length obj) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1192 (eq (aref obj 0) 'rgb))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1193
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1194 (defun font-rgb-color-red (obj) (aref obj 1))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1195 (defun font-rgb-color-green (obj) (aref obj 2))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1196 (defun font-rgb-color-blue (obj) (aref obj 3))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1198 (defun font-color-rgb-components (color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 "Return the RGB components of COLOR as a list of integers (R G B).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200 16-bit values are always returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1201 #FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202 into their components.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1203 RGB values for color names are looked up in the rgb.txt file.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 The variable x-library-search-path is use to locate the rgb.txt file."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 (let ((case-fold-search t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207 ((and (font-rgb-color-p color) (floatp (aref color 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1208 (list (* 65535 (aref color 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 (* 65535 (aref color 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210 (* 65535 (aref color 2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211 ((font-rgb-color-p color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212 (list (font-rgb-color-red color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1213 (font-rgb-color-green color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 (font-rgb-color-blue color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 ((and (vectorp color) (= 3 (length color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 (list (aref color 0) (aref color 1) (aref color 2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 ((and (listp color) (= 3 (length color)) (floatp (car color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218 (mapcar #'(lambda (x) (* x 65535)) color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1219 ((and (listp color) (= 3 (length color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 ((or (string-match "^#" color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222 (string-match "^rgb:" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 (font-parse-rgb-components color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 ((string-match "\\([0-9.]+\\)[ \t]\\([0-9.]+\\)[ \t]\\([0-9.]+\\)"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 (let ((r (string-to-number (match-string 1 color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 (g (string-to-number (match-string 2 color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 (b (string-to-number (match-string 3 color))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 (if (floatp r)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 (setq r (round (* 255 r))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 g (round (* 255 g))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 b (round (* 255 b))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 (font-parse-rgb-components (format "#%02x%02x%02x" r g b))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 (font-lookup-rgb-components color)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1237 (defun font-tty-compute-color-delta (col1 col2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1238 (+
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1239 (* (- (aref col1 0) (aref col2 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240 (- (aref col1 0) (aref col2 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1241 (* (- (aref col1 1) (aref col2 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1242 (- (aref col1 1) (aref col2 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 (* (- (aref col1 2) (aref col2 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 (- (aref col1 2) (aref col2 2)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 (defun font-tty-find-closest-color (r g b)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 ;; This is basically just a lisp copy of allocate_nearest_color
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 ;; from objects-x.c from Emacs 19
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 ;; We really should just check tty-color-list, but unfortunately
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 ;; that does not include any RGB information at all.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1251 ;; So for now we just hardwire in the default list and call it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 ;; good for now.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 (setq r (/ r 65535.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 g (/ g 65535.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255 b (/ b 65535.0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1256 (let* ((color_def (vector r g b))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 (colors [([1.0 1.0 1.0] . "white")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 ([0.0 1.0 1.0] . "cyan")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259 ([1.0 0.0 1.0] . "magenta")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 ([0.0 0.0 1.0] . "blue")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 ([1.0 1.0 0.0] . "yellow")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 ([0.0 1.0 0.0] . "green")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 ([1.0 0.0 0.0] . "red")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264 ([0.0 0.0 0.0] . "black")])
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1265 (no_cells (length colors))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1266 (x 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 (nearest 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 (nearest_delta 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269 (trial_delta 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1270 (setq nearest_delta (font-tty-compute-color-delta (car (aref colors 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 color_def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 (while (/= no_cells x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 (setq trial_delta (font-tty-compute-color-delta (car (aref colors x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 color_def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 (if (< trial_delta nearest_delta)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 (setq nearest x
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 nearest_delta trial_delta))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 (setq x (1+ x)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279 (cdr-safe (aref colors nearest))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1280
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 (defun font-normalize-color (color &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 "Return an RGB tuple, given any form of input. If an error occurs, black
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 is returned."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 (case (device-type device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 ((x pm)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 (mswindows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 (let* ((rgb (font-color-rgb-components color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 (color (apply 'format "#%02x%02x%02x" rgb)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1290 (mswindows-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 (tty
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 (ns
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1295 (let ((vals (mapcar #'(lambda (x) (lsh x -8))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 (font-color-rgb-components color))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 (apply 'format "RGB%02x%02x%02xff" vals)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298 (otherwise
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1299 color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 (defun font-set-face-background (&optional face color &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 ((or (font-rgb-color-p color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 (string-match "^#[0-9a-fA-F]+$" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 (apply 'set-face-background face
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 (font-normalize-color color) args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 (apply 'set-face-background face color args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 (error nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 (defun font-set-face-foreground (&optional face color &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317 ((or (font-rgb-color-p color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 (string-match "^#[0-9a-fA-F]+$" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 (apply 'set-face-foreground face (font-normalize-color color) args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 (apply 'set-face-foreground face color args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1322 (error nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 ;;; Support for 'blinking' fonts
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 (defun font-map-windows (func &optional arg frame)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 (let* ((start (selected-window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329 (cur start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330 (result nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1331 (push (funcall func start arg) result)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 (while (not (eq start (setq cur (next-window cur))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333 (push (funcall func cur arg) result))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 result))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 (defun font-face-visible-in-window-p (window face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337 (let ((st (window-start window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1338 (nd (window-end window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 (found nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340 (face-at nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 (setq face-at (get-text-property st 'face (window-buffer window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 (setq found t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 (while (and (not found)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 (/= nd
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 (setq st (next-single-property-change
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 st 'face
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 (window-buffer window) nd))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349 (setq face-at (get-text-property st 'face (window-buffer window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350 (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 (setq found t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 found))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354 (defun font-blink-callback ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 ;; Optimized to never invert the face unless one of the visible windows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 ;; is showing it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 (let ((faces (if font-running-xemacs (face-list t) (face-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 (obj nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 (while faces
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360 (if (and (setq obj (face-property (car faces) 'font-specification))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 (font-blink-p obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362 (memq t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 (font-map-windows 'font-face-visible-in-window-p (car faces))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364 (invert-face (car faces)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1365 (pop faces))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 (defcustom font-blink-interval 0.5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368 "How often to blink faces"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369 :type 'number
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 :group 'faces)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 (defun font-blink-initialize ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 ((featurep 'itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1375 (if (get-itimer "font-blinker")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1376 (delete-itimer (get-itimer "font-blinker")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377 (start-itimer "font-blinker" 'font-blink-callback
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378 font-blink-interval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 font-blink-interval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380 ((fboundp 'run-at-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1381 (cancel-function-timers 'font-blink-callback)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 (run-at-time font-blink-interval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383 font-blink-interval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 'font-blink-callback))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385 (t nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387 (provide 'font)