annotate lisp/font.el @ 872:79c6ff3eef26

[xemacs-hg @ 2002-06-20 21:18:01 by ben] font changes etc.; some 21.4 changes mule/mule-msw-init-late.el: Specify charset->windows-registry conversion. mule/mule-x-init.el: Delete extra mule font additions here. Put them in faces.c. cl-macs.el: Document better. font-lock.el: Move Lisp function regexp to lisp-mode.el. lisp-mode.el: Various indentation fixes: Handle flet functions better. Handle argument lists in defuns and flets. Handle quoted lists, e.g. property lists -- don't indent like function calls. Distinguish between lambdas and other lists. lisp-mode.el: Handle this form. faces.el, font-menu.el, font.el, gtk-faces.el, msw-faces.el, msw-font-menu.el, x-faces.el, x-init.el: Major overhaul of face-handling code: -- Fix lots of bogus code in msw-faces.el, msw-font-menu.el, font-menu.el that was "truenaming" font specs -- i.e. in the process of frobbing a particular field in a general user-specified font spec with wildcarded fields, sticking in particular values for all the remaining wildcarded fields. This bug was rampant everywhere except in x-faces.el (the oldest and only correctly written code). This also means that we need to work with font names at all times and not font instances, because a font instance is essentially a truenamed font. -- Total rewrite of extremely junky code in msw-faces.el. Work with names as well as font instances, and return names; stop truenaming when canonicalizing and frobbing; fix handling of the combined style field, i.e. weight/slant (also fixed in font.el). -- Totally rewrite the frobbing functions in faces.el. This time, we frob all the instantiators rather than just computing a single instance value and working backwards. That way, e.g., `bold' will work for all charsets that have bold available, rather than only for whatever charset was part of the computed font instance (another example of the truename virus). Also fix up code to look at the fallbacks (all of them) when no global value present, so we don't need to put something in the global value. Intelligently handle a request to frob a buffer locale, rather than signalling an error. When frobbing instantiators, try hard to figure out what device type is associated with them, and frob each according to its own proper device type. Correctly handle inheritance vectors given as instantiators. Preserve existing tags when putting back frobbed instantiators. Extract out general specifier-frobbing code into specifier.el. Document everything cleanly. Do lots of other things better, etc. -- Don't duplicatively set a global specification for the default font -- it's already in the fallback and we no longer need a default global specification present. Delete various code in x-faces.el and msw-faces.el that duplicated the lists of fonts in faces.c. -- init-global-faces was not being called at all under MS Windows! Major bogosity. That caused device-specific values to get stuck into all the fonts, making it very hard to change them -- setting global specs caused nothing to happen. -- Correct weight names in font.el. -- Lots more font fixups in objects*.c. Printer.el: Warning fix. specifier.el: Add more args to map-specifier. Add various "heuristic" specifier functions to aid in creation of specifier-munging code such as in faces.el. subr.el: New functions. lwlib.c: Fix warning. config.inc.samp: Clean up, add args to control fastcall (not yet supported! the changes needed are in another ws of mine), profile support, vc6 support, union-type. xemacs.dsp, xemacs.mak: Semi-major overhaul. Fix bug where dump-id was always getting recomputed, forcing a redump even when nothing changed. Add support for fastcall. Support edit-and-continue (on by default) with vc6. Use incremental linking when doing a debug compilation. Add support for profiling. Consolidate the various debug flags. Partial support for "batch-compiling" -- compiling many files on a single invocation of the compiler. Doesn't seem to help that much for me, so it's not finished or enabled by default. Remove HAVE_MSW_C_DIRED, we always do. Correct some sloppy use of directories. s/cygwin32.h: Allow pdump to work under Cygwin (mmap is broken, so need to undefine HAVE_MMAP). s/win32-common.h, s/windowsnt.h: Support for fastcall. Add WIN32_ANY for identifying all Win32 variants (Cygwin, native, MinGW). Both of these are properly used in another ws. alloc.c, balloon-x.c, buffer.c, bytecode.c, callint.c, cm.c, cmdloop.c, cmds.c, console-gtk.c, console-gtk.h, console-msw.c, console-msw.h, console-stream.c, console-stream.h, console-tty.c, console-tty.h, console-x.c, console-x.h, console.c, console.h, device-gtk.c, device-msw.c, device-tty.c, device-x.c, device.c, device.h, devslots.h, dialog-gtk.c, dialog-msw.c, dialog-x.c, dialog.c, dired-msw.c, editfns.c, emacs.c, event-Xt.c, event-gtk.c, event-msw.c, event-stream.c, event-tty.c, event-unixoid.c, events.c, extents.c, extents.h, faces.c, fileio.c, fns.c, frame-gtk.c, frame-msw.c, frame-tty.c, frame-x.c, frame.c, frame.h, glyphs-eimage.c, glyphs-gtk.c, glyphs-msw.c, glyphs-widget.c, glyphs-x.c, glyphs.c, glyphs.h, gui-gtk.c, gui-msw.c, gui-x.c, gui.c, gutter.c, input-method-xlib.c, intl-encap-win32.c, intl-win32.c, keymap.c, lisp.h, macros.c, menubar-gtk.c, menubar-msw.c, menubar-x.c, menubar.c, menubar.h, minibuf.c, mule-charset.c, nt.c, objects-gtk.c, objects-gtk.h, objects-msw.c, objects-msw.h, objects-tty.c, objects-tty.h, objects-x.c, objects-x.h, objects.c, objects.h, postgresql.c, print.c, process.h, redisplay-gtk.c, redisplay-msw.c, redisplay-output.c, redisplay-tty.c, redisplay-x.c, redisplay.c, redisplay.h, scrollbar-gtk.c, scrollbar-msw.c, scrollbar-x.c, scrollbar.c, select-gtk.c, select-msw.c, select-x.c, select.c, signal.c, sound.c, specifier.c, symbols.c, syntax.c, sysdep.c, syssignal.h, syswindows.h, toolbar-common.c, toolbar-gtk.c, toolbar-msw.c, toolbar-x.c, toolbar.c, unicode.c, window.c, window.h: The following are the major changes made: (1) Separation of various header files into an external and an internal version, similar to the existing separation of process.h and procimpl.h. Eventually this should be done for all Lisp objects. The external version has the same name as currently; the internal adds -impl. The external file has XFOO() macros for objects, but the structure is opaque and defined only in the internal file. It's now reasonable to move all prototypes in lisp.h into the appropriate external file, and this should be done. Currently, separation has been done on extents.h, objects*.h, console.h, device.h, frame.h, and window.h. For c/d/f/w, the most basic properties are available in the external header file, with the macros resolving to functions. In the internal header file, the macros are redefined to directly access the structure. Also, the global MARK_FOO_CHANGED macros have been made into functions so that they can be accessed without needing to include lots of -impl headers -- they are used in almost exclusively in non-time-critical functions, and take up enough time that the function overhead will be negligible. Similarly, the function overhead from making the basic properties mentioned above into functions is negligible, and code that does heavy accessing of c/d/f/w structures inevitably ends up needing the internal header files, anyway. (2) More face changes. -- Major rewrite of objects-msw.c. Now handles wildcard specs properly, rather than "truenaming" (or even worse, signalling an error, which previously happened with some of the fallbacks if you tried to use them in make-font-instance!). -- Split charset matching of fonts into two stages -- one to find a font specifically designed for a particular charset (by examining its registry), the second to find a Unicode font that can support the charset. This needs to proceed as two complete, separate instantiations in order to work properly (otherwise many of the fonts in the HELLO page look wrong). This should also make it easy to support iso10646 (Unicode) fonts under X. -- All default values for fonts are now completely specified in the fallbacks. Stuff from mule-x-init.el has all been moved here, merged with the existing specs, and totally rethought so you get sensible results. (HELLO now looks much better!). -- Generalize the "default X/GTK device" stuff into a per-device-type "default device". -- Add mswindows-{set-}charset-registry. In time, charset<->code-page conversion functions will be removed. -- Wrap protective code around calls to compute device specifier tags, and do this computation before calling the face initialization code because the latter may need these tags to be correctly updated. (3) Other changes. EmacsFrame.c, glyphs-msw.c, eval.c, gui-x.c, intl-encap-win32.c, search.c, signal.c, toolbar-msw.c, unicode.c: Warning fixes. config.h.in: #undefs meant to be frobbed by configure *MUST* go inside of #ifndef WIN32_NO_CONFIGURE, and everything else *MUST* go outside! eval.c: Let detailed backtraces be detailed. specifier.c: Don't override user's print-string-length/print-length settings. glyphs.c: New function image-instance-instantiator. config.h.in, sysdep.c: Changes for fastcall. sysdep.c, nt.c: Fix up a previous botched patch that tried to add support for both EEXIST and EACCES. IF THE BOTCHED PATCH WENT INTO 21.4, THIS FIXUP NEEDS TO GO IN, TOO. search.c: Fix *evil* crash due to incorrect synching of syntax-cache code with 21.1. THIS SHOULD GO INTO 21.4.
author ben
date Thu, 20 Jun 2002 21:19:10 +0000
parents 2923009caf47
children 01c57eb70ae9
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.
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
5 ;; Copyright (C) 2002 Ben Wing.
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
6
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Author: wmperry
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
8 ;; Maintainer: XEmacs Development Team
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 ;; Created: 1997/09/05 15:44:37
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
10 ;; Keywords: faces
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 ;; Version: 1.52
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
12
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
13 ;; 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
14 ;; under the terms of the GNU General Public License as published by
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
15 ;; the Free Software Foundation; either version 2, or (at your option)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
16 ;; any later version.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
17
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
18 ;; 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
19 ;; 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
20 ;; 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
21 ;; General Public License for more details.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
23 ;; 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
24 ;; 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
25 ;; 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
26 ;; 02111-1307, USA.
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
27
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
28 ;;; Synched up with: Not in FSF
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
29
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
30 ;;; Commentary:
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
32 ;;; Code:
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
33
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
34 (globally-declare-fboundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
35 '(x-list-fonts
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
36 mswindows-list-fonts ns-list-fonts internal-facep fontsetp get-font-info
523
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
37 get-fontset-info mswindows-define-rgb-color cancel-function-timers
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
38 mswindows-font-regexp mswindows-canonicalize-font-name
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
39 mswindows-parse-font-style mswindows-construct-font-style
523
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
40 ;; #### perhaps we should rewrite font-warn to avoid the warning
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
41 font-warn))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
42
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
43 (globally-declare-boundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
44 '(global-face-data
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
45 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
46
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 (require 'cl)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 (eval-and-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 (defvar device-fonts-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 (condition-case ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 (require 'custom)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 (error nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 nil ;; We've got what we needed
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 ;; We have the old custom-library, hack around it!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 (defmacro defgroup (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 (defmacro defcustom (var value doc &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 `(defvar ,var ,value ,doc))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 (if (not (fboundp 'try-font-name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 (defun try-font-name (fontname &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64 (case window-system
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 ((x pm) (car-safe (x-list-fonts fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 (mswindows (car-safe (mswindows-list-fonts fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67 (ns (car-safe (ns-list-fonts fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 (otherwise nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 (if (not (fboundp 'facep))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 (defun facep (face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 "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
73 (if (not window-system)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 nil ; FIXME if FSF ever does TTY faces
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 (and (or (internal-facep face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 (and (symbolp face) (assq face global-face-data)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 (if (not (fboundp 'set-face-property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 (defun set-face-property (face property value &optional locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81 tag-set how-to-add)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 "Change a property of FACE."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 (and (symbolp face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 (put face property value))))
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 (if (not (fboundp 'face-property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 (defun face-property (face property &optional locale tag-set exact-p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 "Return FACE's value of the given PROPERTY."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 (and (symbolp face) (get face property))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 (require 'disp-table)
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 ;;; Lots of variables / keywords for use later in the program
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 ;;; Not much should need to be modified
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 "Whether we are running in XEmacs or not.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 (defmacro define-font-keywords (&rest keys)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 `(eval-and-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 (let ((keywords (quote ,keys)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 (while keywords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 (or (boundp (car keywords))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 (set (car keywords) (car keywords)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 (setq keywords (cdr keywords))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 (defconst font-window-system-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 '((x . (x-font-create-name x-font-create-object))
608
4d7fdf497470 [xemacs-hg @ 2001-06-04 16:59:51 by wmperry]
wmperry
parents: 523
diff changeset
111 (gtk . (x-font-create-name x-font-create-object))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 (ns . (ns-font-create-name ns-font-create-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 (mswindows . (mswindows-font-create-name mswindows-font-create-object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 (tty . (tty-font-create-plist tty-font-create-object)))
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
116 "An assoc list mapping device types to a list of translations.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
117
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
118 The first function creates a font name from a font descriptor object.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
119 The second performs the reverse translation.")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 (defconst ns-font-weight-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 '((:extra-light . "extralight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 (:light . "light")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 (:demi-light . "demilight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 (:medium . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 (:normal . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 (:demi-bold . "demibold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (:bold . "bold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 (:extra-bold . "extrabold"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 "An assoc list mapping keywords to actual NeXTstep specific
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 information to use")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133 (defconst x-font-weight-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
134 '((:extra-light . "extralight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 (:light . "light")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136 (:demi-light . "demilight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 (:demi . "demi")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 (:book . "book")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 (:medium . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 (:normal . "medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 (:demi-bold . "demibold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 (:bold . "bold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 (:extra-bold . "extrabold"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 "An assoc list mapping keywords to actual Xwindow specific strings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 for use in the 'weight' field of an X font string.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 (defconst font-possible-weights
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 (mapcar 'car x-font-weight-mappings))
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 (defvar font-rgb-file nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 "Where the RGB file was found.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 (defvar font-maximum-slippage "1pt"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 "How much a font is allowed to vary from the desired size.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
156 ;; Canonical (internal) sizes are in points.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
157 ;; Registry
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 (define-font-keywords :family :style :size :registry :encoding)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 (define-font-keywords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 :weight :extra-light :light :demi-light :medium :normal :demi-bold
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 :bold :extra-bold)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 (defvar font-style-keywords nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
166 (defun set-font-family (fontobj family)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 (aset fontobj 1 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
169 (defun set-font-weight (fontobj weight)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 (aset fontobj 3 weight))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
172 (defun set-font-style (fontobj style)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 (aset fontobj 5 style))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
175 (defun set-font-size (fontobj size)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 (aset fontobj 7 size))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
178 (defun set-font-registry (fontobj reg)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 (aset fontobj 9 reg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
181 (defun set-font-encoding (fontobj enc)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 (aset fontobj 11 enc))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
184 (defun font-family (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 (aref fontobj 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
187 (defun font-weight (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 (aref fontobj 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
190 (defun font-style (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 (aref fontobj 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
193 (defun font-size (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 (aref fontobj 7))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
196 (defun font-registry (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 (aref fontobj 9))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
199 (defun font-encoding (fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 (aref fontobj 11))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 (eval-when-compile
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 (defmacro define-new-mask (attr mask)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 `(progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 (setq font-style-keywords
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 (cons (cons (quote ,attr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 (cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 (quote ,(intern (format "set-font-%s-p" attr)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 (quote ,(intern (format "font-%s-p" attr)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 font-style-keywords))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
211 (defconst ,(intern (format "font-%s-mask" attr)) (lsh 1 ,mask)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 ,(format
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 "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
214 attr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 (defun ,(intern (format "font-%s-p" attr)) (fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 ,(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
217 (if (/= 0 (logand (font-style fontobj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 ,(intern (format "font-%s-mask" attr))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 ,(format "Set whether FONTOBJ will be renderd in `%s' or not."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 attr)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 (val
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
226 (set-font-style fontobj (logior (font-style fontobj)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
227 ,(intern
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
228 (format "font-%s-mask" attr)))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 ((,(intern (format "font-%s-p" attr)) fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 (set-font-style fontobj (- (font-style fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 ,(intern
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 (format "font-%s-mask" attr)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 )))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234
523
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
235 (define-new-mask bold 1)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
236 (define-new-mask italic 2)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
237 (define-new-mask oblique 3)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
238 (define-new-mask dim 4)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
239 (define-new-mask underline 5)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
240 (define-new-mask overline 6)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
241 (define-new-mask linethrough 7)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
242 (define-new-mask strikethru 8)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
243 (define-new-mask reverse 9)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
244 (define-new-mask blink 10)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
245 (define-new-mask smallcaps 11)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
246 (define-new-mask bigcaps 12)
cd662ad69f40 [xemacs-hg @ 2001-05-09 13:43:49 by ben]
ben
parents: 502
diff changeset
247 (define-new-mask dropcaps 13)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 (defvar font-caps-display-table
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 (let ((table (make-display-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 (i 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 ;; Standard ASCII characters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 (while (< i 26)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 (aset table (+ i ?a) (+ i ?A))
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 ;; Now ISO translations
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 (setq i 224)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 (while (< i 247) ;; Agrave - Ouml
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 (aset table i (- i 32))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 (setq i 248)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 (while (< i 255) ;; Oslash - Thorn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 (aset table i (- i 32))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 (setq i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 ;;; Utility functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
270 (defun set-font-style-by-keywords (fontobj styles)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 (make-local-variable 'font-func)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 (declare (special font-func))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 (if (listp styles)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 (while styles
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 (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
276 styles (cdr styles))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 (and (fboundp font-func) (funcall font-func fontobj t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 (and (fboundp font-func) (funcall font-func fontobj t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
281 (defun font-properties-from-style (fontobj)
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
282 (let ((todo font-style-keywords)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 type func retval)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 (while todo
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 (setq func (cdr (cdr (car todo)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 type (car (pop todo)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 (if (funcall func fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 (setq retval (cons type retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 (defun font-unique (list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 (let ((retval)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 (cur))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 (while list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 (setq cur (car list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 list (cdr list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 (if (member cur retval)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 (setq retval (cons cur retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 (nreverse retval)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 (defun font-higher-weight (w1 w2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 (let ((index1 (length (memq w1 font-possible-weights)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 (index2 (length (memq w2 font-possible-weights))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 ((<= index1 index2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 (or w1 w2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 ((not w2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 w1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 w2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 (defun font-spatial-to-canonical (spec &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
314 "Convert SPEC (in inches, millimeters, points, picas, or pixels) into points.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
315
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
316 Canonical sizes are in points. If SPEC is null, nil is returned. If SPEC is
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
317 a number, it is interpreted as the desired point size and returned unchanged.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
318 Otherwise SPEC must be a string consisting of a number and an optional type.
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
319 The type may be the strings \"px\", \"pix\", or \"pixel\" (pixels), \"pt\" or
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
320 \"point\" (points), \"pa\" or \"pica\" (picas), \"in\" or \"inch\" (inches), \"cm\"
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
321 (centimeters), or \"mm\" (millimeters).
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
322
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
323 1 in = 2.54 cm = 6 pa = 25.4 mm = 72 pt. Pixel size is device-dependent."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 ((numberp spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 ((null spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 (let ((num nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 (type nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 ;; If for any reason we get null for any of this, default
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 ;; to 1024x768 resolution on a 17" screen
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 (pix-width (float (or (device-pixel-width device) 1024)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 (mm-width (float (or (device-mm-width device) 293)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 (retval nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 (cond
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
338 ;; the following string-match is broken, there will never be a
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
339 ;; left operand detected
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 (let ((math-func (intern (match-string 1 spec)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 (other (font-spatial-to-canonical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 (substring spec (match-end 0) nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 (default (font-spatial-to-canonical
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 (font-default-size-for-device device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 (if (fboundp math-func)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 (setq type "px"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 spec (int-to-string (funcall math-func default other)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 (setq type "px"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 spec (int-to-string other)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 ((string-match "[^0-9.]+$" spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 (setq type (substring spec (match-beginning 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 spec (substring spec 0 (match-beginning 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 (setq type "px"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 spec spec)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 (setq num (string-to-number spec))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 ((member type '("pixel" "px" "pix"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 (setq retval (* num (/ pix-width mm-width) (/ 25.4 72.0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 ((member type '("point" "pt"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 (setq retval num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 ((member type '("pica" "pa"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 (setq retval (* num 12.0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 ((member type '("inch" "in"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 (setq retval (* num 72.0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 ((string= type "mm")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 (setq retval (* num (/ 72.0 25.4))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 ((string= type "cm")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 (setq retval (* num 10 (/ 72.0 25.4))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 (setq retval num))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 ;;; The main interface routines - constructors and accessor functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 (defun make-font (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 (vector :family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 (if (stringp (plist-get args :family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 (list (plist-get args :family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 (plist-get args :family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 :weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 (plist-get args :weight)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 :style
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 (if (numberp (plist-get args :style))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 (plist-get args :style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 :size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 (plist-get args :size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 :registry
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 (plist-get args :registry)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 :encoding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 (plist-get args :encoding)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 (defun font-create-name (fontobj &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
399 "Return a font name constructed from FONTOBJ, appropriate for DEVICE."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 (let* ((type (device-type device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 (func (car (cdr-safe (assq type font-window-system-mappings)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 (and func (fboundp func) (funcall func fontobj device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 (defun font-create-object (fontname &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
406 "Return a font descriptor object for FONTNAME, appropriate for DEVICE."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 (let* ((type (device-type device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 (and func (fboundp func) (funcall func fontname device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 (defun font-combine-fonts-internal (fontobj-1 fontobj-2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 (let ((retval (make-font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 (size-1 (and (font-size fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 (font-spatial-to-canonical (font-size fontobj-1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 (size-2 (and (font-size fontobj-2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 (font-spatial-to-canonical (font-size fontobj-2)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 (set-font-weight retval (font-higher-weight (font-weight fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 (font-weight fontobj-2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 (set-font-family retval (font-unique (append (font-family fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 (font-family fontobj-2))))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
421 (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
422 (font-style fontobj-2)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 (set-font-registry retval (or (font-registry fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 (font-registry fontobj-2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 (set-font-encoding retval (or (font-encoding fontobj-1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 (font-encoding fontobj-2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 (set-font-size retval (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 ((and size-1 size-2 (>= size-2 size-1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 (font-size fontobj-2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 ((and size-1 size-2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 (font-size fontobj-1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 (size-1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 (font-size fontobj-1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 (size-2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 (font-size fontobj-2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 (t nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 retval))
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 font-combine-fonts (&rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 ((null args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 (error "Wrong number of arguments to font-combine-fonts"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 ((= (length args) 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 (car args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 (let ((retval (font-combine-fonts-internal (nth 0 args) (nth 1 args))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 (setq args (cdr (cdr args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 (while args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 (setq retval (font-combine-fonts-internal retval (car args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 args (cdr args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 retval))))
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 ;;; The window-system dependent code (TTY-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 (defun tty-font-create-object (fontname &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
459 "Return a font descriptor object for FONTNAME, appropriate for TTY devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 (make-font :size "12pt"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 (defun tty-font-create-plist (fontobj &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
463 "Return a font name constructed from FONTOBJ, appropriate for TTY devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 (list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 (cons 'underline (font-underline-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 (cons 'highlight (if (or (font-bold-p fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 (memq (font-weight fontobj) '(:bold :demi-bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 (cons 'dim (font-dim-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 (cons 'blinking (font-blink-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 (cons 'reverse (font-reverse-p fontobj))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 ;;; The window-system dependent code (X-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 (defvar font-x-font-regexp (or (and font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 (boundp 'x-font-regexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 x-font-regexp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 (let
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 (foundry "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 (family "[^-]*")
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
484 ;(weight "\\(bold\\|demibold\\|medium\\|black\\)")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 (weight\? "\\([^-]*\\)")
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
486 ;(slant "\\([ior]\\)")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 (slant\? "\\([^-]?\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 (swidth "\\([^-]*\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 (adstyle "\\([^-]*\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 (pixelsize "\\(\\*\\|[0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 (resx "\\([*0]\\|[0-9][0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 (resy "\\([*0]\\|[0-9][0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 (spacing "[cmp?*]")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 (avgwidth "\\(\\*\\|[0-9]+\\)")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 (registry "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 (encoding "[^-]+")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 (concat "\\`\\*?[-?*]"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 foundry - family - weight\? - slant\? - swidth - adstyle -
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 pixelsize - pointsize - resx - resy - spacing - avgwidth -
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 registry - encoding "\\'"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 ))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505 (defvar font-x-registry-and-encoding-regexp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 (or (and font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 (boundp 'x-font-regexp-registry-and-encoding)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 (symbol-value 'x-font-regexp-registry-and-encoding))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 (let ((- "[-?]")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 (registry "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 (encoding "[^-]+"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 (defvar font-x-family-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 '(
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 ("serif" . ("new century schoolbook"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 "utopia"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 "charter"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 "times"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 "lucidabright"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 "garamond"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 "palatino"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 "times new roman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 "baskerville"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525 "bookman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 "bodoni"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 "computer modern"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528 "rockwell"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 ("sans-serif" . ("lucida"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 "helvetica"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 "gills-sans"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 "avant-garde"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 "univers"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 "optima"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 ("elfin" . ("tymes"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 ("monospace" . ("courier"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 "fixed"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 "lucidatypewriter"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 "clean"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 "terminal"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 ("cursive" . ("sirene"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 "zapf chancery"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 "A list of font family mappings on X devices.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 (defun x-font-create-object (fontname &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
548 "Return a font descriptor object for FONTNAME, appropriate for X devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 (let ((case-fold-search t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 (if (or (not (stringp fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 (not (string-match font-x-font-regexp fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 (make-font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 (let ((family nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 (size nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 (weight (match-string 1 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 (slant (match-string 2 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 (swidth (match-string 3 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 (adstyle (match-string 4 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 (pxsize (match-string 5 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 (ptsize (match-string 6 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 (retval nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 (case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 (if (not (string-match x-font-regexp-foundry-and-family fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 (setq family (list (downcase (match-string 1 fontname)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 (if (string= "*" weight) (setq weight nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 (if (string= "*" slant) (setq slant nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 (if (string= "*" swidth) (setq swidth nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 (if (string= "*" adstyle) (setq adstyle nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571 (if (string= "*" pxsize) (setq pxsize nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 (if (string= "*" ptsize) (setq ptsize nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 (if ptsize (setq size (/ (string-to-int ptsize) 10)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 (if (and (not size) pxsize) (setq size (concat pxsize "px")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 (if (and adstyle (not (equal adstyle "")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 (setq family (append family (list (downcase adstyle)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 (setq retval (make-font :family family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 :weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 :size size))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 (set-font-bold-p retval (eq :bold weight))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 ((null slant) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 ((member slant '("i" "I"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 (set-font-italic-p retval t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 ((member slant '("o" "O"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 (set-font-oblique-p retval t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 (when (string-match font-x-registry-and-encoding-regexp fontname)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 (set-font-registry retval (match-string 1 fontname))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 (set-font-encoding retval (match-string 2 fontname)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 retval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 (defun x-font-families-for-device (&optional device no-resetp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 (ignore-errors (require 'x-font-menu))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 (if (boundp 'device-fonts-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 (if (and (not menu) (not no-resetp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 (reset-device-font-menus device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 (x-font-families-for-device device t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 (aref menu 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 (aref menu 1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 (sort (font-unique (nconc scaled normal)) 'string-lessp))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 (cons "monospace" (mapcar 'car font-x-family-mappings))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 (defvar font-default-cache nil)
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-font-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 (if font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 (font-truename
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 (make-font-specifier
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 (face-font-name 'default device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 (let ((font (cdr-safe (assq 'font (frame-parameters device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 (if (and (fboundp 'fontsetp) (fontsetp font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 font))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 (defun font-default-object-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 (let ((font (font-default-font-for-device device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 (or (cdr-safe (assoc font font-default-cache))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 (let ((object (font-create-object font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 (push (cons font object) font-default-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 object))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 (defun font-default-family-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 (font-family (font-default-object-for-device (or device (selected-device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 (defun font-default-registry-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 (font-registry (font-default-object-for-device (or device (selected-device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 (defun font-default-encoding-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 (font-encoding (font-default-object-for-device (or device (selected-device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 (defun font-default-size-for-device (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 ;; face-height isn't the right thing (always 1 pixel too high?)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 ;; (if font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 ;; (format "%dpx" (face-height 'default device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 (font-size (font-default-object-for-device (or device (selected-device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 (defun x-font-create-name (fontobj &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
651 "Return a font name constructed from FONTOBJ, appropriate for X devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 (if (and (not (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 (font-weight fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 (font-size fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 (font-registry fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 (font-encoding fontobj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 (= (font-style fontobj) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 (face-font 'default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 (let* ((default (font-default-object-for-device device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 (family (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 (font-family default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 (x-font-families-for-device device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 (weight (or (font-weight fontobj) :medium))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 (size (or (if font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 (font-size fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 (font-size default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 (registry (or (font-registry fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 (font-registry default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 "*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 (encoding (or (font-encoding fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 (font-encoding default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 "*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 (if (stringp family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 (setq family (list family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 (setq weight (font-higher-weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 (and (font-bold-p fontobj) :bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 (if (stringp size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 (setq size (truncate (font-spatial-to-canonical size device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 (let ((done nil) ; Did we find a good font yet?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 (font-name nil) ; font name we are currently checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 (cur-family nil) ; current family we are checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 (while (and family (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 (setq cur-family (car family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 family (cdr family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 (if (assoc cur-family font-x-family-mappings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 ;; If the family name is an alias as defined by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 ;; font-x-family-mappings, then append those families
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 ;; to the front of 'family' and continue in the loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 (setq family (append
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 (cdr-safe (assoc cur-family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 font-x-family-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 ;; 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
697 ;; First, convert all '-' to spaces so that we don't screw up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 ;; the oh-so wonderful X font model. Wheee.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 (let ((x (length cur-family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 (while (> x 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 (if (= ?- (aref cur-family (1- x)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 (aset cur-family (1- x) ? ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 (setq x (1- x))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 ;; We treat oblique and italic as equivalent. Don't ask.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 (let ((slants '("o" "i")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 (while (and slants (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 (setq font-name (format "-*-%s-%s-%s-*-*-*-%s-*-*-*-*-%s-%s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 cur-family weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 (if (or (font-italic-p fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 (font-oblique-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 (car slants)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 "r")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 (if size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 (int-to-string (* 10 size)) "*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 registry
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 encoding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 slants (cdr slants)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 done (try-font-name font-name device))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 (if done font-name)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 ;;; The window-system dependent code (NS-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 (defun ns-font-families-for-device (&optional device no-resetp)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 ;; 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
728 ;; 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
729 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 (if (boundp 'device-fonts-cache)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 (if (and (not menu) (not no-resetp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 (reset-device-font-menus device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 (ns-font-families-for-device device t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 (aref menu 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 (aref menu 1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 (sort (font-unique (nconc scaled normal)) 'string-lessp))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 (defun ns-font-create-name (fontobj &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
743 "Return a font name constructed from FONTOBJ, appropriate for NextSTEP devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 (let ((family (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 (ns-font-families-for-device device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 (weight (or (font-weight fontobj) :medium))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 (style (or (font-style fontobj) (list :normal)))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
748 (size (font-size fontobj)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 ;; Create a font, wow!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 (if (stringp family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 (setq family (list family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 (if (or (symbolp style) (numberp style))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 (setq style (list style)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 (setq weight (font-higher-weight weight (car-safe (memq :bold style))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 (if (stringp size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 (setq size (font-spatial-to-canonical size device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 "medium"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759 (let ((done nil) ; Did we find a good font yet?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 (font-name nil) ; font name we are currently checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 (cur-family nil) ; current family we are checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763 (while (and family (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 (setq cur-family (car family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 family (cdr family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 (if (assoc cur-family font-x-family-mappings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 ;; If the family name is an alias as defined by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768 ;; font-x-family-mappings, then append those families
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 ;; to the front of 'family' and continue in the loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 ;; #### 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
771 (setq family (append
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 (cdr-safe (assoc cur-family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 font-x-family-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 ;; CARL: Need help here - I am not familiar with the NS font
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776 ;; model
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 (setq font-name "UNKNOWN FORMULA GOES HERE"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 done (try-font-name font-name device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 (if done font-name))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 ;;; The window-system dependent code (mswindows-style)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 (defconst mswindows-font-weight-mappings
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
787 '((:thin . "Thin")
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
788 (:extra-light . "Extra Light")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 (:light . "Light")
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
790 (:demi-light . "Light")
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
791 (:demi . "Light")
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
792 (:book . "Medium")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 (:medium . "Medium")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 (:normal . "Normal")
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
795 (:demi-bold . "Demi Bold")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796 (:bold . "Bold")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 (:regular . "Regular")
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
798 (:extra-bold . "Extra Bold")
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
799 (:heavy . "Heavy"))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 "An assoc list mapping keywords to actual mswindows specific strings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 for use in the 'weight' field of an mswindows font string.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 (defvar font-mswindows-family-mappings
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 '(
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 ("serif" . ("times new roman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 "century schoolbook"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 "book antiqua"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 "bookman old style"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 ("sans-serif" . ("arial"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 "verdana"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 "lucida sans unicode"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 ("monospace" . ("courier new"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 "lucida console"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 "courier"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 "terminal"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 ("cursive" . ("roman"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 "script"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 "A list of font family mappings on mswindows devices.")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 (defun mswindows-font-create-object (fontname &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
822 "Return a font descriptor object for FONTNAME, appropriate for MS Windows devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 (let ((case-fold-search t)
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
824 (font (declare-fboundp (mswindows-canonicalize-font-name fontname))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 (if (or (not (stringp font))
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
826 (not (string-match mswindows-font-regexp font)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 (make-font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 (let ((family (match-string 1 font))
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
829 (style (match-string 2 font))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
830 (pointsize (match-string 3 font))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
831 (effects (match-string 4 font))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
832 (charset (match-string 5 font))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 (retval nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 (size nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 (case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 )
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
837 (destructuring-bind (weight . slant)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
838 (mswindows-parse-font-style style)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
839 (if (equal pointsize "") (setq pointsize nil))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
840 (if pointsize (setq size (concat pointsize "pt")))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
841 (if weight (setq weight
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
842 (intern-soft
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
843 (concat ":" (downcase (replace-in-string
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
844 weight " " "-"))))))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
845 (setq retval (make-font :family family
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
846 :weight weight
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
847 :size size
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
848 :encoding charset))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
849 (set-font-bold-p retval (eq :bold weight))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
850 (cond
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
851 ((null slant) nil)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
852 ((string-match "[iI]talic" slant)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
853 (set-font-italic-p retval t)))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
854 (cond
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
855 ((null effects) nil)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
856 ((string-match "^[uU]nderline [sS]trikeout" effects)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
857 (set-font-underline-p retval t)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
858 (set-font-strikethru-p retval t))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
859 ((string-match "[uU]nderline" effects)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
860 (set-font-underline-p retval t))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
861 ((string-match "[sS]trikeout" effects)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
862 (set-font-strikethru-p retval t)))
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
863 retval)))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 (defun mswindows-font-create-name (fontobj &optional device)
707
a307f9a2021d [xemacs-hg @ 2001-12-20 05:49:28 by andyp]
andyp
parents: 608
diff changeset
866 "Return a font name constructed from FONTOBJ, appropriate for MS Windows devices."
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 (if (and (not (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 (font-weight fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 (font-size fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 (font-registry fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 (font-encoding fontobj)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 (= (font-style fontobj) 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 (face-font 'default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 (or device (setq device (selected-device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 (let* ((default (font-default-object-for-device device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 (family (or (font-family fontobj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 (font-family default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 (weight (or (font-weight fontobj) :regular))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 (size (or (if font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 (font-size fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 (font-size default)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 (underline-p (font-underline-p fontobj))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 (strikeout-p (font-strikethru-p fontobj))
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
884 (encoding (font-encoding fontobj)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 (if (stringp family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 (setq family (list family)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 (setq weight (font-higher-weight weight
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 (and (font-bold-p fontobj) :bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 (if (stringp size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 (setq size (truncate (font-spatial-to-canonical size device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 (setq weight (or (cdr-safe
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 (assq weight mswindows-font-weight-mappings)) ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 (let ((done nil) ; Did we find a good font yet?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 (font-name nil) ; font name we are currently checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 (cur-family nil) ; current family we are checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 (while (and family (not done))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 (setq cur-family (car family)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 family (cdr family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 (if (assoc cur-family font-mswindows-family-mappings)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 ;; If the family name is an alias as defined by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 ;; font-mswindows-family-mappings, then append those families
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 ;; to the front of 'family' and continue in the loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904 (setq family (append
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 (cdr-safe (assoc cur-family
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 font-mswindows-family-mappings))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 family))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 ;; We treat oblique and italic as equivalent. Don't ask.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 ;; Courier New:Bold Italic:10:underline strikeout:western
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
910 (setq font-name (format "%s:%s:%s:%s:%s"
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
911 cur-family
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
912 (mswindows-construct-font-style
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
913 weight
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
914 (if (font-italic-p fontobj)
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 778
diff changeset
915 "Italic" ""))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 (if size
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 (int-to-string size) "10")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918 (if underline-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 (if strikeout-p
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 "underline strikeout"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 "underline")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 (if strikeout-p "strikeout" ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 (if encoding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 encoding ""))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 done (try-font-name font-name device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 (if done font-name)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 ;;; Cache building code
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 ;;;###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 (defun x-font-build-cache (&optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 (let ((hash-table (make-hash-table :test 'equal :size 15))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 (fonts (mapcar 'x-font-create-object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 (plist nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 (cur nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 (while fonts
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 (setq cur (car fonts)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 fonts (cdr fonts)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 plist (cl-gethash (car (font-family cur)) hash-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 (if (not (memq (font-weight cur) (plist-get plist 'weights)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 (setq plist (plist-put plist 'weights (cons (font-weight cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 (plist-get plist 'weights)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944 (if (not (member (font-size cur) (plist-get plist 'sizes)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 (setq plist (plist-put plist 'sizes (cons (font-size cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 (plist-get plist 'sizes)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 (if (and (font-oblique-p cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 (not (memq 'oblique (plist-get plist 'styles))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950 (if (and (font-italic-p cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951 (not (memq 'italic (plist-get plist 'styles))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 (cl-puthash (car (font-family cur)) plist hash-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 hash-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 ;;; 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
959 ;;; can deal with either syntax.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 ;;; ###autoload
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 (defun font-set-face-font (&optional face font &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 ((and (vectorp font) (= (length font) 12))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 (let ((font-name (font-create-name font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 (set-face-property face 'font-specification font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 ((null font-name) ; No matching font!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 ((listp font-name) ; For TTYs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 (let (cur)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 (while font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 (setq cur (car font-name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 font-name (cdr font-name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 (apply 'set-face-property face (car cur) (cdr cur) args))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976 (font-running-xemacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 (apply 'set-face-font face font-name args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 (apply 'set-face-underline-p face (font-underline-p font) args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 (fboundp 'set-face-display-table))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 (apply 'set-face-display-table
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 face font-caps-display-table args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 (apply 'set-face-property face 'strikethru (or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 (font-linethrough-p font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 (font-strikethru-p font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 (apply 'set-face-font face font-name args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 (error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 (let ((args (car-safe args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 (and (or (font-bold-p font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 (memq (font-weight font) '(:bold :demi-bold)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 (make-face-bold face args t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 (and (font-italic-p font) (make-face-italic face args t)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 (apply 'set-face-underline-p face (font-underline-p font) args)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 ;; Let the original set-face-font signal any errors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 (set-face-property face 'font-specification nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 (apply 'set-face-font face font args))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 ;;; Now for emacsen specific stuff
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-device-fonts (device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 ;; Update all faces that were created with the 'font' package
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 ;; to appear correctly on the new device. This should be in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 ;; create-device-hook. This is XEmacs 19.12+ specific
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 (let ((faces (face-list 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 (cur nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 (font-spec nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1013 (while faces
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 (setq cur (car faces)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 faces (cdr faces)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 font-spec (face-property cur 'font-specification))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017 (if font-spec
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 (set-face-font cur font-spec device)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020 (defun font-update-one-face (face &optional device-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021 ;; Update FACE on all devices in DEVICE-LIST
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022 ;; DEVICE_LIST defaults to a list of all active devices
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1023 (setq device-list (or device-list (device-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1024 (if (devicep device-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1025 (setq device-list (list device-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026 (let* ((cur-device nil)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1027 (font-spec (face-property face 'font-specification)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 (if (not font-spec)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029 ;; Hey! Don't mess with fonts we didn't create in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 ;; first place.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 (while device-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 (setq cur-device (car device-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 device-list (cdr device-list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1035 (if (not (device-live-p cur-device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 ;; Whoah!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037 nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038 (if font-spec
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039 (set-face-font face font-spec cur-device)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1040
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042 ;;; Various color related things
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1044 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1045 ((fboundp 'display-warning)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1046 (fset 'font-warn 'display-warning))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1047 ((fboundp 'w3-warn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1048 (fset 'font-warn 'w3-warn))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1049 ((fboundp 'url-warn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1050 (fset 'font-warn 'url-warn))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1051 ((fboundp 'warn)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1052 (defun font-warn (class message &optional level)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 (warn "(%s/%s) %s" class (or level 'warning) message)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1054 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1055 (defun font-warn (class message &optional level)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1056 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1057 (set-buffer (get-buffer-create "*W3-WARNINGS*"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1058 (goto-char (point-max))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1059 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1060 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1061 (display-buffer (current-buffer))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1062
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1063 (defun font-lookup-rgb-components (color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 "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
1065 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
1066 (let ((lib-list (if (boundp 'x-library-search-path)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1067 x-library-search-path
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1068 ;; This default is from XEmacs 19.13 - hope it covers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1069 ;; everyone.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1070 (list "/usr/X11R6/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1071 "/usr/X11R5/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1072 "/usr/lib/X11R6/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1073 "/usr/lib/X11R5/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1074 "/usr/local/X11R6/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1075 "/usr/local/X11R5/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1076 "/usr/local/lib/X11R6/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1077 "/usr/local/lib/X11R5/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 "/usr/X11/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079 "/usr/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080 "/usr/local/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 "/usr/X386/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082 "/usr/x386/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 "/usr/XFree86/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084 "/usr/unsupported/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 "/usr/athena/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1086 "/usr/local/x11r5/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087 "/usr/lpp/Xamples/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 "/usr/openwin/lib/X11/"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089 "/usr/openwin/share/lib/X11/")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090 (file font-rgb-file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091 r g b)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 (if (not file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093 (while lib-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 (setq file (expand-file-name "rgb.txt" (car lib-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 (if (file-readable-p file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 (setq lib-list nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 font-rgb-file file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 (setq lib-list (cdr lib-list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 file nil))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1100 (if (null file)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101 (list 0 0 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1102 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103 (set-buffer (find-file-noselect file))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 (if (not (= (aref (buffer-name) 0) ? ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105 (rename-buffer (generate-new-buffer-name " *rgb-tmp-buffer*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 (save-excursion
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107 (save-restriction
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108 (widen)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109 (goto-char (point-min))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 (if (re-search-forward (format "\t%s$" (regexp-quote color)) nil t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1111 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1112 (beginning-of-line)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1113 (setq r (* (read (current-buffer)) 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1114 g (* (read (current-buffer)) 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1115 b (* (read (current-buffer)) 256)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1116 (font-warn 'color (format "No such color: %s" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1117 (setq r 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1118 g 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 b 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 (list r g b) ))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1121
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1122 (defun font-hex-string-to-number (string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1123 "Convert STRING to an integer by parsing it as a hexadecimal number."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1124 (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 (?1 . 1) (?b . 11) (?B . 11)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 (?2 . 2) (?c . 12) (?C . 12)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127 (?3 . 3) (?d . 13) (?D . 13)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128 (?4 . 4) (?e . 14) (?E . 14)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129 (?5 . 5) (?f . 15) (?F . 15)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 (?6 . 6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131 (?7 . 7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132 (?8 . 8)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 (?9 . 9)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134 (n 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135 (i 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 (lim (length string)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137 (while (< i lim)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 (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
1139 i (1+ i)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 n ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1142 (defun font-parse-rgb-components (color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1143 "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
1144 #FEFEFE and rgb:fe/fe/fe style specifications are parsed."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 (let ((case-fold-search t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 r g b str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147 (cond ((string-match "^#[0-9a-f]+$" color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 ((= (length color) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 (setq r (font-hex-string-to-number (substring color 1 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 g (font-hex-string-to-number (substring color 2 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 b (font-hex-string-to-number (substring color 3 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 r (* r 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 g (* g 4096)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 b (* b 4096)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156 ((= (length color) 7)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 (setq r (font-hex-string-to-number (substring color 1 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 g (font-hex-string-to-number (substring color 3 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 b (font-hex-string-to-number (substring color 5 7))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160 r (* r 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 g (* g 256)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 b (* b 256)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 ((= (length color) 10)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164 (setq r (font-hex-string-to-number (substring color 1 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 g (font-hex-string-to-number (substring color 4 7))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 b (font-hex-string-to-number (substring color 7 10))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 r (* r 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 g (* g 16)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 b (* b 16)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 ((= (length color) 13)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 (setq r (font-hex-string-to-number (substring color 1 5))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172 g (font-hex-string-to-number (substring color 5 9))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1173 b (font-hex-string-to-number (substring color 9 13))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175 (font-warn 'color (format "Invalid RGB color specification: %s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1176 color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177 (setq r 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1178 g 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1179 b 0))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1180 ((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1181 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1182 (if (or (> (- (match-end 1) (match-beginning 1)) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1183 (> (- (match-end 2) (match-beginning 2)) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1184 (> (- (match-end 3) (match-beginning 3)) 4))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185 (error "Invalid RGB color specification: %s" color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1186 (setq str (match-string 1 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1187 r (* (font-hex-string-to-number str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1188 (expt 16 (- 4 (length str))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1189 str (match-string 2 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1190 g (* (font-hex-string-to-number str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1191 (expt 16 (- 4 (length str))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1192 str (match-string 3 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1193 b (* (font-hex-string-to-number str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1194 (expt 16 (- 4 (length str)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1195 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196 (font-warn 'html (format "Invalid RGB color specification: %s"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197 color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1198 (setq r 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 g 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200 b 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1201 (list r g b) ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1203 (defun font-rgb-color-p (obj)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 (or (and (vectorp obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 (= (length obj) 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 (eq (aref obj 0) 'rgb))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1208 (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
1209 (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
1210 (defun font-rgb-color-blue (obj) (aref obj 3))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212 (defun font-color-rgb-components (color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1213 "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
1214 16-bit values are always returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 #FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 into their components.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 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
1218 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
1219 (let ((case-fold-search t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 ((and (font-rgb-color-p color) (floatp (aref color 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222 (list (* 65535 (aref color 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 (* 65535 (aref color 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 (* 65535 (aref color 2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 ((font-rgb-color-p color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 (list (font-rgb-color-red color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 (font-rgb-color-green color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 (font-rgb-color-blue color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 ((and (vectorp color) (= 3 (length color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 (list (aref color 0) (aref color 1) (aref color 2)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 ((and (listp color) (= 3 (length color)) (floatp (car color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 (mapcar #'(lambda (x) (* x 65535)) color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 ((and (listp color) (= 3 (length color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 ((or (string-match "^#" color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 (string-match "^rgb:" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1237 (font-parse-rgb-components color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1238 ((string-match "\\([0-9.]+\\)[ \t]\\([0-9.]+\\)[ \t]\\([0-9.]+\\)"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1239 color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240 (let ((r (string-to-number (match-string 1 color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1241 (g (string-to-number (match-string 2 color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1242 (b (string-to-number (match-string 3 color))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 (if (floatp r)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 (setq r (round (* 255 r))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 g (round (* 255 g))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 b (round (* 255 b))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 (font-parse-rgb-components (format "#%02x%02x%02x" r g b))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 (font-lookup-rgb-components color)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1251 (defun font-tty-compute-color-delta (col1 col2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 (+
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 (* (- (aref col1 0) (aref col2 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 (- (aref col1 0) (aref col2 0)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255 (* (- (aref col1 1) (aref col2 1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1256 (- (aref col1 1) (aref col2 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 (* (- (aref col1 2) (aref col2 2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 (- (aref col1 2) (aref col2 2)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 (defun font-tty-find-closest-color (r g b)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 ;; This is basically just a lisp copy of allocate_nearest_color
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 ;; from objects-x.c from Emacs 19
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 ;; We really should just check tty-color-list, but unfortunately
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264 ;; that does not include any RGB information at all.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1265 ;; 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
1266 ;; good for now.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 (setq r (/ r 65535.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 g (/ g 65535.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269 b (/ b 65535.0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1270 (let* ((color_def (vector r g b))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 (colors [([1.0 1.0 1.0] . "white")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 ([0.0 1.0 1.0] . "cyan")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 ([1.0 0.0 1.0] . "magenta")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 ([0.0 0.0 1.0] . "blue")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 ([1.0 1.0 0.0] . "yellow")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 ([0.0 1.0 0.0] . "green")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 ([1.0 0.0 0.0] . "red")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 ([0.0 0.0 0.0] . "black")])
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279 (no_cells (length colors))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1280 (x 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 (nearest 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 (nearest_delta 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 (trial_delta 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 (setq nearest_delta (font-tty-compute-color-delta (car (aref colors 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 color_def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 (while (/= no_cells x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 (setq trial_delta (font-tty-compute-color-delta (car (aref colors x))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 color_def))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 (if (< trial_delta nearest_delta)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1290 (setq nearest x
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 nearest_delta trial_delta))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 (setq x (1+ x)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 (cdr-safe (aref colors nearest))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 (defun font-normalize-color (color &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 "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
1297 is returned."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298 (case (device-type device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1299 ((x pm)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 (mswindows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 (let* ((rgb (font-color-rgb-components color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 (color (apply 'format "#%02x%02x%02x" rgb)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 (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
1305 color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 (tty
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 (ns
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
1309 (let ((vals (mapcar #'(lambda (x) (lsh x -8))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 (font-color-rgb-components color))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 (apply 'format "RGB%02x%02x%02xff" vals)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 (otherwise
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 color)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315 (defun font-set-face-background (&optional face color &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 ((or (font-rgb-color-p color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 (string-match "^#[0-9a-fA-F]+$" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 (apply 'set-face-background face
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1322 (font-normalize-color color) args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 (apply 'set-face-background face color args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 (error nil)))
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-set-face-foreground (&optional face color &rest args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 (interactive)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329 (condition-case nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1331 ((or (font-rgb-color-p color)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 (string-match "^#[0-9a-fA-F]+$" color))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333 (apply 'set-face-foreground face (font-normalize-color color) args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 (apply 'set-face-foreground face color args)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 (error nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 ;;; Support for 'blinking' fonts
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 (defun font-map-windows (func &optional arg frame)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 (let* ((start (selected-window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 (cur start)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 (result nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 (push (funcall func start arg) result)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 (while (not (eq start (setq cur (next-window cur))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 (push (funcall func cur arg) result))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 result))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350 (defun font-face-visible-in-window-p (window face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 (let ((st (window-start window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 (nd (window-end window))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 (found nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354 (face-at nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 (setq face-at (get-text-property st 'face (window-buffer window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 (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
1357 (setq found t))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 (while (and (not found)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 (/= nd
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360 (setq st (next-single-property-change
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 st 'face
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362 (window-buffer window) nd))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 (setq face-at (get-text-property st 'face (window-buffer window)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364 (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
1365 (setq found t)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366 found))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368 (defun font-blink-callback ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369 ;; Optimized to never invert the face unless one of the visible windows
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 ;; is showing it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 (let ((faces (if font-running-xemacs (face-list t) (face-list)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 (obj nil))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 (while faces
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 (if (and (setq obj (face-property (car faces) 'font-specification))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1375 (font-blink-p obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1376 (memq t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377 (font-map-windows 'font-face-visible-in-window-p (car faces))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378 (invert-face (car faces)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 (pop faces))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1381 (defcustom font-blink-interval 0.5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 "How often to blink faces"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383 :type 'number
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 :group 'faces)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 (defun font-blink-initialize ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1388 ((featurep 'itimer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1389 (if (get-itimer "font-blinker")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1390 (delete-itimer (get-itimer "font-blinker")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1391 (start-itimer "font-blinker" 'font-blink-callback
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1392 font-blink-interval
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1393 font-blink-interval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1394 ((fboundp 'run-at-time)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 (cancel-function-timers 'font-blink-callback)
776
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 707
diff changeset
1396 (declare-fboundp (run-at-time font-blink-interval
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 707
diff changeset
1397 font-blink-interval
79940b592197 [xemacs-hg @ 2002-03-15 07:43:14 by ben]
ben
parents: 707
diff changeset
1398 'font-blink-callback)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399 (t nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401 (provide 'font)